deSolve/0000755000176000001440000000000013603425023011701 5ustar ripleyusersdeSolve/NAMESPACE0000644000176000001440000000124213136461015013121 0ustar ripleyusersuseDynLib(deSolve) import(methods, graphics, grDevices, stats) export(aquaphy, ccl4model, SCOC, daspk, lsoda, lsodar, lsode, lsodes, ode, ode.1D, ode.2D, ode.3D, ode.band, vode, zvode, radau) export(rk, rk4, euler, euler.1D, rkMethod, lagvalue, lagderiv, dede) export(timestep, nearestEvent, cleanEventTimes, plot.1D, matplot.0D, matplot.1D, matplot.deSolve) exportPattern("^diagnostics.*") export(DLLfunc, DLLres) S3method("print", "deSolve") S3method("plot", "deSolve") S3method("image", "deSolve") S3method("hist", "deSolve") S3method("summary", "deSolve") S3method("subset", "deSolve") S3method("diagnostics", "deSolve") S3method("diagnostics", "default") deSolve/demo/0000755000176000001440000000000013136461011012623 5ustar ripleyusersdeSolve/demo/CCL4model.R0000644000176000001440000002562513136461011014466 0ustar ripleyusers### Functions to facilitate fitting the CCl4 inhalation model initparms <- function(...) { arglist <- list(...) Pm <- numeric(36) ## The Changeable parameters are ones that can be modified on input Changeable <- c("BW", "QP", "QC", "VFC", "VLC", "VMC", "QFC", "QLC", "QMC", "PLA", "PFA", "PMA", "PTA", "PB", "MW", "VMAX", "KM", "CONC", "KL", "RATS", "VCHC") ## Computed parameters are strictly functions of the Changeable ones. Computed <- c("VCH", "AI0", "PL", "PF", "PT", "PM", "VTC", "VT", "VF", "VL", "VM", "QF", "QL", "QM", "QT") names(Pm) <- c(Changeable, Computed ) ### Physiological parameters Pm["BW"] <- 0.182 # Body weight (kg) Pm["QP"] <- 4.0 # Alveolar ventilation rate (hr^-1) Pm["QC"] <- 4.0 # Cardiac output (hr^-1) Pm["VFC"] <- 0.08 # Fraction fat tissue (kg/(kg/BW)) Pm["VLC"] <- 0.04 # Fraction liver tissue (kg/(kg/BW)) Pm["VMC"] <- 0.74 # Fraction of muscle tissue (kg/(kg/BW)) Pm["QFC"] <- 0.05 # Fractional blood flow to fat ((hr^-1)/QC Pm["QLC"] <- 0.15 # Fractional blood flow to liver ((hr^-1)/QC) Pm["QMC"] <- 0.32 # Fractional blood flow to muscle ((hr^-1)/QC) ## Chemical specific parameters for chemical Pm["PLA"] <- 16.17 # Liver/air partition coefficient Pm["PFA"] <- 281.48 # Fat/air partition coefficient Pm["PMA"] <- 13.3 # Muscle/air partition coefficient Pm["PTA"] <- 16.17 # Viscera/air partition coefficient Pm["PB"] <- 5.487 # Blood/air partition coefficient Pm["MW"] <- 153.8 # Molecular weight (g/mol) Pm["VMAX"] <- 0.11 # Maximum velocity of metabolism (mg/hr) Pm["KM"] <- 1.3 # Michaelis-Menten constant (mg/l) ## Parameters for simulated experiment Pm["CONC"] <- 1000 # Inhaled concentration Pm["KL"] <- 0.02 # Loss rate from empty chamber /hr Pm["RATS"] <- 1.0 # Number of rats enclosed in chamber Pm["VCHC"] <- 3.8 # Volume of closed chamber (l) ## Now, change anything from the argument list ## First, delete anything in arglist that is not in Changeable whichdel <- which(! names(arglist) %in% Changeable) if (length(whichdel)) { warning(paste("Parameters", paste(names(arglist)[whichdel], collapse=", "), "are not in this model\n")) } arglist[whichdel] <- NULL ## Is there anything else if (length(arglist)) { Pm[names(arglist)] <- as.vector(unlist(arglist)) } ## Computed parameter values Pm["VCH"] <- Pm["VCHC"] - Pm["RATS"]*Pm["BW"] # Net chamber volume Pm["AI0"] <- Pm["CONC"]*Pm["VCH"]*Pm["MW"]/24450 # Initial amt. in chamber (mg) Pm[c("PL", "PF", "PT", "PM")] <- Pm[c("PLA", "PFA", "PTA", "PMA")]/Pm["PB"] ## Fraction viscera (kg/(kg BW)) Pm["VTC"] <- 0.91 - sum(Pm[c("VLC", "VFC", "VMC")]) Pm[c("VT", "VF", "VL", "VM")] <- Pm[c("VTC", "VFC", "VLC", "VMC")]*Pm["BW"] Pm[c("QF", "QL", "QM")] <- Pm[c("QFC", "QLC", "QMC")]*Pm["QC"] Pm["QT"] <- Pm["QC"] - sum(Pm[c("QF", "QL", "QM")]) Pm } ### We don't actually use these functions (though they work) ### They exist because cclmodel.orig is easier to read than ccl4modelG ### The model function also computes some values that are of interest in ### checking the model and for calculating a dose metric: ### the amount metabolized (AM) ### the area under the concentration-time curve in the liver (CLT) ### and the mass balance (MASS), which should be constant if everything ### worked right. ## State variable, y, assignments. ## CI CM CT CF CL ## AI AAM AT AF AL CLT AM ## 1 2 3 4 5 6 7 initstate.orig <- function(Pm) { y <- rep(0, 7) names(y) <- c("AI", "AAM", "AT", "AF", "AL", "CLT", "AM") y["AI"] <- Pm["AI0"] y } parms <- initparms() ccl4model.orig <- with(as.list(parms), function(t, y, parms) { conc <- y[c("AI", "AAM", "AT", "AF", "AL")]/c(VCH, VM, VT, VF, VL) ## Vconc[1] is conc in mixed venous blood Vconc <- c(0, conc[2:5]/parms[c("PM", "PT", "PF", "PL")]) # '0' is a placeholder Vconc[1] <- sum(Vconc[2:5]*c(QM, QT, QF, QL))/QC ## CA is conc in arterial blood CA <- (QC * Vconc[1] + QP * conc[1])/ (QC + QP/PB) ## Exhaled chemical CX <- CA/PB ## return the derivatives and other computed items list(c(RATS*QP*(CX - conc[1]) - KL*y["AI"], QM*(CA - Vconc[2]), QT*(CA - Vconc[3]), QF*(CA - Vconc[4]), QL*(CA - Vconc[5]) - (RAM <- VMAX*Vconc[5]/(KM + Vconc[5])), conc[5], RAM), c(DOSE = as.vector(AI0 - y["AI"]), MASS = as.vector(sum(y[c("AAM","AT", "AF", "AL", "AM")])*RATS), CP=as.vector(conc[1]*24450.0/MW) )) }) ### Versions that only calculate what is needed for parameter estimation initparmmx <- function(parms) { mx <- matrix(nrow=5, ncol=7) mx[1, 6] <- parms["VCH"] mx[1, 7] <- parms["MW"] mx[4, 6] <- parms["VL"]*parms["PL"] mx[5, 6] <- parms["VMAX"] mx[5, 7] <- parms["KM"] mxx <- matrix(parms[c("QP", "QM", "QT", "QF", "QL")], nrow=5, ncol=5, byrow=TRUE) mxx <- sweep(mxx, 2, parms[c("VCH", "VM", "VT", "VF", "VL")], "/") mxx <- sweep(mxx, 2, c(1, parms[c("PM", "PT", "PF", "PL")]), "/") mxx <- mxx/(parms["QC"] + parms["QP"]/parms["PB"]) mxx <- sweep(mxx, 1, c(parms["RATS"]*parms["QP"]/parms["PB"], parms[c("QM", "QT", "QF", "QL")]), "*") dg <- diag(c(parms["RATS"]*parms["QP"]/parms["VCH"] + parms["KL"], parms[c("QM", "QT", "QF", "QL")]/ (parms[c("PM", "PT", "PF", "PL")]*parms[c("VM", "VT", "VF", "VL")]))) mxx <- mxx - dg mx[1:5, 1:5] <- mxx mx } ### Now, include the gradients wrt Vmax, Km, and initial chamber concentration initstateG <- function(Pm) { y <- rep(0, 20) names(y) <- c("AI", "AAM", "AT", "AF", "AL", "dAIdVm", "dAAMdVm", "dATdVm", "dAFdVm", "dALdVm", "dAIdK", "dAAMdK", "dATdK", "dAFdK", "dALdK", "dAIdy0", "dAAMdy0", "dATdy0", "dAFdy0", "dALdy0" ) y["AI"] <- Pm["AI0"] y["dAIdy0"] <- Pm["VCH"] * Pm["MW"]/24450.0 y } ccl4modelG <- function(t, y, parms) { list(c(parms[,1:5] %*% y[1:5] - c(0, 0, 0, 0, parms[5, 6]*y[5] / ((Kms <- parms[5, 7]*parms[4, 6]) + y[5])), parms[, 1:5] %*% y[6:10] - c(0, 0, 0, 0, y[5]/(Kms + y[5]) + parms[5, 6]*Kms*y[10]/ (Kms + y[5])^2), parms[, 1:5] %*% y[11:15] - c(0, 0, 0, 0, parms[5, 6]*(y[15]*Kms - parms[4, 6]*y[5])/ (Kms + y[5])^2), parms[,1:5] %*% y[16:20] - c(0, 0, 0, 0, parms[5, 6]*Kms*y[20]/(Kms + y[5])^2) ), c(CP = as.vector(y[1]*(zz <- 24450.0/parms[1, 6]/parms[1, 7])), dCPdVm = as.vector(y[6]*zz), dCPdK = as.vector(y[11]*zz), dCPdy0 = as.vector(y[16]*zz) ) ) } ### Function to use in gnls. This is more complicated than usual for such ### functions, because each value for each animal depends on the previous ### value for that animal. Normal vectorization doesn't work. Work with ### log(Vmax) and log(Km) ccl4gnls <- function(time, initconc, lVmax, lKm, lconc) { Vmax <- if(length(lVmax) == 1) rep(exp(lVmax), length(time)) else exp(lVmax) Km <- if (length(lKm) == 1) rep(exp(lKm), length(time)) else exp(lKm) conc <- if (length(lconc) == 1) rep(exp(lconc), length(time)) else exp(lconc) Concs <- levels(initconc) CP <- numeric(length(time)) .grad <- matrix(nrow=length(time), ncol=3, dimnames=list(NULL, c("lVmax", "lKm", "lconc"))) ### Run the model once for each unique initial concentration for (Conc in Concs) { sel <- initconc == Conc parms <- initparms(CONC=conc[sel][1], VMAX=Vmax[sel][1], KM=Km[sel][1]) parmmx <- initparmmx(parms) y <- initstateG(parms) TTime <- sort(unique(time[sel])) if (! 0 %in% TTime) TTime <- c(0, TTime) out <- lsoda(y, TTime, ccl4modelG, parmmx, rtol=1e-12, atol=1e-12) CP[sel] <- out[match(time[sel], out[,"time"]),"CP"] .grad[sel, "lVmax"] <- out[match(time[sel], out[, "time"]), "dCPdVm"] .grad[sel, "lKm"] <- out[match(time[sel], out[, "time"]), "dCPdK"] .grad[sel, "lconc"] <- out[match(time[sel], out[, "time"]), "dCPdy0"] } .grad <- .grad * cbind(Vmax, Km, conc) attr(CP, "gradient") <- .grad CP } if (require(nlme, quietly=TRUE)) { start <- log(c(lVmax = 0.11, lKm=1.3, 25, 100, 250, 1000)) ### Data are from: ### Evans, et al. (1994) Applications of sensitivity analysis to a ### physiologically ### based pharmacokinetic model for carbon tetrachloride in rats. ### Toxicology and Applied Pharmacology 128: 36--44. data(ccl4data) ccl4data.avg<-aggregate(ccl4data$ChamberConc, by=ccl4data[c("time", "initconc")], mean) names(ccl4data.avg)[3]<-"ChamberConc" ### Estimate log(Vmax), log(Km), and the logs of the initial ### concentrations with gnls cat("\nThis may take a little while ... \n") ccl4.gnls <- gnls(ChamberConc ~ ccl4gnls(time, factor(initconc), lVmax, lKm, lconc), params = list(lVmax + lKm ~ 1, lconc ~ factor(initconc)-1), data=ccl4data.avg, start=start, weights=varPower(fixed=1), verbose=TRUE) start <- coef(ccl4.gnls) ccl4.gnls2 <- gnls(ChamberConc ~ ccl4gnls(time, factor(initconc), lVmax, lKm, lconc), params = list(lVmax + lKm ~ 1, lconc ~ factor(initconc)-1), data=ccl4data, start=start, weights=varPower(fixed=1), verbose=TRUE) print(summary(ccl4.gnls2)) ### Now fit a separate initial concentration for each animal start <- c(coef(ccl4.gnls)) cat("\nApprox. 95% Confidence Intervals for Metabolic Parameters:\n") tmp <- exp(intervals(ccl4.gnls2)[[1]][1:2,]) row.names(tmp) <- c("Vmax", "Km") print(tmp) cat("\nOf course, the statistical model is inappropriate, since\nthe concentrations within animal are pretty highly autocorrelated:\nsee the graph.\n") opar <- par(ask=TRUE, no.readonly=TRUE) plot(ChamberConc ~ time, data=ccl4data, xlab="Time (hours)", xlim=range(c(0, ccl4data$time)), ylab="Chamber Concentration (ppm)", log="y") out <- predict(ccl4.gnls2, newdata=ccl4data.avg) concentrations <- sort(unique(ccl4data$initconc)) for (conc in concentrations) { times <- ccl4data.avg$time[sel <- ccl4data.avg$initconc == conc] CP <- out[sel] lines(CP ~ times) } par(opar) } else { cat("This example requires the package nlme\n") } deSolve/demo/00Index0000644000176000001440000000022113136461011013750 0ustar ripleyusersCCL4model Use gnls to estimate parameters for CCl4 PBPK model odedim Lotka-Volterra dynamics in 1-D and in 2-D, using ode.1D and ode.2D deSolve/demo/odedim.R0000644000176000001440000001411513136461011014211 0ustar ripleyuserspa <- par (ask=FALSE) ##===================================================== ## a predator and its prey diffusing on a flat surface ## in concentric circles ## 1-D model with using cylindrical coordinates ## Lotka-Volterra type biology ##===================================================== ## ================ ## Model equations ## ================ lvmod <- function (time, state, parms, N, rr, ri, dr, dri) { with (as.list(parms), { PREY <- state[1:N] PRED <- state[(N+1):(2*N)] ## Fluxes due to diffusion ## at internal and external boundaries: zero gradient FluxPrey <- -Da * diff(c(PREY[1], PREY, PREY[N]))/dri FluxPred <- -Da * diff(c(PRED[1], PRED, PRED[N]))/dri ## Biology: Lotka-Volterra model Ingestion <- rIng * PREY*PRED GrowthPrey <- rGrow * PREY*(1-PREY/cap) MortPredator <- rMort * PRED ## Rate of change = Flux gradient + Biology dPREY <- -diff(ri * FluxPrey)/rr/dr + GrowthPrey - Ingestion dPRED <- -diff(ri * FluxPred)/rr/dr + Ingestion*assEff -MortPredator return (list(c(dPREY, dPRED))) }) } ## ================== ## Model application ## ================== ## model parameters: R <- 20 # total radius of surface, m N <- 100 # 100 concentric circles dr <- R/N # thickness of each layer r <- seq(dr/2, by = dr, len = N) # distance of center to mid-layer ri <- seq(0, by = dr, len = N+1) # distance to layer interface dri <- dr # dispersion distances parms <- c(Da = 0.05, # m2/d, dispersion coefficient rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of pred assEff = 0.5, # -, assimilation efficiency cap = 10) # density, carrying capacity ## Initial conditions: both present in central circle (box 1) only state <- rep(0, 2*N) state[1] <- state[N+1] <- 10 ## RUNNING the model: times <- seq(0, 140, by = 0.1) # output wanted at these time intervals ## the model is solved by the two implemented methods: ## 1. Default: banded reformulation print(system.time( out <- ode.1D(y = state, times = times, func = lvmod, parms = parms, nspec = 2, N = N, rr = r, ri = ri, dr = dr, dri = dri) )) ## 2. Using sparse method print(system.time( out2 <- ode.1D(y = state, times = times, func = lvmod, parms = parms, nspec = 2, N = N, rr = r, ri = ri, dr = dr, dri = dri, method = "lsodes") )) # diagnostics of the run diagnostics(out) # plot results ylim <- range(out[,-1]) for (i in seq(1, length(times), by = 1)) { matplot(r, matrix(nr = N, nc = 2, out[i, -1]), main=paste("1-D L-V, day",times[i]), type="l", lwd=2, col = c("blue", "red"), xlab = "x", ylab = "y", ylim = ylim) legend("topright", c("Prey", "Predator"), col= c("blue", "red"), lwd=2) } ## ============================================================ ## A Lotka-Volterra predator-prey model with predator and prey ## dispersing in 2 dimensions ## ============================================================ lvmod2D <- function (time, state, pars, N, Da, dx) { NN <- N*N Prey <- matrix(nr = N, nc = N, state[1:NN]) Pred <- matrix(nr = N, nc = N, state[(NN+1):(2*NN)]) with (as.list(pars), { ## Biology dPrey <- rGrow* Prey *(1- Prey/K) - rIng* Prey *Pred dPred <- rIng* Prey *Pred*assEff -rMort* Pred zero <- rep(0, N) ## 1. Fluxes in x-direction; zero fluxes near boundaries FluxPrey <- -Da * rbind(zero, (Prey[2:N, ]-Prey[1:(N-1),]), zero)/dx FluxPred <- -Da * rbind(zero, (Pred[2:N, ]-Pred[1:(N-1),]), zero)/dx ## Add flux gradient to rate of change dPrey <- dPrey - (FluxPrey[2:(N+1),]-FluxPrey[1:N,])/dx dPred <- dPred - (FluxPred[2:(N+1),]-FluxPred[1:N,])/dx ## 2. Fluxes in y-direction; zero fluxes near boundaries FluxPrey <- -Da * cbind(zero, (Prey[, 2:N]-Prey[,1:(N-1)]), zero)/dx FluxPred <- -Da * cbind(zero, (Pred[,2:N]-Pred[,1:(N-1)]), zero)/dx ## Add flux gradient to rate of change dPrey <- dPrey - (FluxPrey[, 2:(N+1)]-FluxPrey[, 1:N])/dx dPred <- dPred - (FluxPred[, 2:(N+1)]-FluxPred[, 1:N])/dx return (list(c(as.vector(dPrey), as.vector(dPred)))) }) } ## =================== ## Model applications ## =================== pars <- c(rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2, # /day, mortality rate of predator assEff = 0.5, # -, assimilation efficiency K = 5 ) # mmol/m3, carrying capacity R <- 20 # total length of surface, m N <- 50 # number of boxes in one direction dx <- R/N # thickness of each layer Da <- 0.05 # m2/d, dispersion coefficient NN <- N*N # total number of boxes ## initial conditions yini <- rep(0, 2*N*N) cc <- c((NN/2):(NN/2+1) + N/2, (NN/2):(NN/2+1) - N/2) yini[cc] <- yini[NN + cc] <- 1 ## solve model (5000 state variables... times <- seq(0, 75, by = 0.1) out <- ode.2D(y = yini, times = times, func = lvmod2D, parms = pars, dimens = c(N, N), N = N, dx = dx, Da = Da, lrw = 500000) ## plot results Col <- colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000")) zlim <- range(out[, 2:(NN+1)]) for (i in seq(1, length(times), by = 10)) filled.contour(matrix(nr = N, nc = N, out[i, 2:(NN+1)]), main=paste("2-D L-V, day", times[i]), color = Col, xlab = "x", ylab = "y", zlim = zlim) for (i in seq(1, length(times), by = 1)) { Prey <- out[i, (2+N):(1+2*N)] Pred <- out[i, NN+(2+N):(1+2*N)] matplot(1:N, cbind(Prey, Pred), main=paste("2-D L-V, day", times[i]), type = "l", lwd = 2, col = c("blue","red"), xlab = "x", ylab = "Conc", ylim = ylim) legend("topright", c("Prey", "Predator"), col = c("blue", "red"), lwd = 2) } par(pa) deSolve/.Rinstignore0000644000176000001440000000005113136461011014177 0ustar ripleyusersinst/doc/aphid.png inst/doc/image1D.png deSolve/data/0000755000176000001440000000000013136461014012613 5ustar ripleyusersdeSolve/data/ccl4data.rda0000644000176000001440000001212413603407646014774 0ustar ripleyuserswTTGW5* (Xan"ߥ"(:uYJGP!BǞGcXcػ1UccMl_{$Iߞk>!5šmÒNC{`M8Xּ5_Ϛwv gdFCk5jͻUn4%jCѿ5nͻ[Mf|3k5aOn~jvߚOwszMsoD F$nּytQyk5n7Zͬ|skÒv^jMwjȬ[nIm][T[ֵNֵum5um][j̾~Kf~vؿe-)oYqzJݷ{[V\޲R-+ ޮn8ꍺ<1pK)S7cS'cFaѶmkقp[a "mA[e mAO[c zقXWsr!|8d~؋z[*YwGw-GԼA]TD>mwK(w*Y>VW¢y1[5nCQ鸡7AYH}Jjyz~HP+OGC ,"J|=m3|W/8Ž7a'Qt'j()(P4"ZhO?PaBo@:7 '[8mƢoֻFcPcG9 Vw7L\vO9jdt>uQܳ|I~?ͶIO~vyԝQ<7*Lݹxc]<蝅1Ø(Ob-}u'T?rMsh\gb)B1u5'ℜBݏ_o/ϔҒBQlo錀 Qt䒐s(i=v(ֹpnD}PpvXju0ɑ~OL_e|)&'@Aw QٲYSK9G?pPIWhh?ѕCGq%b^\]=1v湷ل=]6 cf= cu-QiIPI.@*LtyvFi˸FgPоJ/vF;Zd{({{XXnp(3wXo)=$ Ι(.=pzd>PPmj ]'#,3K~YdNj~킌,ߚu4,gӟsz@T] =u]d mc^MlkfYC6.\}4`5=he= j⫅Xly8 }xx7鬱p6/T! -o5Zv虸RՉFHYSn"e?K O#銮z}OTo GriVFQ+qzV[p6;1NfS kD!w67뀡jK]Ix!7>'FZ&`̯0ȋ9™eH?pRSiinV3bRoN!e*#%wFdH޲f?"($?1u2!ir7$DK@++"by^ҍQH\&Nצ#Hi$6_.N]~H F1bYuXua:dNr9n=lYIeӖkǼ 0dvc2z/'.Hs>ӰZEE慎bBBJe_?gab2ԼF򀦾գ&#w>C;GRn0$%9 w1/ĊJCbd@mAŇ l9#80 ABCҐNzX(71 I/Er}A\#Vvsm ļ̊޷m bZz[|t{ilXvz> l6*R^b&h7'!t76@BףމƀVï\~]ޘ }68 qGEGl㋻Gs:|SY'"zQC?W$z,}Np)"\ضb[D-uѹh!|]/SEnskM8'MWmO}L1@#1n+ͷoXb9`V-&|v&nBcSo t<EgN=#v"P.e$v28k/n6Yf=ŀ{+ߙ{oOfk>wnLإC=I>j1ĭꚹ-̧qw*|%k r wz JfjC+3[Y:Լq bW0pCeN"lEݭXA<_h_ּ|vоۡ]b{h} Ftw) ĵ8#e9|fhFע= {oC@WC^۾;fM<~ḼjSUOpSHZ 0_˺ ze{DFu! c;:u|^褨7;:YةG+7؞[Ek~_/r|:uGRڱζOηx#W4z.?.]o-P+aܶ% K#*OTx}yWRO%ٯZ|<ۅn+ږ֍)j=@yYbxbSy/KÏ:OA+,Uw ^=? vOy*CN -^W<L߲i^_SS3f𝐵x3h_mAErqj[ 3=?"B G[9i^x7ۭNb~׮2ȫ'Lxyo׎lƪ {ð5x<- K콠Z|BCP~ [pBVm2s| c<߃C2y=;&ۻ_B hp|:7_F Z3$v}Ҟq{G-gUcy6 vMuWvOz+t矟@}@-s(3l7֤C!; 9|)Go]uF_ótC3re\SQ_Zvl -@ [*[k`$ERĤK E )RJJR$1`I &1`I &1`K .1K .1K .1!H AbC$ 1!H PH PH PH PH PH PJ PJ PJ PJ PJ PI PI PI PI PI PK PK PK PK PK H H H H AAS( *(TRPM!тL`-hD &Z0тL4F4F4F4F4F4F4F4F4F4F4N4N4N4N4N4N4N4N4N4N4h Ԯ@ Ԯ@ ԮUP jWAP(DSMA4DSMI4%єDSMI4%єDSMI4TDSME4TDSME4TDSMM45DSMM45DSMM4 4DMC4 4DMC4  D#0r #0r #0r #0r #0r #0r #0r #0r #0r #0r #0r #0r #0r #0#0#0#0#0#0#0#0#0#0#0#0#0#0'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'pN.N.N.N.N.N.N.N.N.N.N.N.N.N.%D \"Kr@.%D \"Kr@.%D \"Kr@.%D \"Kr@.D<#{#7\D`f.;Ort:}#v^ͷeec[s6R0#/WLن|YͷF7eggٙ7ww\crS<<8XgrL.| 7?;3r_r幙} \details{ The \code{lagvalue} and \code{lagderiv} can only be called during the integration, the lagged time should not be smaller than the initial simulation time, nor should it be larger than the current simulation time. Cubic Hermite interpolation is used to obtain an accurate interpolant at the requested lagged time. } \seealso{ \link{dede}, for how to implement delay differential equations. } \examples{ ## ============================================================================= ## exercise 6 from Shampine and Thompson, 2000 ## solving delay differential equations with dde23 ## ## two lag values ## ============================================================================= ##----------------------------- ## the derivative function ##----------------------------- derivs <- function(t, y, parms) { History <- function(t) c(cos(t), sin(t)) if (t < 1) lag1 <- History(t - 1)[1] else lag1 <- lagvalue(t - 1)[1] # returns a vector; select first element if (t < 2) lag2 <- History(t - 2)[2] else lag2 <- lagvalue(t - 2,2) # faster than lagvalue(t - 2)[2] dy1 <- lag1 * lag2 dy2 <- -y[1] * lag2 list(c(dy1, dy2), lag1 = lag1, lag2 = lag2) } ##----------------------------- ## parameters ##----------------------------- r <- 3.5; m <- 19 ##----------------------------- ## initial values and times ##----------------------------- yinit <- c(y1 = 0, y2 = 0) times <- seq(0, 20, by = 0.01) ##----------------------------- ## solve the model ##----------------------------- yout <- dede(y = yinit, times = times, func = derivs, parms = NULL, atol = 1e-9) ##----------------------------- ## plot results ##----------------------------- plot(yout, type = "l", lwd = 2) ## ============================================================================= ## The predator-prey model with time lags, from Hale ## problem 1 from Shampine and Thompson, 2000 ## solving delay differential equations with dde23 ## ## a vector with lag valuess ## ============================================================================= ##----------------------------- ## the derivative function ##----------------------------- predprey <- function(t, y, parms) { tlag <- t - 1 if (tlag < 0) ylag <- c(80, 30) else ylag <- lagvalue(tlag) # returns a vector dy1 <- a * y[1] * (1 - y[1]/m) + b * y[1] * y[2] dy2 <- c * y[2] + d * ylag[1] * ylag[2] list(c(dy1, dy2)) } ##----------------------------- ## parameters ##----------------------------- a <- 0.25; b <- -0.01; c <- -1 ; d <- 0.01; m <- 200 ##----------------------------- ## initial values and times ##----------------------------- yinit <- c(y1 = 80, y2 = 30) times <- seq(0, 100, by = 0.01) #----------------------------- # solve the model #----------------------------- yout <- dede(y = yinit, times = times, func = predprey, parms = NULL) ##----------------------------- ## display, plot results ##----------------------------- plot(yout, type = "l", lwd = 2, main = "Predator-prey model", mfrow = c(2, 2)) plot(yout[,2], yout[,3], xlab = "y1", ylab = "y2", type = "l", lwd = 2) diagnostics(yout) ## ============================================================================= ## ## A neutral delay differential equation (lagged derivative) ## y't = -y'(t-1), y(t) t < 0 = 1/t ## ## ============================================================================= ##----------------------------- ## the derivative function ##----------------------------- derivs <- function(t, y, parms) { tlag <- t - 1 if (tlag < 0) dylag <- -1 else dylag <- lagderiv(tlag) list(c(dy = -dylag), dylag = dylag) } ##----------------------------- ## initial values and times ##----------------------------- yinit <- 0 times <- seq(0, 4, 0.001) ##----------------------------- ## solve the model ##----------------------------- yout <- dede(y = yinit, times = times, func = derivs, parms = NULL) ##----------------------------- ## display, plot results ##----------------------------- plot(yout, type = "l", lwd = 2) } \keyword{utilities}deSolve/man/lsodes.Rd0000644000176000001440000005630713136461014014250 0ustar ripleyusers\name{lsodes} \alias{lsodes} \title{Solver for Ordinary Differential Equations (ODE) With Sparse Jacobian } \description{ Solves the initial value problem for stiff systems of ordinary differential equations (ODE) in the form: \deqn{dy/dt = f(t,y)} and where the Jacobian matrix df/dy has an arbitrary sparse structure. The \R function \code{lsodes} provides an interface to the FORTRAN ODE solver of the same name, written by Alan C. Hindmarsh and Andrew H. Sherman. The system of ODE's is written as an \R function or be defined in compiled code that has been dynamically loaded. } \usage{ lsodes(y, times, func, parms, rtol = 1e-6, atol = 1e-6, jacvec = NULL, sparsetype = "sparseint", nnz = NULL, inz = NULL, rootfunc = NULL, verbose = FALSE, nroot = 0, tcrit = NULL, hmin = 0, hmax = NULL, hini = 0, ynames = TRUE, maxord = NULL, maxsteps = 5000, lrw = NULL, liw = NULL, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, events=NULL, lags = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time; if only one step is to be taken; set \code{times} = \code{NULL}. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time \code{t}, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{lsodes()} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func} or \code{jacfunc}. } \item{rtol }{relative error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{atol }{absolute error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{jacvec }{if not \code{NULL}, an \R function that computes a column of the Jacobian of the system of differential equations \eqn{\partial\dot{y}_i/\partial y_j}{dydot(i)/dy(j)}, or a string giving the name of a function or subroutine in \file{dllname} that computes the column of the Jacobian (see vignette \code{"compiledCode"} for more about this option). The \R calling sequence for \code{jacvec} is identical to that of \code{func}, but with extra parameter \code{j}, denoting the column number. Thus, \code{jacvec} should be called as: \code{jacvec = func(t, y, j, parms)} and \code{jacvec} should return a vector containing column \code{j} of the Jacobian, i.e. its i-th value is \eqn{\partial\dot{y}_i/\partial y_j}{dydot(i)/dy(j)}. If this function is absent, \code{lsodes} will generate the Jacobian by differences. } \item{sparsetype }{the sparsity structure of the Jacobian, one of "sparseint" or "sparseusr", "sparsejan", ..., The sparsity can be estimated internally by lsodes (first option) or given by the user (last two). See details. } \item{nnz }{the number of nonzero elements in the sparse Jacobian (if this is unknown, use an estimate). } \item{inz }{if \code{sparsetype} equal to "sparseusr", a two-columned matrix with the (row, column) indices to the nonzero elements in the sparse Jacobian. If \code{sparsetype} = "sparsejan", a vector with the elements ian followed by he elements jan as used in the lsodes code. See details. In all other cases, ignored. } \item{rootfunc }{if not \code{NULL}, an \R function that computes the function whose root has to be estimated or a string giving the name of a function or subroutine in \file{dllname} that computes the root function. The \R calling sequence for \code{rootfunc} is identical to that of \code{func}. \code{rootfunc} should return a vector with the function values whose root is sought. } \item{verbose }{if \code{TRUE}: full output to the screen, e.g. will print the \code{diagnostiscs} of the integration - see details. } \item{nroot }{only used if \file{dllname} is specified: the number of constraint functions whose roots are desired during the integration; if \code{rootfunc} is an R-function, the solver estimates the number of roots. } \item{tcrit }{if not \code{NULL}, then \code{lsodes} cannot integrate past \code{tcrit}. The FORTRAN routine \code{lsodes} overshoots its targets (times points in the vector \code{times}), and interpolates values for the desired time points. If there is a time beyond which integration should not proceed (perhaps because of a singularity), that should be provided in \code{tcrit}. } \item{hmin }{an optional minimum value of the integration stepsize. In special situations this parameter may speed up computations with the cost of precision. Don't use \code{hmin} if you don't know why! } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, \code{hmax} is set to the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. } \item{hini }{initial step size to be attempted; if 0, the initial step size is determined by the solver. } \item{ynames }{logical, if \code{FALSE} names of state variables are not passed to function \code{func}; this may speed up the simulation especially for multi-D models. } \item{maxord }{the maximum order to be allowed. \code{NULL} uses the default, i.e. order 12 if implicit Adams method (meth = 1), order 5 if BDF method (meth = 2). Reduce maxord to save storage space. } \item{maxsteps }{maximal number of steps per output interval taken by the solver. } \item{lrw }{the length of the real work array rwork; due to the sparsicity, this cannot be readily predicted. If \code{NULL}, a guess will be made, and if not sufficient, \code{lsodes} will return with a message indicating the size of rwork actually required. Therefore, some experimentation may be necessary to estimate the value of \code{lrw}. For instance, if you get the error: \preformatted{ DLSODES- RWORK length is insufficient to proceed. Length needed is .ge. LENRW (=I1), exceeds LRW (=I2) In above message, I1 = 27627 I2 = 25932 } set \code{lrw} equal to 27627 or a higher value } \item{liw }{the length of the integer work array iwork; due to the sparsicity, this cannot be readily predicted. If \code{NULL}, a guess will be made, and if not sufficient, \code{lsodes} will return with a message indicating the size of iwork actually required. Therefore, some experimentation may be necessary to estimate the value of \code{liw}. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func} and \code{jacfunc}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the dll - you have to perform this check in the code. See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. These names will be used to label the output matrix. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See \link{forcings} or vignette \code{compiledCode}. } \item{events }{A matrix or data frame that specifies events, i.e. when the value of a state variable is suddenly changed. See \link{events} for more information. } \item{lags }{A list that specifies timelags, i.e. the number of steps that has to be kept. To be used for delay differential equations. See \link{timelags}, \link{dede} for more information. } \item{... }{additional arguments passed to \code{func} and \code{jacfunc} allowing this to be a generic function. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the FORTRAN routine `lsodes' returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{Karline Soetaert } \examples{ ## Various ways to solve the same model. ## ======================================================================= ## The example from lsodes source code ## A chemical model ## ======================================================================= n <- 12 y <- rep(1, n) dy <- rep(0, n) times <- c(0, 0.1*(10^(0:4))) rtol <- 1.0e-4 atol <- 1.0e-6 parms <- c(rk1 = 0.1, rk2 = 10.0, rk3 = 50.0, rk4 = 2.5, rk5 = 0.1, rk6 = 10.0, rk7 = 50.0, rk8 = 2.5, rk9 = 50.0, rk10 = 5.0, rk11 = 50.0, rk12 = 50.0,rk13 = 50.0, rk14 = 30.0, rk15 = 100.0,rk16 = 2.5, rk17 = 100.0,rk18 = 2.5, rk19 = 50.0, rk20 = 50.0) # chemistry <- function (time, Y, pars) { with (as.list(pars), { dy[1] <- -rk1 *Y[1] dy[2] <- rk1 *Y[1] + rk11*rk14*Y[4] + rk19*rk14*Y[5] - rk3 *Y[2]*Y[3] - rk15*Y[2]*Y[12] - rk2*Y[2] dy[3] <- rk2 *Y[2] - rk5 *Y[3] - rk3*Y[2]*Y[3] - rk7*Y[10]*Y[3] + rk11*rk14*Y[4] + rk12*rk14*Y[6] dy[4] <- rk3 *Y[2]*Y[3] - rk11*rk14*Y[4] - rk4*Y[4] dy[5] <- rk15*Y[2]*Y[12] - rk19*rk14*Y[5] - rk16*Y[5] dy[6] <- rk7 *Y[10]*Y[3] - rk12*rk14*Y[6] - rk8*Y[6] dy[7] <- rk17*Y[10]*Y[12] - rk20*rk14*Y[7] - rk18*Y[7] dy[8] <- rk9 *Y[10] - rk13*rk14*Y[8] - rk10*Y[8] dy[9] <- rk4 *Y[4] + rk16*Y[5] + rk8*Y[6] + rk18*Y[7] dy[10] <- rk5 *Y[3] + rk12*rk14*Y[6] + rk20*rk14*Y[7] + rk13*rk14*Y[8] - rk7 *Y[10]*Y[3] - rk17*Y[10]*Y[12] - rk6 *Y[10] - rk9*Y[10] dy[11] <- rk10*Y[8] dy[12] <- rk6 *Y[10] + rk19*rk14*Y[5] + rk20*rk14*Y[7] - rk15*Y[2]*Y[12] - rk17*Y[10]*Y[12] return(list(dy)) }) } ## ======================================================================= ## application 1. lsodes estimates the structure of the Jacobian ## and calculates the Jacobian by differences ## ======================================================================= out <- lsodes(func = chemistry, y = y, parms = parms, times = times, atol = atol, rtol = rtol, verbose = TRUE) ## ======================================================================= ## application 2. the structure of the Jacobian is input ## lsodes calculates the Jacobian by differences ## this is not so efficient... ## ======================================================================= ## elements of Jacobian that are not zero nonzero <- matrix(nc = 2, byrow = TRUE, data = c( 1, 1, 2, 1, # influence of sp1 on rate of change of others 2, 2, 3, 2, 4, 2, 5, 2, 12, 2, 2, 3, 3, 3, 4, 3, 6, 3, 10, 3, 2, 4, 3, 4, 4, 4, 9, 4, # d (dyi)/dy4 2, 5, 5, 5, 9, 5, 12, 5, 3, 6, 6, 6, 9, 6, 10, 6, 7, 7, 9, 7, 10, 7, 12, 7, 8, 8, 10, 8, 11, 8, 3,10, 6,10, 7,10, 8,10, 10,10, 12,10, 2,12, 5,12, 7,12, 10,12, 12,12) ) ## when run, the default length of rwork is too small ## lsodes will tell the length actually needed # out2 <- lsodes(func = chemistry, y = y, parms = parms, times = times, # inz = nonzero, atol = atol,rtol = rtol) #gives warning out2 <- lsodes(func = chemistry, y = y, parms = parms, times = times, sparsetype = "sparseusr", inz = nonzero, atol = atol, rtol = rtol, verbose = TRUE, lrw = 353) ## ======================================================================= ## application 3. lsodes estimates the structure of the Jacobian ## the Jacobian (vector) function is input ## ======================================================================= chemjac <- function (time, Y, j, pars) { with (as.list(pars), { PDJ <- rep(0,n) if (j == 1){ PDJ[1] <- -rk1 PDJ[2] <- rk1 } else if (j == 2) { PDJ[2] <- -rk3*Y[3] - rk15*Y[12] - rk2 PDJ[3] <- rk2 - rk3*Y[3] PDJ[4] <- rk3*Y[3] PDJ[5] <- rk15*Y[12] PDJ[12] <- -rk15*Y[12] } else if (j == 3) { PDJ[2] <- -rk3*Y[2] PDJ[3] <- -rk5 - rk3*Y[2] - rk7*Y[10] PDJ[4] <- rk3*Y[2] PDJ[6] <- rk7*Y[10] PDJ[10] <- rk5 - rk7*Y[10] } else if (j == 4) { PDJ[2] <- rk11*rk14 PDJ[3] <- rk11*rk14 PDJ[4] <- -rk11*rk14 - rk4 PDJ[9] <- rk4 } else if (j == 5) { PDJ[2] <- rk19*rk14 PDJ[5] <- -rk19*rk14 - rk16 PDJ[9] <- rk16 PDJ[12] <- rk19*rk14 } else if (j == 6) { PDJ[3] <- rk12*rk14 PDJ[6] <- -rk12*rk14 - rk8 PDJ[9] <- rk8 PDJ[10] <- rk12*rk14 } else if (j == 7) { PDJ[7] <- -rk20*rk14 - rk18 PDJ[9] <- rk18 PDJ[10] <- rk20*rk14 PDJ[12] <- rk20*rk14 } else if (j == 8) { PDJ[8] <- -rk13*rk14 - rk10 PDJ[10] <- rk13*rk14 PDJ[11] <- rk10 } else if (j == 10) { PDJ[3] <- -rk7*Y[3] PDJ[6] <- rk7*Y[3] PDJ[7] <- rk17*Y[12] PDJ[8] <- rk9 PDJ[10] <- -rk7*Y[3] - rk17*Y[12] - rk6 - rk9 PDJ[12] <- rk6 - rk17*Y[12] } else if (j == 12) { PDJ[2] <- -rk15*Y[2] PDJ[5] <- rk15*Y[2] PDJ[7] <- rk17*Y[10] PDJ[10] <- -rk17*Y[10] PDJ[12] <- -rk15*Y[2] - rk17*Y[10] } return(PDJ) }) } out3 <- lsodes(func = chemistry, y = y, parms = parms, times = times, jacvec = chemjac, atol = atol, rtol = rtol) ## ======================================================================= ## application 4. The structure of the Jacobian (nonzero elements) AND ## the Jacobian (vector) function is input ## ======================================================================= out4 <- lsodes(func = chemistry, y = y, parms = parms, times = times, lrw = 351, sparsetype = "sparseusr", inz = nonzero, jacvec = chemjac, atol = atol, rtol = rtol, verbose = TRUE) # The sparsejan variant # note: errors in inz may cause R to break, so this is not without danger... # out5 <- lsodes(func = chemistry, y = y, parms = parms, times = times, # jacvec = chemjac, atol = atol, rtol = rtol, sparsetype = "sparsejan", # inz = c(1,3,8,13,17,21,25,29,32,32,38,38,43, # ian # 1,2, 2,3,4,5,12, 2,3,4,6,10, 2,3,4,9, 2,5,9,12, 3,6,9,10, # jan # 7,9,10,12, 8,10,11, 3,6,7,8,10,12, 2,5,7,10,12), lrw = 343) } \references{ Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), North-Holland, Amsterdam, 1983, pp. 55-64. S. C. Eisenstat, M. C. Gursky, M. H. Schultz, and A. H. Sherman, Yale Sparse Matrix Package: I. The Symmetric Codes, Int. J. Num. Meth. Eng., 18 (1982), pp. 1145-1151. S. C. Eisenstat, M. C. Gursky, M. H. Schultz, and A. H. Sherman, Yale Sparse Matrix Package: II. The Nonsymmetric Codes, Research Report No. 114, Dept. of Computer Sciences, Yale University, 1977. } \details{ The work is done by the FORTRAN subroutine \code{lsodes}, whose documentation should be consulted for details (it is included as comments in the source file \file{src/opkdmain.f}). The implementation is based on the November, 2003 version of lsodes, from Netlib. \code{lsodes} is applied for stiff problems, where the Jacobian has a sparse structure. There are several choices depending on whether \code{jacvec} is specified and depending on the setting of \code{sparsetype}. If function \code{jacvec} is present, then it should return the j-th column of the Jacobian matrix. There are also several choices for the sparsity specification, selected by argument \code{sparsetype}. \itemize{ \item \code{sparsetype} = \code{"sparseint"}. The sparsity is estimated by the solver, based on numerical differences. In this case, it is advisable to provide an estimate of the number of non-zero elements in the Jacobian (\code{nnz}). This value can be approximate; upon return the number of nonzero elements actually required will be known (1st element of attribute \code{dims}). In this case, \code{inz} need not be specified. \item \code{sparsetype} = \code{"sparseusr"}. The sparsity is determined by the user. In this case, \code{inz} should be a \code{matrix}, containing indices (row, column) to the nonzero elements in the Jacobian matrix. The number of nonzeros \code{nnz} will be set equal to the number of rows in \code{inz}. \item \code{sparsetype} = \code{"sparsejan"}. The sparsity is also determined by the user. In this case, \code{inz} should be a \code{vector}, containting the \code{ian} and \code{jan} elements of the sparse storage format, as used in the sparse solver. Elements of \code{ian} should be the first \code{n+1} elements of this vector, and contain the starting locations in \code{jan} of columns 1.. n. \code{jan} contains the row indices of the nonzero locations of the Jacobian, reading in columnwise order. The number of nonzeros \code{nnz} will be set equal to the length of \code{inz} - (n+1). \item \code{sparsetype} = \code{"1D"}, \code{"2D"}, \code{"3D"}. The sparsity is estimated by the solver, based on numerical differences. Assumes finite differences in a 1D, 2D or 3D regular grid - used by functions \code{ode.1D}, \code{ode.2D}, \code{ode.3D}. Similar are \code{"2Dmap"}, and \code{"3Dmap"}, which also include a mapping variable (passed in nnz). } The input parameters \code{rtol}, and \code{atol} determine the \bold{error control} performed by the solver. See \code{\link{lsoda}} for details. The diagnostics of the integration can be printed to screen by calling \code{\link{diagnostics}}. If \code{verbose} = \code{TRUE}, the diagnostics will written to the screen at the end of the integration. See vignette("deSolve") for an explanation of each element in the vectors containing the diagnostic properties and how to directly access them. \bold{Models} may be defined in compiled C or FORTRAN code, as well as in an R-function. See package vignette \code{"compiledCode"} for details. More information about models defined in compiled code is in the package vignette ("compiledCode"); information about linking forcing functions to compiled code is in \link{forcings}. Examples in both C and FORTRAN are in the \file{doc/examples/dynload} subdirectory of the \code{deSolve} package directory. \code{lsodes} can find the root of at least one of a set of constraint functions \code{rootfunc} of the independent and dependent variables. It then returns the solution at the root if that occurs sooner than the specified stop condition, and otherwise returns the solution according the specified stop condition. Caution: Because of numerical errors in the function \code{rootfun} due to roundoff and integration error, \code{lsodes} may return false roots, or return the same root at two or more nearly equal values of \code{time}. } \seealso{ \itemize{ \item \code{\link{rk}}, \item \code{\link{rk4}} and \code{\link{euler}} for Runge-Kutta integrators. \item \code{\link{lsoda}}, \code{\link{lsode}}, \code{\link{lsodar}}, \code{\link{vode}}, \code{\link{daspk}} for other solvers of the Livermore family, \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/lsoda.Rd0000644000176000001440000004627413136461014014063 0ustar ripleyusers\name{lsoda} \alias{lsoda} \title{ Solver for Ordinary Differential Equations (ODE), Switching Automatically Between Stiff and Non-stiff Methods } \description{ Solving initial value problems for stiff or non-stiff systems of first-order ordinary differential equations (ODEs). The \R function \code{lsoda} provides an interface to the FORTRAN ODE solver of the same name, written by Linda R. Petzold and Alan C. Hindmarsh. The system of ODE's is written as an \R function (which may, of course, use \code{\link{.C}}, \code{\link{.Fortran}}, \code{\link{.Call}}, etc., to call foreign code) or be defined in compiled code that has been dynamically loaded. A vector of parameters is passed to the ODEs, so the solver may be used as part of a modeling package for ODEs, or for parameter estimation using any appropriate modeling tool for non-linear models in \R such as \code{\link{optim}}, \code{\link{nls}}, \code{\link{nlm}} or \code{\link[nlme]{nlme}} \code{lsoda} differs from the other integrators (except \code{lsodar}) in that it switches automatically between stiff and nonstiff methods. This means that the user does not have to determine whether the problem is stiff or not, and the solver will automatically choose the appropriate method. It always starts with the nonstiff method. } \usage{ lsoda(y, times, func, parms, rtol = 1e-6, atol = 1e-6, jacfunc = NULL, jactype = "fullint", rootfunc = NULL, verbose = FALSE, nroot = 0, tcrit = NULL, hmin = 0, hmax = NULL, hini = 0, ynames = TRUE, maxordn = 12, maxords = 5, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, events = NULL, lags = NULL,...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{times at which explicit estimates for \code{y} are desired. The first value in \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time t, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{lsoda()} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func} or \code{jacfunc}. } \item{rtol }{relative error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{atol }{absolute error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{jacfunc }{if not \code{NULL}, an \R function, that computes the Jacobian of the system of differential equations \eqn{\partial\dot{y}_i/\partial y_j}{dydot(i)/dy(j)}, or a string giving the name of a function or subroutine in \file{dllname} that computes the Jacobian (see vignette \code{"compiledCode"} for more about this option). In some circumstances, supplying \code{jacfunc} can speed up the computations, if the system is stiff. The \R calling sequence for \code{jacfunc} is identical to that of \code{func}. If the Jacobian is a full matrix, \code{jacfunc} should return a matrix \eqn{\partial\dot{y}/\partial y}{dydot/dy}, where the ith row contains the derivative of \eqn{dy_i/dt} with respect to \eqn{y_j}, or a vector containing the matrix elements by columns (the way \R and FORTRAN store matrices). If the Jacobian is banded, \code{jacfunc} should return a matrix containing only the nonzero bands of the Jacobian, rotated row-wise. See first example of \link{lsode}. } \item{jactype }{the structure of the Jacobian, one of \code{"fullint"}, \code{"fullusr"}, \code{"bandusr"} or \code{"bandint"} - either full or banded and estimated internally or by user. } \item{rootfunc }{if not \code{NULL}, an \R function that computes the function whose root has to be estimated or a string giving the name of a function or subroutine in \file{dllname} that computes the root function. The \R calling sequence for \code{rootfunc} is identical to that of \code{func}. \code{rootfunc} should return a vector with the function values whose root is sought. When \code{rootfunc} is provided, then \code{lsodar} will be called. } \item{verbose }{if \code{TRUE}: full output to the screen, e.g. will print the \code{diagnostiscs} of the integration - see details. } \item{nroot }{only used if \file{dllname} is specified: the number of constraint functions whose roots are desired during the integration; if \code{rootfunc} is an R-function, the solver estimates the number of roots. } \item{tcrit }{if not \code{NULL}, then \code{lsoda} cannot integrate past \code{tcrit}. The FORTRAN routine \code{lsoda} overshoots its targets (times points in the vector \code{times}), and interpolates values for the desired time points. If there is a time beyond which integration should not proceed (perhaps because of a singularity), that should be provided in \code{tcrit}. } \item{hmin }{an optional minimum value of the integration stepsize. In special situations this parameter may speed up computations with the cost of precision. Don't use \code{hmin} if you don't know why! } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, \code{hmax} is set to the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. } \item{hini }{initial step size to be attempted; if 0, the initial step size is determined by the solver. } \item{ynames }{logical, if \code{FALSE}: names of state variables are not passed to function \code{func}; this may speed up the simulation especially for large models. } \item{maxordn }{the maximum order to be allowed in case the method is non-stiff. Should be <= 12. Reduce \code{maxord} to save storage space. } \item{maxords }{the maximum order to be allowed in case the method is stiff. Should be <= 5. Reduce maxord to save storage space. } \item{bandup }{number of non-zero bands above the diagonal, in case the Jacobian is banded. } \item{banddown }{number of non-zero bands below the diagonal, in case the Jacobian is banded. } \item{maxsteps }{maximal number of steps per output interval taken by the solver. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func} and \code{jacfunc}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the dll - you have to perform this check in the code. See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. These names will be used to label the output matrix. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See \link{forcings} or vignette \code{compiledCode}. } \item{events }{A matrix or data frame that specifies events, i.e. when the value of a state variable is suddenly changed. See \link{events} for more information. } \item{lags }{A list that specifies timelags, i.e. the number of steps that has to be kept. To be used for delay differential equations. See \link{timelags}, \link{dede} for more information. } \item{... }{additional arguments passed to \code{func} and \code{jacfunc} allowing this to be a generic function. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the FORTRAN routine `lsoda' returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{R. Woodrow Setzer } \examples{ ## ======================================================================= ## Example 1: ## A simple resource limited Lotka-Volterra-Model ## ## Note: ## 1. parameter and state variable names made ## accessible via "with" function ## 2. function sigimp accessible through lexical scoping ## (see also ode and rk examples) ## ======================================================================= SPCmod <- function(t, x, parms) { with(as.list(c(parms, x)), { import <- sigimp(t) dS <- import - b*S*P + g*C #substrate dP <- c*S*P - d*C*P #producer dC <- e*P*C - f*C #consumer res <- c(dS, dP, dC) list(res) }) } ## Parameters parms <- c(b = 0.0, c = 0.1, d = 0.1, e = 0.1, f = 0.1, g = 0.0) ## vector of timesteps times <- seq(0, 100, length = 101) ## external signal with rectangle impulse signal <- as.data.frame(list(times = times, import = rep(0,length(times)))) signal$import[signal$times >= 10 & signal$times <= 11] <- 0.2 sigimp <- approxfun(signal$times, signal$import, rule = 2) ## Start values for steady state y <- xstart <- c(S = 1, P = 1, C = 1) ## Solving out <- lsoda(xstart, times, SPCmod, parms) ## Plotting mf <- par("mfrow") plot(out, main = c("substrate", "producer", "consumer")) plot(out[,"P"], out[,"C"], type = "l", xlab = "producer", ylab = "consumer") par(mfrow = mf) ## ======================================================================= ## Example 2: ## from lsoda source code ## ======================================================================= ## names makes this easier to read, but may slow down execution. parms <- c(k1 = 0.04, k2 = 1e4, k3 = 3e7) my.atol <- c(1e-6, 1e-10, 1e-6) times <- c(0,4 * 10^(-1:10)) lsexamp <- function(t, y, p) { yd1 <- -p["k1"] * y[1] + p["k2"] * y[2]*y[3] yd3 <- p["k3"] * y[2]^2 list(c(yd1, -yd1-yd3, yd3), c(massbalance = sum(y))) } exampjac <- function(t, y, p) { matrix(c(-p["k1"], p["k1"], 0, p["k2"]*y[3], - p["k2"]*y[3] - 2*p["k3"]*y[2], 2*p["k3"]*y[2], p["k2"]*y[2], -p["k2"]*y[2], 0 ), 3, 3) } ## measure speed (here and below) system.time( out <- lsoda(c(1, 0, 0), times, lsexamp, parms, rtol = 1e-4, atol = my.atol, hmax = Inf) ) out ## This is what the authors of lsoda got for the example: ## the output of this program (on a cdc-7600 in single precision) ## is as follows.. ## ## at t = 4.0000e-01 y = 9.851712e-01 3.386380e-05 1.479493e-02 ## at t = 4.0000e+00 y = 9.055333e-01 2.240655e-05 9.444430e-02 ## at t = 4.0000e+01 y = 7.158403e-01 9.186334e-06 2.841505e-01 ## at t = 4.0000e+02 y = 4.505250e-01 3.222964e-06 5.494717e-01 ## at t = 4.0000e+03 y = 1.831975e-01 8.941774e-07 8.168016e-01 ## at t = 4.0000e+04 y = 3.898730e-02 1.621940e-07 9.610125e-01 ## at t = 4.0000e+05 y = 4.936363e-03 1.984221e-08 9.950636e-01 ## at t = 4.0000e+06 y = 5.161831e-04 2.065786e-09 9.994838e-01 ## at t = 4.0000e+07 y = 5.179817e-05 2.072032e-10 9.999482e-01 ## at t = 4.0000e+08 y = 5.283401e-06 2.113371e-11 9.999947e-01 ## at t = 4.0000e+09 y = 4.659031e-07 1.863613e-12 9.999995e-01 ## at t = 4.0000e+10 y = 1.404280e-08 5.617126e-14 1.000000e+00 ## Using the analytic Jacobian speeds up execution a little : system.time( outJ <- lsoda(c(1, 0, 0), times, lsexamp, parms, rtol = 1e-4, atol = my.atol, jacfunc = exampjac, jactype = "fullusr", hmax = Inf) ) all.equal(as.data.frame(out), as.data.frame(outJ)) # TRUE diagnostics(out) diagnostics(outJ) # shows what lsoda did internally } \references{ Hindmarsh, Alan C. (1983) ODEPACK, A Systematized Collection of ODE Solvers; in p.55--64 of Stepleman, R.W. et al.[ed.] (1983) \emph{Scientific Computing}, North-Holland, Amsterdam. Petzold, Linda R. (1983) Automatic Selection of Methods for Solving Stiff and Nonstiff Systems of Ordinary Differential Equations. \emph{Siam J. Sci. Stat. Comput.} \bold{4}, 136--148. Netlib: \url{http://www.netlib.org} } \details{ All the hard work is done by the FORTRAN subroutine \code{lsoda}, whose documentation should be consulted for details (it is included as comments in the source file \file{src/opkdmain.f}). The implementation is based on the 12 November 2003 version of lsoda, from Netlib. \code{lsoda} switches automatically between stiff and nonstiff methods. This means that the user does not have to determine whether the problem is stiff or not, and the solver will automatically choose the appropriate method. It always starts with the nonstiff method. The form of the \bold{Jacobian} can be specified by \code{jactype} which can take the following values: \describe{ \item{"fullint"}{a full Jacobian, calculated internally by lsoda, the default,} \item{"fullusr"}{a full Jacobian, specified by user function \code{jacfunc},} \item{"bandusr"}{a banded Jacobian, specified by user function \code{jacfunc} the size of the bands specified by \code{bandup} and \code{banddown},} \item{"bandint"}{banded Jacobian, calculated by lsoda; the size of the bands specified by \code{bandup} and \code{banddown}.} } If \code{jactype} = "fullusr" or "bandusr" then the user must supply a subroutine \code{jacfunc}. The following description of \bold{error control} is adapted from the documentation of the lsoda source code (input arguments \code{rtol} and \code{atol}, above): The input parameters \code{rtol}, and \code{atol} determine the error control performed by the solver. The solver will control the vector \bold{e} of estimated local errors in \bold{y}, according to an inequality of the form max-norm of ( \bold{e}/\bold{ewt} ) \eqn{\leq}{ <= } 1, where \bold{ewt} is a vector of positive error weights. The values of \code{rtol} and \code{atol} should all be non-negative. The form of \bold{ewt} is: \deqn{\mathbf{rtol} \times \mathrm{abs}(\mathbf{y}) + \mathbf{atol}}{\bold{rtol} * abs(\bold{y}) + \bold{atol}} where multiplication of two vectors is element-by-element. If the request for precision exceeds the capabilities of the machine, the FORTRAN subroutine lsoda will return an error code; under some circumstances, the \R function \code{lsoda} will attempt a reasonable reduction of precision in order to get an answer. It will write a warning if it does so. The diagnostics of the integration can be printed to screen by calling \code{\link{diagnostics}}. If \code{verbose} = \code{TRUE}, the diagnostics will written to the screen at the end of the integration. See vignette("deSolve") for an explanation of each element in the vectors containing the diagnostic properties and how to directly access them. \bold{Models} may be defined in compiled C or FORTRAN code, as well as in an R-function. See package vignette \code{"compiledCode"} for details. More information about models defined in compiled code is in the package vignette ("compiledCode"); information about linking forcing functions to compiled code is in \link{forcings}. Examples in both C and FORTRAN are in the \file{dynload} subdirectory of the \code{deSolve} package directory. } \seealso{ \itemize{ \item \code{\link{rk}}, \code{\link{rkMethod}}, \code{\link{rk4}} and \code{\link{euler}} for Runge-Kutta integrators. \item \code{\link{lsode}}, which can also find a root \item \code{\link{lsodes}}, \code{\link{lsodar}}, \code{\link{vode}}, \code{\link{daspk}} for other solvers of the Livermore family, \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, } \code{\link{diagnostics}} to print diagnostic messages. } \note{ The \file{demo} directory contains some examples of using \code{\link[nlme]{gnls}} to estimate parameters in a dynamic model. } \keyword{math} deSolve/man/SCOC.Rd0000644000176000001440000000465413136461014013504 0ustar ripleyusers\name{SCOC} \alias{SCOC} \title{A Sediment Model of Oxygen Consumption} \description{A model that describes oxygen consumption in a marine sediment. One state variable: \itemize{ \item sedimentary organic carbon, } Organic carbon settles on the sediment surface (forcing function Flux) and decays at a constant rate. The equation is simple: \deqn{\frac{dC}{dt} = Flux - k C} This model is written in \code{FORTRAN}. } \usage{SCOC(times, y = NULL, parms, Flux, ...)} \arguments{ \item{times}{time sequence for which output is wanted; the first value of times must be the initial time,} \item{y}{the initial value of the state variable; if \code{NULL} it will be estimated based on \code{Flux} and \code{parms},} \item{parms }{the model parameter, \code{k},} \item{Flux }{a data set with the organic carbon deposition rates, } \item{...}{any other parameters passed to the integrator \code{ode} (which solves the model).} } \author{Karline Soetaert } \examples{ ## Forcing function data Flux <- matrix(ncol = 2, byrow = TRUE, data = c( 1, 0.654, 11, 0.167, 21, 0.060, 41, 0.070, 73,0.277, 83,0.186, 93,0.140,103, 0.255, 113, 0.231,123, 0.309,133,1.127,143,1.923, 153,1.091,163,1.001, 173, 1.691,183, 1.404,194,1.226,204,0.767, 214, 0.893,224,0.737, 234,0.772,244, 0.726,254,0.624,264,0.439, 274,0.168,284 ,0.280, 294,0.202,304, 0.193,315,0.286,325,0.599, 335, 1.889,345, 0.996,355,0.681,365,1.135)) parms <- c(k = 0.01) times <- 1:365 out <- SCOC(times, parms = parms, Flux = Flux) plot(out[,"time"], out[,"Depo"], type = "l", col = "red") lines(out[,"time"], out[,"Mineralisation"], col = "blue") ## Constant interpolation of forcing function - left side of interval fcontrol <- list(method = "constant") out2 <- SCOC(times, parms = parms, Flux = Flux, fcontrol = fcontrol) plot(out2[,"time"], out2[,"Depo"], type = "l",col = "red") lines(out2[,"time"], out2[,"Mineralisation"], col = "blue") } \references{ Soetaert, K. and P.M.J. Herman, 2009. A Practical Guide to Ecological Modelling. Using \R as a Simulation Platform. Springer, 372 pp. } \details{ The model is implemented primarily to demonstrate the linking of FORTRAN with \R-code. The source can be found in the \file{doc/examples/dynload} subdirectory of the package. } \seealso{ \code{\link{ccl4model}}, the CCl4 inhalation model. \code{\link{aquaphy}}, the algal growth model. } \keyword{models} deSolve/man/ccl4data.Rd0000644000176000001440000000234013136461014014422 0ustar ripleyusers\name{ccl4data} \docType{data} \alias{ccl4data} \title{Closed Chamber Study of CCl4 Metabolism by Rats.} \description{The results of a closed chamber experiment to determine metabolic parameters for CCl4 (carbon tetrachloride) in rats. } \usage{data(ccl4data)} \format{This data frame contains the following columns: \describe{ \item{time}{the time (in hours after starting the experiment).} \item{initconc}{initial chamber concentration (ppm).} \item{animal}{this is a repeated measures design; this variable indicates which animal the observation pertains to. } \item{ChamberConc}{chamber concentration at \code{time}, in ppm.} } } \source{ Evans, et al. 1994 Applications of sensitivity analysis to a physiologically based pharmacokinetic model for carbon tetrachloride in rats. Toxicology and Applied Pharmacology \bold{128}: 36 -- 44. } \examples{ plot(ChamberConc ~ time, data = ccl4data, xlab = "Time (hours)", xlim = range(c(0, ccl4data$time)), ylab = "Chamber Concentration (ppm)", log = "y") ccl4data.avg <- aggregate(ccl4data$ChamberConc, by = ccl4data[c("time", "initconc")], mean) points(x ~ time, data = ccl4data.avg, pch = 16) } \keyword{datasets} deSolve/man/rk.Rd0000644000176000001440000003616713136461014013375 0ustar ripleyusers\name{rk} \alias{rk} \title{Explicit One-Step Solvers for Ordinary Differential Equations (ODE)} \description{Solving initial value problems for non-stiff systems of first-order ordinary differential equations (ODEs). The \R function \code{rk} is a top-level function that provides interfaces to a collection of common explicit one-step solvers of the Runge-Kutta family with fixed or variable time steps. The system of ODE's is written as an \R function (which may, of course, use \code{\link{.C}}, \code{\link{.Fortran}}, \code{\link{.Call}}, etc., to call foreign code) or be defined in compiled code that has been dynamically loaded. A vector of parameters is passed to the ODEs, so the solver may be used as part of a modeling package for ODEs, or for parameter estimation using any appropriate modeling tool for non-linear models in \R such as \code{\link{optim}}, \code{\link{nls}}, \code{\link{nlm}} or \code{\link[nlme]{nlme}} } \usage{ rk(y, times, func, parms, rtol = 1e-6, atol = 1e-6, verbose = FALSE, tcrit = NULL, hmin = 0, hmax = NULL, hini = hmax, ynames = TRUE, method = rkMethod("rk45dp7", ... ), maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, events = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{times at which explicit estimates for \code{y} are desired. The first value in \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time t, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{rk} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func}. } \item{rtol }{relative error tolerance, either a scalar or an array as long as \code{y}. Only applicable to methods with variable time step, see details. } \item{atol }{absolute error tolerance, either a scalar or an array as long as \code{y}. Only applicable to methods with variable time step, see details. } \item{tcrit }{if not \code{NULL}, then \code{rk} cannot integrate past \code{tcrit}. This parameter is for compatibility with other solvers. } \item{verbose }{a logical value that, when TRUE, triggers more verbose output from the ODE solver. } \item{hmin }{an optional minimum value of the integration stepsize. In special situations this parameter may speed up computations with the cost of precision. Don't use \code{hmin} if you don't know why! } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, \code{hmax} is set to the maximum of \code{hini} and the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. Note that \code{hmin} and \code{hmax} are ignored by fixed step methods like \code{"rk4"} or \code{"euler"}. } \item{hini }{initial step size to be attempted; if 0, the initial step size is determined automatically by solvers with flexible time step. For fixed step methods, setting \code{hini = 0} forces internal time steps identically to external time steps provided by \code{times}. Similarly, internal time steps of non-interpolating solvers cannot be bigger than external time steps specified in \code{times}. } \item{ynames }{if \code{FALSE}: names of state variables are not passed to function \code{func} ; this may speed up the simulation especially for large models. } \item{method }{the integrator to use. This can either be a string constant naming one of the pre-defined methods or a call to function \code{\link{rkMethod}} specifying a user-defined method. The most common methods are the fixed-step methods \code{"euler"}, second and fourth-order Runge Kutta (\code{"rk2"}, \code{"rk4"}), or the variable step methods Bogacki-Shampine \code{"rk23bs"}, Runge-Kutta-Fehlberg \code{"rk34f"}, the fifth-order Cash-Karp method \code{"rk45ck"} or the fifth-order Dormand-Prince method with seven stages \code{"rk45dp7"}. As a suggestion, one may use \code{"rk23bs"} (alias \code{"ode23"}) for simple problems and \code{"rk45dp7"} (alias \code{"ode45"}) for rough problems. } \item{maxsteps }{average maximal number of steps per output interval taken by the solver. This argument is defined such as to ensure compatibility with the Livermore-solvers. \code{rk} only accepts the maximal number of steps for the entire integration. It is calculated as \code{max(length(times) * maxsteps, max(diff(times)/hini + 1)}. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func} and \code{jacfunc}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the dll - you have to perform this check in the code. See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See \link{forcings} or vignette \code{compiledCode}. } \item{events }{A matrix or data frame that specifies events, i.e. when the value of a state variable is suddenly changed. See \link{events} for more information. Not also that if events are specified, then polynomial interpolation is switched off and integration takes place from one external time step to the next, with an internal step size less than or equal the difference of two adjacent points of \code{times}. } \item{... }{additional arguments passed to \code{func} allowing this to be a generic function. } } \details{ Function \code{rk} is a generalized implementation that can be used to evaluate different solvers of the Runge-Kutta family of explicit ODE solvers. A pre-defined set of common method parameters is in function \code{\link{rkMethod}} which also allows to supply user-defined Butcher tables. The input parameters \code{rtol}, and \code{atol} determine the error control performed by the solver. The solver will control the vector of estimated local errors in \bold{y}, according to an inequality of the form max-norm of ( \bold{e}/\bold{ewt} ) \eqn{\leq}{ <= } 1, where \bold{ewt} is a vector of positive error weights. The values of \code{rtol} and \code{atol} should all be non-negative. The form of \bold{ewt} is: \deqn{\mathbf{rtol} \times \mathrm{abs}(\mathbf{y}) + \mathbf{atol}}{\bold{rtol} * abs(\bold{y}) + \bold{atol}} where multiplication of two vectors is element-by-element. \bold{Models} can be defined in \R as a user-supplied \bold{R-function}, that must be called as: \code{yprime = func(t, y, parms)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to time, and whose second element contains output variables that are required at each point in time. Examples are given below. } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the integration routine returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \note{ Arguments \code{rpar} and \code{ipar} are provided for compatibility with \code{lsoda}. Starting with version 1.8 implicit Runge-Kutta methods are also supported by this general \code{rk} interface, however their implementation is still experimental. Instead of this you may consider \code{\link{radau}} for a specific full implementation of an implicit Runge-Kutta method. } \references{ Butcher, J. C. (1987) The numerical analysis of ordinary differential equations, Runge-Kutta and general linear methods, Wiley, Chichester and New York. Engeln-Muellges, G. and Reutter, F. (1996) Numerik Algorithmen: Entscheidungshilfe zur Auswahl und Nutzung. VDI Verlag, Duesseldorf. Hindmarsh, Alan C. (1983) ODEPACK, A Systematized Collection of ODE Solvers; in p.55--64 of Stepleman, R.W. et al.[ed.] (1983) \emph{Scientific Computing}, North-Holland, Amsterdam. Press, W. H., Teukolsky, S. A., Vetterling, W. T. and Flannery, B. P. (2007) Numerical Recipes in C. Cambridge University Press. } \author{Thomas Petzoldt \email{thomas.petzoldt@tu-dresden.de}} \seealso{ For most practical cases, solvers of the Livermore family (i.e. the ODEPACK solvers, see below) are superior. Some of them are also suitable for stiff ODEs, differential algebraic equations (DAEs), or partial differential equations (PDEs). \itemize{ \item \code{\link{rkMethod}} for a list of available Runge-Kutta parameter sets, \item \code{\link{rk4}} and \code{\link{euler}} for special versions without interpolation (and less overhead), \item \code{\link{lsoda}}, \code{\link{lsode}}, \code{\link{lsodes}}, \code{\link{lsodar}}, \code{\link{vode}}, \code{\link{daspk}} for solvers of the Livermore family, \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, \item \code{\link{diagnostics}} to print diagnostic messages. } } \examples{ ## ======================================================================= ## Example: Resource-producer-consumer Lotka-Volterra model ## ======================================================================= ## Notes: ## - Parameters are a list, names accessible via "with" function ## - Function sigimp passed as an argument (input) to model ## (see also ode and lsoda examples) SPCmod <- function(t, x, parms, input) { with(as.list(c(parms, x)), { import <- input(t) dS <- import - b*S*P + g*C # substrate dP <- c*S*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dS, dP, dC) list(res) }) } ## The parameters parms <- c(b = 0.001, c = 0.1, d = 0.1, e = 0.1, f = 0.1, g = 0.0) ## vector of timesteps times <- seq(0, 200, length = 101) ## external signal with rectangle impulse signal <- data.frame(times = times, import = rep(0, length(times))) signal$import[signal$times >= 10 & signal$times <= 11] <- 0.2 sigimp <- approxfun(signal$times, signal$import, rule = 2) ## Start values for steady state xstart <- c(S = 1, P = 1, C = 1) ## Euler method out1 <- rk(xstart, times, SPCmod, parms, hini = 0.1, input = sigimp, method = "euler") ## classical Runge-Kutta 4th order out2 <- rk(xstart, times, SPCmod, parms, hini = 1, input = sigimp, method = "rk4") ## Dormand-Prince method of order 5(4) out3 <- rk(xstart, times, SPCmod, parms, hmax = 1, input = sigimp, method = "rk45dp7") mf <- par("mfrow") ## deSolve plot method for comparing scenarios plot(out1, out2, out3, which = c("S", "P", "C"), main = c ("Substrate", "Producer", "Consumer"), col =c("black", "red", "green"), lty = c("solid", "dotted", "dotted"), lwd = c(1, 2, 1)) ## user-specified plot function plot (out1[,"P"], out1[,"C"], type = "l", xlab = "Producer", ylab = "Consumer") lines(out2[,"P"], out2[,"C"], col = "red", lty = "dotted", lwd = 2) lines(out3[,"P"], out3[,"C"], col = "green", lty = "dotted") legend("center", legend = c("euler", "rk4", "rk45dp7"), lty = c(1, 3, 3), lwd = c(1, 2, 1), col = c("black", "red", "green")) par(mfrow = mf) } \keyword{ math }deSolve/man/vode.Rd0000644000176000001440000004602213136461014013705 0ustar ripleyusers\name{vode} \alias{vode} \title{Solver for Ordinary Differential Equations (ODE)} \description{ Solves the initial value problem for stiff or nonstiff systems of ordinary differential equations (ODE) in the form: \deqn{dy/dt = f(t,y)} The \R function \code{vode} provides an interface to the FORTRAN ODE solver of the same name, written by Peter N. Brown, Alan C. Hindmarsh and George D. Byrne. The system of ODE's is written as an \R function or be defined in compiled code that has been dynamically loaded. In contrast to \code{\link{lsoda}}, the user has to specify whether or not the problem is stiff and choose the appropriate solution method. \code{vode} is very similar to \code{\link{lsode}}, but uses a variable-coefficient method rather than the fixed-step-interpolate methods in \code{\link{lsode}}. In addition, in vode it is possible to choose whether or not a copy of the Jacobian is saved for reuse in the corrector iteration algorithm; In \code{lsode}, a copy is not kept. } \usage{vode(y, times, func, parms, rtol = 1e-6, atol = 1e-6, jacfunc = NULL, jactype = "fullint", mf = NULL, verbose = FALSE, tcrit = NULL, hmin = 0, hmax = NULL, hini = 0, ynames = TRUE, maxord = NULL, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, events=NULL, lags = NULL,...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time; if only one step is to be taken; set \code{times = NULL}. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time \code{t}, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{vode()} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func} or \code{jacfunc}. } \item{rtol }{relative error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{atol }{absolute error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{jacfunc }{if not \code{NULL}, an \R function that computes the Jacobian of the system of differential equations \eqn{\partial\dot{y}_i/\partial y_j}{dydot(i)/dy(j)}, or a string giving the name of a function or subroutine in \file{dllname} that computes the Jacobian (see vignette \code{"compiledCode"} for more about this option). In some circumstances, supplying \code{jacfunc} can speed up the computations, if the system is stiff. The \R calling sequence for \code{jacfunc} is identical to that of \code{func}. If the Jacobian is a full matrix, \code{jacfunc} should return a matrix \eqn{\partial\dot{y}/\partial y}{dydot/dy}, where the ith row contains the derivative of \eqn{dy_i/dt} with respect to \eqn{y_j}, or a vector containing the matrix elements by columns (the way \R and FORTRAN store matrices). If the Jacobian is banded, \code{jacfunc} should return a matrix containing only the nonzero bands of the Jacobian, rotated row-wise. See first example of \link{lsode}. } \item{jactype }{the structure of the Jacobian, one of \code{"fullint"}, \code{"fullusr"}, \code{"bandusr"} or \code{"bandint"} - either full or banded and estimated internally or by user; overruled if \code{mf} is not \code{NULL}. } \item{mf }{the "method flag" passed to function vode - overrules \code{jactype} - provides more options than \code{jactype} - see details. } \item{verbose }{if TRUE: full output to the screen, e.g. will print the \code{diagnostiscs} of the integration - see details. } \item{tcrit }{if not \code{NULL}, then \code{vode} cannot integrate past \code{tcrit}. The FORTRAN routine \code{dvode} overshoots its targets (times points in the vector \code{times}), and interpolates values for the desired time points. If there is a time beyond which integration should not proceed (perhaps because of a singularity), that should be provided in \code{tcrit}. } \item{hmin }{an optional minimum value of the integration stepsize. In special situations this parameter may speed up computations with the cost of precision. Don't use hmin if you don't know why! } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, hmax is set to the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. } \item{hini }{initial step size to be attempted; if 0, the initial step size is determined by the solver. } \item{ynames }{logical; if \code{FALSE}: names of state variables are not passed to function \code{func} ; this may speed up the simulation especially for multi-D models. } \item{maxord }{the maximum order to be allowed. \code{NULL} uses the default, i.e. order 12 if implicit Adams method (meth = 1), order 5 if BDF method (meth = 2). Reduce maxord to save storage space. } \item{bandup }{number of non-zero bands above the diagonal, in case the Jacobian is banded. } \item{banddown }{number of non-zero bands below the diagonal, in case the Jacobian is banded. } \item{maxsteps }{maximal number of steps per output interval taken by the solver. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func} and \code{jacfunc}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the dll - you have to perform this check in the code - See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. These names will be used to label the output matrix. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. \link{forcings} or package vignette \code{"compiledCode"} } \item{events }{A matrix or data frame that specifies events, i.e. when the value of a state variable is suddenly changed. See \link{events} for more information. } \item{lags }{A list that specifies timelags, i.e. the number of steps that has to be kept. To be used for delay differential equations. See \link{timelags}, \link{dede} for more information. } \item{... }{additional arguments passed to \code{func} and \code{jacfunc} allowing this to be a generic function. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the FORTRAN routine `vode' returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{Karline Soetaert } \examples{ ## ======================================================================= ## ex. 1 ## The famous Lorenz equations: chaos in the earth's atmosphere ## Lorenz 1963. J. Atmos. Sci. 20, 130-141. ## ======================================================================= chaos <- function(t, state, parameters) { with(as.list(c(state)), { dx <- -8/3 * x + y * z dy <- -10 * (y - z) dz <- -x * y + 28 * y - z list(c(dx, dy, dz)) }) } state <- c(x = 1, y = 1, z = 1) times <- seq(0, 100, 0.01) out <- vode(state, times, chaos, 0) plot(out, type = "l") # all versus time plot(out[,"x"], out[,"y"], type = "l", main = "Lorenz butterfly", xlab = "x", ylab = "y") ## ======================================================================= ## ex. 2 ## SCOC model, in FORTRAN - to see the FORTRAN code: ## browseURL(paste(system.file(package="deSolve"), ## "/doc/examples/dynload/scoc.f",sep="")) ## example from Soetaert and Herman, 2009, chapter 3. (simplified) ## ======================================================================= ## Forcing function data Flux <- matrix(ncol = 2, byrow = TRUE, data = c( 1, 0.654, 11, 0.167, 21, 0.060, 41, 0.070, 73, 0.277, 83, 0.186, 93, 0.140,103, 0.255, 113, 0.231,123, 0.309,133, 1.127,143, 1.923, 153,1.091,163, 1.001, 173, 1.691,183, 1.404,194, 1.226,204, 0.767, 214,0.893,224, 0.737, 234, 0.772,244, 0.726,254, 0.624,264, 0.439, 274,0.168,284, 0.280, 294, 0.202,304, 0.193,315, 0.286,325, 0.599, 335,1.889,345, 0.996, 355, 0.681,365, 1.135)) parms <- c(k = 0.01) meanDepo <- mean(approx(Flux[,1], Flux[,2], xout = seq(1, 365, by = 1))$y) Yini <- c(y = as.double(meanDepo/parms)) times <- 1:365 out <- vode(Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc = "scocforc", forcings = Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation", "Depo")) matplot(out[,1], out[,c("Depo", "Mineralisation")], type = "l", col = c("red", "blue"), xlab = "time", ylab = "Depo") ## Constant interpolation of forcing function - left side of interval fcontrol <- list(method = "constant") out2 <- vode(Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc = "scocforc", forcings = Flux, fcontrol = fcontrol, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation", "Depo")) matplot(out2[,1], out2[,c("Depo", "Mineralisation")], type = "l", col = c("red", "blue"), xlab = "time", ylab = "Depo") ## Constant interpolation of forcing function - middle of interval fcontrol <- list(method = "constant", f = 0.5) out3 <- vode(Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc = "scocforc", forcings = Flux, fcontrol = fcontrol, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation", "Depo")) matplot(out3[,1], out3[,c("Depo", "Mineralisation")], type = "l", col = c("red", "blue"), xlab = "time", ylab = "Depo") plot(out, out2, out3) } \references{ P. N. Brown, G. D. Byrne, and A. C. Hindmarsh, 1989. VODE: A Variable Coefficient ODE Solver, SIAM J. Sci. Stat. Comput., 10, pp. 1038-1051. \cr Also, LLNL Report UCRL-98412, June 1988. G. D. Byrne and A. C. Hindmarsh, 1975. A Polyalgorithm for the Numerical Solution of Ordinary Differential Equations. ACM Trans. Math. Software, 1, pp. 71-96. A. C. Hindmarsh and G. D. Byrne, 1977. EPISODE: An Effective Package for the Integration of Systems of Ordinary Differential Equations. LLNL Report UCID-30112, Rev. 1. G. D. Byrne and A. C. Hindmarsh, 1976. EPISODEB: An Experimental Package for the Integration of Systems of Ordinary Differential Equations with Banded Jacobians. LLNL Report UCID-30132, April 1976. A. C. Hindmarsh, 1983. ODEPACK, a Systematized Collection of ODE Solvers. in Scientific Computing, R. S. Stepleman et al., eds., North-Holland, Amsterdam, pp. 55-64. K. R. Jackson and R. Sacks-Davis, 1980. An Alternative Implementation of Variable Step-Size Multistep Formulas for Stiff ODEs. ACM Trans. Math. Software, 6, pp. 295-318. Netlib: \url{http://www.netlib.org} } \details{ Before using the integrator \code{vode}, the user has to decide whether or not the problem is stiff. If the problem is nonstiff, use method flag \code{mf} = 10, which selects a nonstiff (Adams) method, no Jacobian used. If the problem is stiff, there are four standard choices which can be specified with \code{jactype} or \code{mf}. The options for \bold{jactype} are \describe{ \item{jac = "fullint":}{a full Jacobian, calculated internally by vode, corresponds to \code{mf} = 22, } \item{jac = "fullusr":}{a full Jacobian, specified by user function \code{jacfunc}, corresponds to \code{mf} = 21, } \item{jac = "bandusr":}{a banded Jacobian, specified by user function \code{jacfunc}; the size of the bands specified by \code{bandup} and \code{banddown}, corresponds to \code{mf} = 24, } \item{jac = "bandint":}{a banded Jacobian, calculated by vode; the size of the bands specified by \code{bandup} and \code{banddown}, corresponds to \code{mf} = 25. } } More options are available when specifying \bold{mf} directly. The legal values of \code{mf} are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, 25, -11, -12, -14, -15, -21, -22, -24, -25. \code{mf} is a signed two-digit integer, \code{mf = JSV*(10*METH + MITER)}, where \describe{ \item{JSV = SIGN(mf)}{indicates the Jacobian-saving strategy: JSV = 1 means a copy of the Jacobian is saved for reuse in the corrector iteration algorithm. JSV = -1 means a copy of the Jacobian is not saved. } \item{METH}{indicates the basic linear multistep method: METH = 1 means the implicit Adams method. METH = 2 means the method based on backward differentiation formulas (BDF-s). } \item{MITER}{indicates the corrector iteration method: MITER = 0 means functional iteration (no Jacobian matrix is involved). MITER = 1 means chord iteration with a user-supplied full (NEQ by NEQ) Jacobian. MITER = 2 means chord iteration with an internally generated (difference quotient) full Jacobian (using NEQ extra calls to \code{func} per df/dy value). MITER = 3 means chord iteration with an internally generated diagonal Jacobian approximation (using 1 extra call to \code{func} per df/dy evaluation). MITER = 4 means chord iteration with a user-supplied banded Jacobian. MITER = 5 means chord iteration with an internally generated banded Jacobian (using ML+MU+1 extra calls to \code{func} per df/dy evaluation). } } If MITER = 1 or 4, the user must supply a subroutine \code{jacfunc}. The example for integrator \code{\link{lsode}} demonstrates how to specify both a banded and full Jacobian. The input parameters \code{rtol}, and \code{atol} determine the \bold{error control} performed by the solver. If the request for precision exceeds the capabilities of the machine, vode will return an error code. See \code{\link{lsoda}} for details. The diagnostics of the integration can be printed to screen by calling \code{\link{diagnostics}}. If \code{verbose} = \code{TRUE}, the diagnostics will written to the screen at the end of the integration. See vignette("deSolve") for an explanation of each element in the vectors containing the diagnostic properties and how to directly access them. \bold{Models} may be defined in compiled C or FORTRAN code, as well as in an R-function. See package vignette \code{"compiledCode"} for details. More information about models defined in compiled code is in the package vignette ("compiledCode"); information about linking forcing functions to compiled code is in \link{forcings}. Examples in both C and FORTRAN are in the \file{dynload} subdirectory of the \code{deSolve} package directory. } \seealso{ \itemize{ \item \code{\link{rk}}, \item \code{\link{rk4}} and \code{\link{euler}} for Runge-Kutta integrators. \item \code{\link{lsoda}}, \code{\link{lsode}}, \code{\link{lsodes}}, \code{\link{lsodar}}, \code{\link{daspk}} for other solvers of the Livermore family, \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, } \code{\link{diagnostics}} to print diagnostic messages. } \note{ From version 1.10.4, the default of \code{atol} was changed from 1e-8 to 1e-6, to be consistent with the other solvers. } \keyword{math} deSolve/man/daspk.Rd0000644000176000001440000006361613136461014014062 0ustar ripleyusers\name{daspk} \alias{daspk} \title{Solver for Differential Algebraic Equations (DAE)} \description{ Solves either: \itemize{ \item a system of ordinary differential equations (ODE) of the form \deqn{y' = f(t, y, ...)} or \item a system of differential algebraic equations (DAE) of the form \deqn{F(t,y,y') = 0} or \item a system of linearly implicit DAES in the form \deqn{M y' = f(t, y)} } using a combination of backward differentiation formula (BDF) and a direct linear system solution method (dense or banded). The \R function \code{daspk} provides an interface to the FORTRAN DAE solver of the same name, written by Linda R. Petzold, Peter N. Brown, Alan C. Hindmarsh and Clement W. Ulrich. The system of DE's is written as an \R function (which may, of course, use \code{\link{.C}}, \code{.Fortran}, \code{\link{.Call}}, etc., to call foreign code) or be defined in compiled code that has been dynamically loaded. } \usage{ daspk(y, times, func = NULL, parms, nind = c(length(y), 0, 0), dy = NULL, res = NULL, nalg = 0, rtol = 1e-6, atol = 1e-6, jacfunc = NULL, jacres = NULL, jactype = "fullint", mass = NULL, estini = NULL, verbose = FALSE, tcrit = NULL, hmin = 0, hmax = NULL, hini = 0, ynames = TRUE, maxord = 5, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, events = NULL, lags = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the DE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time; if only one step is to be taken; set \code{times} = \code{NULL}. } \item{func }{to be used if the model is an ODE, or a DAE written in linearly implicit form (M y' = f(t, y)). \code{func} should be an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time t. \code{func} must be defined as: \code{func <- function(t, y, parms,...)}. \cr \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}, unless \code{ynames} is FALSE. \code{parms} is a vector or list of parameters. \code{...} (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives should be specified in the same order as the specification of the state variables \code{y}. Note that it is not possible to define \code{func} as a compiled function in a dynamically loaded shared library. Use \code{res} instead. } \item{parms }{vector or list of parameters used in \code{func}, \code{jacfunc}, or \code{res} } \item{nind }{if a DAE system: a three-valued vector with the number of variables of index 1, 2, 3 respectively. The equations must be defined such that the index 1 variables precede the index 2 variables which in turn precede the index 3 variables. The sum of the variables of different index should equal N, the total number of variables. Note that this has been added for consistency with \link{radau}. If used, then the variables are weighed differently than in the original daspk code, i.e. index 2 variables are scaled with 1/h, index 3 variables are scaled with 1/h^2. In some cases this allows daspk to solve index 2 or index 3 problems. } \item{dy }{the initial derivatives of the state variables of the DE system. Ignored if an ODE. } \item{res }{if a DAE system: either an \R-function that computes the residual function \eqn{F(t,y,y')} of the DAE system (the model defininition) at time \code{t}, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{res} is a user-supplied \R-function, it must be defined as: \code{res <- function(t, y, dy, parms, ...)}. Here \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system, \code{dy} are the corresponding derivatives. If the initial \code{y} or \code{dy} have a \code{names} attribute, the names will be available inside \code{res}, unless \code{ynames} is \code{FALSE}. \code{parms} is a vector of parameters. The return value of \code{res} should be a list, whose first element is a vector containing the residuals of the DAE system, i.e. \eqn{\delta = F(t,y,y')}{delta = F(t,y,y')}, and whose next elements contain output variables that are required at each point in \code{times}. If \code{res} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{daspk()} is called (see package vignette \code{"compiledCode"} for more information). } \item{nalg }{if a DAE system: the number of algebraic equations (equations not involving derivatives). Algebraic equations should always be the last, i.e. preceeded by the differential equations. Only used if \code{estini} = 1. } \item{rtol }{relative error tolerance, either a scalar or a vector, one value for each y, } \item{atol }{absolute error tolerance, either a scalar or a vector, one value for each y. } \item{jacfunc }{if not \code{NULL}, an \R function that computes the Jacobian of the system of differential equations. Only used in case the system is an ODE (\eqn{y' = f(t, y)}), specified by \code{func}. The \R calling sequence for \code{jacfunc} is identical to that of \code{func}. If the Jacobian is a full matrix, \code{jacfunc} should return a matrix \eqn{\partial\dot{y}/\partial y}{dydot/dy}, where the ith row contains the derivative of \eqn{dy_i/dt} with respect to \eqn{y_j}, or a vector containing the matrix elements by columns (the way \R and FORTRAN store matrices). If the Jacobian is banded, \code{jacfunc} should return a matrix containing only the nonzero bands of the Jacobian, rotated row-wise. See first example of lsode. } \item{jacres }{ \code{jacres} and not \code{jacfunc} should be used if the system is specified by the residual function \eqn{F(t, y, y')}, i.e. \code{jacres} is used in conjunction with \code{res}. If \code{jacres} is an \R-function, the calling sequence for \code{jacres} is identical to that of \code{res}, but with extra parameter \code{cj}. Thus it should be called as: \code{jacres = func(t, y, dy, parms, cj, ...)}. Here \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system, \eqn{y'} are the corresponding derivatives and \code{cj} is a scalar, which is normally proportional to the inverse of the stepsize. If the initial \code{y} or \code{dy} have a \code{names} attribute, the names will be available inside \code{jacres}, unless \code{ynames} is \code{FALSE}. \code{parms} is a vector of parameters (which may have a names attribute). If the Jacobian is a full matrix, \code{jacres} should return the matrix \eqn{dG/dy + c_j\cdot dG/dy'}{dG/d y + cj*dG/d y'}, where the \eqn{i}th row is the sum of the derivatives of \eqn{G_i} with respect to \eqn{y_j} and the scaled derivatives of \eqn{G_i} with respect to \eqn{y'_j}. If the Jacobian is banded, \code{jacres} should return only the nonzero bands of the Jacobian, rotated rowwise. See details for the calling sequence when \code{jacres} is a string. } \item{jactype }{the structure of the Jacobian, one of \code{"fullint"}, \code{"fullusr"}, \code{"bandusr"} or \code{"bandint"} - either full or banded and estimated internally or by the user. } \item{mass }{the mass matrix. If not \code{NULL}, the problem is a linearly implicit DAE and defined as \eqn{M\, dy/dt = f(t,y)}{M dy/dt = f(t,y)}. The mass-matrix \eqn{M} should be of dimension \eqn{n*n} where \eqn{n} is the number of \eqn{y}-values. If \code{mass=NULL} then the model is either an ODE or a DAE, specified with \code{res} } \item{estini }{only if a DAE system, and if initial values of \code{y} and \code{dy} are not consistent (i.e. \eqn{F(t,y,dy) \neq 0}{F(t, y, dy) != 0}), setting \code{estini} = 1 or 2, will solve for them. If \code{estini} = 1: dy and the algebraic variables are estimated from \code{y}; in this case, the number of algebraic equations must be given (\code{nalg}). If \code{estini} = 2: \code{y} will be estimated from \code{dy}. } \item{verbose }{if TRUE: full output to the screen, e.g. will print the \code{diagnostiscs} of the integration - see details. } \item{tcrit }{the FORTRAN routine \code{daspk} overshoots its targets (times points in the vector \code{times}), and interpolates values for the desired time points. If there is a time beyond which integration should not proceed (perhaps because of a singularity), that should be provided in \code{tcrit}. } \item{hmin }{an optional minimum value of the integration stepsize. In special situations this parameter may speed up computations with the cost of precision. Don't use \code{hmin} if you don't know why! } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, \code{hmax} is set to the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. } \item{hini }{initial step size to be attempted; if 0, the initial step size is determined by the solver } \item{ynames }{logical, if \code{FALSE}, names of state variables are not passed to function \code{func}; this may speed up the simulation especially for large models. } \item{maxord }{the maximum order to be allowed. Reduce \code{maxord} to save storage space ( <= 5) } \item{bandup }{number of non-zero bands above the diagonal, in case the Jacobian is banded (and \code{jactype} one of "bandint", "bandusr") } \item{banddown }{number of non-zero bands below the diagonal, in case the Jacobian is banded (and \code{jactype} one of "bandint", "bandusr") } \item{maxsteps }{maximal number of steps per output interval taken by the solver; will be recalculated to be at least 500 and a multiple of 500; if \code{verbose} is \code{TRUE} the solver will give a warning if more than 500 steps are taken, but it will continue till \code{maxsteps} steps. (Note this warning was always given in deSolve versions < 1.10.3). } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions referred to in \code{res} and \code{jacres}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the dll-functions whose names are specified by \code{res} and \code{jacres}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{res} and \code{jacres}. } \item{nout }{only used if \file{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{res}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the dll - you have to perform this check in the code - See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{res}, present in the shared library. These names will be used to label the output matrix. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See \link{forcings} or vignette \code{compiledCode}. } \item{events }{A matrix or data frame that specifies events, i.e. when the value of a state variable is suddenly changed. See \link{events} for more information. } \item{lags }{A list that specifies timelags, i.e. the number of steps that has to be kept. To be used for delay differential equations. See \link{timelags}, \link{dede} for more information. } \item{... }{additional arguments passed to \code{func}, \code{jacfunc}, \code{res} and \code{jacres}, allowing this to be a generic function. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func} or \code{res}, plus an additional column (the first) for the time value. There will be one row for each element in \code{times} unless the FORTRAN routine `daspk' returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{Karline Soetaert } \examples{ ## ======================================================================= ## Coupled chemical reactions including an equilibrium ## modeled as (1) an ODE and (2) as a DAE ## ## The model describes three chemical species A,B,D: ## subjected to equilibrium reaction D <- > A + B ## D is produced at a constant rate, prod ## B is consumed at 1s-t order rate, r ## Chemical problem formulation 1: ODE ## ======================================================================= ## Dissociation constant K <- 1 ## parameters pars <- c( ka = 1e6, # forward rate r = 1, prod = 0.1) Fun_ODE <- function (t, y, pars) { with (as.list(c(y, pars)), { ra <- ka*D # forward rate rb <- ka/K *A*B # backward rate ## rates of changes dD <- -ra + rb + prod dA <- ra - rb dB <- ra - rb - r*B return(list(dy = c(dA, dB, dD), CONC = A+B+D)) }) } ## ======================================================================= ## Chemical problem formulation 2: DAE ## 1. get rid of the fast reactions ra and rb by taking ## linear combinations : dD+dA = prod (res1) and ## dB-dA = -r*B (res2) ## 2. In addition, the equilibrium condition (eq) reads: ## as ra = rb : ka*D = ka/K*A*B = > K*D = A*B ## ======================================================================= Res_DAE <- function (t, y, yprime, pars) { with (as.list(c(y, yprime, pars)), { ## residuals of lumped rates of changes res1 <- -dD - dA + prod res2 <- -dB + dA - r*B ## and the equilibrium equation eq <- K*D - A*B return(list(c(res1, res2, eq), CONC = A+B+D)) }) } ## ======================================================================= ## Chemical problem formulation 3: Mass * Func ## Based on the DAE formulation ## ======================================================================= Mass_FUN <- function (t, y, pars) { with (as.list(c(y, pars)), { ## as above, but without the f1 <- prod f2 <- - r*B ## and the equilibrium equation f3 <- K*D - A*B return(list(c(f1, f2, f3), CONC = A+B+D)) }) } Mass <- matrix(nrow = 3, ncol = 3, byrow = TRUE, data=c(1, 0, 1, # dA + 0 + dB -1, 1, 0, # -dA + dB +0 0, 0, 0)) # algebraic times <- seq(0, 100, by = 2) ## Initial conc; D is in equilibrium with A,B y <- c(A = 2, B = 3, D = 2*3/K) ## ODE model solved with daspk ODE <- daspk(y = y, times = times, func = Fun_ODE, parms = pars, atol = 1e-10, rtol = 1e-10) ## Initial rate of change dy <- c(dA = 0, dB = 0, dD = 0) ## DAE model solved with daspk DAE <- daspk(y = y, dy = dy, times = times, res = Res_DAE, parms = pars, atol = 1e-10, rtol = 1e-10) MASS<- daspk(y=y, times=times, func = Mass_FUN, parms = pars, mass = Mass) ## ================ ## plotting output ## ================ plot(ODE, DAE, xlab = "time", ylab = "conc", type = c("l", "p"), pch = c(NA, 1)) legend("bottomright", lty = c(1, NA), pch = c(NA, 1), col = c("black", "red"), legend = c("ODE", "DAE")) # difference between both implementations: max(abs(ODE-DAE)) ## ======================================================================= ## same DAE model, now with the Jacobian ## ======================================================================= jacres_DAE <- function (t, y, yprime, pars, cj) { with (as.list(c(y, yprime, pars)), { ## res1 = -dD - dA + prod PD[1,1] <- -1*cj # d(res1)/d(A)-cj*d(res1)/d(dA) PD[1,2] <- 0 # d(res1)/d(B)-cj*d(res1)/d(dB) PD[1,3] <- -1*cj # d(res1)/d(D)-cj*d(res1)/d(dD) ## res2 = -dB + dA - r*B PD[2,1] <- 1*cj PD[2,2] <- -r -1*cj PD[2,3] <- 0 ## eq = K*D - A*B PD[3,1] <- -B PD[3,2] <- -A PD[3,3] <- K return(PD) }) } PD <- matrix(ncol = 3, nrow = 3, 0) DAE2 <- daspk(y = y, dy = dy, times = times, res = Res_DAE, jacres = jacres_DAE, jactype = "fullusr", parms = pars, atol = 1e-10, rtol = 1e-10) max(abs(DAE-DAE2)) ## See \dynload subdirectory for a FORTRAN implementation of this model ## ======================================================================= ## The chemical model as a DLL, with production a forcing function ## ======================================================================= times <- seq(0, 100, by = 2) pars <- c(K = 1, ka = 1e6, r = 1) ## Initial conc; D is in equilibrium with A,B y <- c(A = 2, B = 3, D = as.double(2*3/pars["K"])) ## Initial rate of change dy <- c(dA = 0, dB = 0, dD = 0) # production increases with time prod <- matrix(ncol = 2, data = c(seq(0, 100, by = 10), 0.1*(1+runif(11)*1))) ODE_dll <- daspk(y = y, dy = dy, times = times, res = "chemres", dllname = "deSolve", initfunc = "initparms", initforc = "initforcs", parms = pars, forcings = prod, atol = 1e-10, rtol = 1e-10, nout = 2, outnames = c("CONC","Prod")) plot(ODE_dll, which = c("Prod", "D"), xlab = "time", ylab = c("/day", "conc"), main = c("production rate","D")) } \references{ L. R. Petzold, A Description of DASSL: A Differential/Algebraic System Solver, in Scientific Computing, R. S. Stepleman et al. (Eds.), North-Holland, Amsterdam, 1983, pp. 65-68. K. E. Brenan, S. L. Campbell, and L. R. Petzold, Numerical Solution of Initial-Value Problems in Differential-Algebraic Equations, Elsevier, New York, 1989. P. N. Brown and A. C. Hindmarsh, Reduced Storage Matrix Methods in Stiff ODE Systems, J. Applied Mathematics and Computation, 31 (1989), pp. 40-91. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Using Krylov Methods in the Solution of Large-Scale Differential-Algebraic Systems, SIAM J. Sci. Comp., 15 (1994), pp. 1467-1488. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Consistent Initial Condition Calculation for Differential-Algebraic Systems, LLNL Report UCRL-JC-122175, August 1995; submitted to SIAM J. Sci. Comp. Netlib: \url{http://www.netlib.org} } \details{ The daspk solver uses the backward differentiation formulas of orders one through five (specified with \code{maxord}) to solve either: \itemize{ \item an ODE system of the form \deqn{y' = f(t,y,...)} or \item a DAE system of the form \deqn{y' = M f(t,y,...)} or \item a DAE system of the form \deqn{F(t,y,y') = 0}. The index of the DAE should be preferable <= 1. } ODEs are specified using argument \code{func}, DAEs are specified using argument \code{res}. If a DAE system, Values for y \emph{and} y' (argument \code{dy}) at the initial time must be given as input. Ideally, these values should be consistent, that is, if t, y, y' are the given initial values, they should satisfy F(t,y,y') = 0. \cr However, if consistent values are not known, in many cases daspk can solve for them: when \code{estini} = 1, y' and algebraic variables (their number specified with \code{nalg}) will be estimated, when \code{estini} = 2, y will be estimated. The form of the \bold{Jacobian} can be specified by \code{jactype}. This is one of: \describe{ \item{jactype = "fullint":}{a full Jacobian, calculated internally by \code{daspk}, the default, } \item{jactype = "fullusr":}{a full Jacobian, specified by user function \code{jacfunc} or \code{jacres}, } \item{jactype = "bandusr":}{a banded Jacobian, specified by user function \code{jacfunc} or \code{jacres}; the size of the bands specified by \code{bandup} and \code{banddown}, } \item{jactype = "bandint":}{a banded Jacobian, calculated by \code{daspk}; the size of the bands specified by \code{bandup} and \code{banddown}. } } If \code{jactype} = "fullusr" or "bandusr" then the user must supply a subroutine \code{jacfunc}. If jactype = "fullusr" or "bandusr" then the user must supply a subroutine \code{jacfunc} or \code{jacres}. The input parameters \code{rtol}, and \code{atol} determine the \bold{error control} performed by the solver. If the request for precision exceeds the capabilities of the machine, \code{daspk} will return an error code. See \code{\link{lsoda}} for details. When the index of the variables is specified (argument \code{nind}), and higher index variables are present, then the equations are scaled such that equations corresponding to index 2 variables are multiplied with 1/h, for index 3 they are multiplied with 1/h^2, where h is the time step. This is not in the standard DASPK code, but has been added for consistency with solver \link{radau}. Because of this, daspk can solve certain index 2 or index 3 problems. \bold{res and jacres} may be defined in compiled C or FORTRAN code, as well as in an R-function. See package vignette \code{"compiledCode"} for details. Examples in FORTRAN are in the \file{dynload} subdirectory of the \code{deSolve} package directory. The diagnostics of the integration can be printed to screen by calling \code{\link{diagnostics}}. If \code{verbose} = \code{TRUE}, the diagnostics will written to the screen at the end of the integration. See vignette("deSolve") for an explanation of each element in the vectors containing the diagnostic properties and how to directly access them. \bold{Models} may be defined in compiled C or FORTRAN code, as well as in an R-function. See package vignette \code{"compiledCode"} for details. More information about models defined in compiled code is in the package vignette ("compiledCode"); information about linking forcing functions to compiled code is in \link{forcings}. Examples in both C and FORTRAN are in the \file{dynload} subdirectory of the \code{deSolve} package directory. } \seealso{ \itemize{ \item \code{\link{radau}} for integrating DAEs up to index 3, \item \code{\link{rk}}, \item \code{\link{rk4}} and \code{\link{euler}} for Runge-Kutta integrators. \item \code{\link{lsoda}}, \code{\link{lsode}}, \code{\link{lsodes}}, \code{\link{lsodar}}, \code{\link{vode}}, for other solvers of the Livermore family, \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, } \code{\link{diagnostics}} to print diagnostic messages. } \note{ In this version, the Krylov method is not (yet) supported. From \code{deSolve} version 1.10.4 and above, the following changes were made \enumerate{ \item the argument list to \code{daspk} now also includes \code{nind}, the index of each variable. This is used to scale the variables, such that \code{daspk} in R can also solve certain index 2 or index 3 problems, which the original Fortran version may not be able to solve. \item the default of \code{atol} was changed from 1e-8 to 1e-6, to be consistent with the other solvers. \item the multiple warnings from daspk when the number of steps exceed 500 were toggled off unless \code{verbose} is \code{TRUE} } } \keyword{math} deSolve/man/ode.2D.Rd0000644000176000001440000003141013136461014013756 0ustar ripleyusers\name{ode.2D} \alias{ode.2D} \title{Solver for 2-Dimensional Ordinary Differential Equations} \description{ Solves a system of ordinary differential equations resulting from 2-Dimensional partial differential equations that have been converted to ODEs by numerical differencing. } \usage{ ode.2D(y, times, func, parms, nspec = NULL, dimens, method= c("lsodes", "euler", "rk4", "ode23", "ode45", "adams", "iteration"), names = NULL, cyclicBnd = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system, a vector. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the model definition) at time \code{t}, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms, ...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; \code{...} (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. } \item{parms }{parameters passed to \code{func}.} \item{nspec }{the number of \bold{species} (components) in the model.} \item{dimens}{2-valued vector with the number of \bold{boxes} in two dimensions in the model. } \item{cyclicBnd }{if not \code{NULL} then a number or a 2-valued vector with the dimensions where a cyclic boundary is used - \code{1}: x-dimension, \code{2}: y-dimension; see details. } \item{names }{the names of the components; used for plotting. } \item{method }{the integrator. Use \code{"lsodes"} if the model is very stiff; \code{"impAdams"} may be best suited for mildly stiff problems; \code{"euler", "rk4", "ode23", "ode45", "adams"} are most efficient for non-stiff problems. Also allowed is to pass an integrator \code{function}. Use one of the other Runge-Kutta methods via \code{rkMethod}. For instance, \code{method = rkMethod("ode45ck")} will trigger the Cash-Karp method of order 4(5). If \code{"lsodes"} is used, then also the size of the work array should be specified (\code{lrw}) (see \link{lsodes}). Method \code{"iteration"} is special in that here the function \code{func} should return the new value of the state variables rather than the rate of change. This can be used for individual based models, for difference equations, or in those cases where the integration is performed within \code{func}) } \item{... }{additional arguments passed to \code{lsodes}.} } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in times and as many columns as elements in \code{y} plus the number of "global" values returned in the second element of the return from \code{func}, plus an additional column (the first) for the time value. There will be one row for each element in \code{times} unless the integrator returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. The output will have the attributes \code{istate}, and \code{rstate}, two vectors with several useful elements. The first element of istate returns the conditions under which the last call to the integrator returned. Normal is \code{istate = 2}. If \code{verbose = TRUE}, the settings of istate and rstate will be written to the screen. See the help for the selected integrator for details. } \note{ It is advisable though not mandatory to specify \bold{both} \code{nspec} and \code{dimens}. In this case, the solver can check whether the input makes sense (as \code{nspec * dimens[1] * dimens[2] == length(y)}). Do \bold{not} use this method for problems that are not 2D! } \author{Karline Soetaert } \examples{ ## ======================================================================= ## A Lotka-Volterra predator-prey model with predator and prey ## dispersing in 2 dimensions ## ======================================================================= ## ================== ## Model definitions ## ================== lvmod2D <- function (time, state, pars, N, Da, dx) { NN <- N*N Prey <- matrix(nrow = N, ncol = N,state[1:NN]) Pred <- matrix(nrow = N, ncol = N,state[(NN+1):(2*NN)]) with (as.list(pars), { ## Biology dPrey <- rGrow * Prey * (1- Prey/K) - rIng * Prey * Pred dPred <- rIng * Prey * Pred*assEff - rMort * Pred zero <- rep(0, N) ## 1. Fluxes in x-direction; zero fluxes near boundaries FluxPrey <- -Da * rbind(zero,(Prey[2:N,] - Prey[1:(N-1),]), zero)/dx FluxPred <- -Da * rbind(zero,(Pred[2:N,] - Pred[1:(N-1),]), zero)/dx ## Add flux gradient to rate of change dPrey <- dPrey - (FluxPrey[2:(N+1),] - FluxPrey[1:N,])/dx dPred <- dPred - (FluxPred[2:(N+1),] - FluxPred[1:N,])/dx ## 2. Fluxes in y-direction; zero fluxes near boundaries FluxPrey <- -Da * cbind(zero,(Prey[,2:N] - Prey[,1:(N-1)]), zero)/dx FluxPred <- -Da * cbind(zero,(Pred[,2:N] - Pred[,1:(N-1)]), zero)/dx ## Add flux gradient to rate of change dPrey <- dPrey - (FluxPrey[,2:(N+1)] - FluxPrey[,1:N])/dx dPred <- dPred - (FluxPred[,2:(N+1)] - FluxPred[,1:N])/dx return(list(c(as.vector(dPrey), as.vector(dPred)))) }) } ## =================== ## Model applications ## =================== pars <- c(rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of predator assEff = 0.5, # -, assimilation efficiency K = 5 ) # mmol/m3, carrying capacity R <- 20 # total length of surface, m N <- 50 # number of boxes in one direction dx <- R/N # thickness of each layer Da <- 0.05 # m2/d, dispersion coefficient NN <- N*N # total number of boxes ## initial conditions yini <- rep(0, 2*N*N) cc <- c((NN/2):(NN/2+1)+N/2, (NN/2):(NN/2+1)-N/2) yini[cc] <- yini[NN+cc] <- 1 ## solve model (5000 state variables... use Cash-Karp Runge-Kutta method times <- seq(0, 50, by = 1) out <- ode.2D(y = yini, times = times, func = lvmod2D, parms = pars, dimens = c(N, N), names = c("Prey", "Pred"), N = N, dx = dx, Da = Da, method = rkMethod("rk45ck")) diagnostics(out) summary(out) # Mean of prey concentration at each time step Prey <- subset(out, select = "Prey", arr = TRUE) dim(Prey) MeanPrey <- apply(Prey, MARGIN = 3, FUN = mean) plot(times, MeanPrey) \dontrun{ ## plot results Col <- colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000")) for (i in seq(1, length(times), by = 1)) image(Prey[ , ,i], col = Col(100), xlab = , zlim = range(out[,2:(NN+1)])) ## similar, plotting both and adding a margin text with times: image(out, xlab = "x", ylab = "y", mtext = paste("time = ", times)) } select <- c(1, 40) image(out, xlab = "x", ylab = "y", mtext = "Lotka-Volterra in 2-D", subset = select, mfrow = c(2,2), legend = TRUE) # plot prey and pred at t = 10; first use subset to select data prey10 <- matrix (nrow = N, ncol = N, data = subset(out, select = "Prey", subset = (time == 10))) pred10 <- matrix (nrow = N, ncol = N, data = subset(out, select = "Pred", subset = (time == 10))) mf <- par(mfrow = c(1, 2)) image(prey10) image(pred10) par (mfrow = mf) # same, using deSolve's image: image(out, subset = (time == 10)) ## ======================================================================= ## An example with a cyclic boundary condition. ## Diffusion in 2-D; extra flux on 2 boundaries, ## cyclic boundary in y ## ======================================================================= diffusion2D <- function(t, Y, par) { y <- matrix(nrow = nx, ncol = ny, data = Y) # vector to 2-D matrix dY <- -r * y # consumption BNDx <- rep(1, nx) # boundary concentration BNDy <- rep(1, ny) # boundary concentration ## diffusion in X-direction; boundaries=imposed concentration Flux <- -Dx * rbind(y[1,] - BNDy, (y[2:nx,] - y[1:(nx-1),]), BNDy - y[nx,])/dx dY <- dY - (Flux[2:(nx+1),] - Flux[1:nx,])/dx ## diffusion in Y-direction Flux <- -Dy * cbind(y[,1] - BNDx, (y[,2:ny]-y[,1:(ny-1)]), BNDx - y[,ny])/dy dY <- dY - (Flux[,2:(ny+1)] - Flux[,1:ny])/dy ## extra flux on two sides dY[,1] <- dY[,1] + 10 dY[1,] <- dY[1,] + 10 ## and exchange between sides on y-direction dY[,ny] <- dY[,ny] + (y[,1] - y[,ny]) * 10 return(list(as.vector(dY))) } ## parameters dy <- dx <- 1 # grid size Dy <- Dx <- 1 # diffusion coeff, X- and Y-direction r <- 0.05 # consumption rate nx <- 50 ny <- 100 y <- matrix(nrow = nx, ncol = ny, 1) ## model most efficiently solved with lsodes - need to specify lrw print(system.time( ST3 <- ode.2D(y, times = 1:100, func = diffusion2D, parms = NULL, dimens = c(nx, ny), verbose = TRUE, names = "Y", lrw = 400000, atol = 1e-10, rtol = 1e-10, cyclicBnd = 2) )) # summary of 2-D variable summary(ST3) # plot output at t = 10 t10 <- matrix (nrow = nx, ncol = ny, data = subset(ST3, select = "Y", subset = (time == 10))) persp(t10, theta = 30, border = NA, phi = 70, col = "lightblue", shade = 0.5, box = FALSE) # image plot, using deSolve's image function image(ST3, subset = time == 10, method = "persp", theta = 30, border = NA, phi = 70, main = "", col = "lightblue", shade = 0.5, box = FALSE) \dontrun{ zlim <- range(ST3[, -1]) for (i in 2:nrow(ST3)) { y <- matrix(nrow = nx, ncol = ny, data = ST3[i, -1]) filled.contour(y, zlim = zlim, main = i) } # same image(ST3, method = "filled.contour") } } \details{ This is the method of choice for 2-dimensional models, that are only subjected to transport between adjacent layers. Based on the dimension of the problem, and if \code{lsodes} is used as the integrator, the method first calculates the sparsity pattern of the Jacobian, under the assumption that transport is only occurring between adjacent layers. Then \code{lsodes} is called to solve the problem. If the model is not stiff, then it is more efficient to use one of the explicit integration routines In some cases, a cyclic boundary condition exists. This is when the first boxes in x-or y-direction interact with the last boxes. In this case, there will be extra non-zero fringes in the Jacobian which need to be taken into account. The occurrence of cyclic boundaries can be toggled on by specifying argument \code{cyclicBnd}. For innstance, \code{cyclicBnd = 1} indicates that a cyclic boundary is required only for the x-direction, whereas \code{cyclicBnd = c(1,2)} imposes a cyclic boundary for both x- and y-direction. The default is no cyclic boundaries. If \code{lsodes} is used to integrate, it will probably be necessary to specify the length of the real work array, \code{lrw}. Although a reasonable guess of \code{lrw} is made, it is likely that this will be too low. In this case, \code{ode.2D} will return with an error message telling the size of the work array actually needed. In the second try then, set \code{lrw} equal to this number. For instance, if you get the error: \preformatted{ DLSODES- RWORK length is insufficient to proceed. Length needed is .ge. LENRW (=I1), exceeds LRW (=I2) In above message, I1 = 27627 I2 = 25932 } set \code{lrw} equal to 27627 or a higher value. See \link{lsodes} for the additional options. } \seealso{ \itemize{ \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for integrating models with a banded Jacobian \item \code{\link{ode.1D}} for integrating 1-D models \item \code{\link{ode.3D}} for integrating 3-D models \item \code{\link{lsodes}} for the integration options. } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/plot.deSolve.Rd0000644000176000001440000003520613275007613015335 0ustar ripleyusers\name{plot.deSolve} \alias{plot.deSolve} \alias{plot.1D} \alias{matplot.0D} \alias{matplot.deSolve} \alias{matplot.1D} %\alias{matplot,deSolve-method} \alias{hist.deSolve} \alias{image.deSolve} \alias{subset.deSolve} \title{ Plot, Image and Histogram Method for deSolve Objects } \description{ Plot the output of numeric integration routines. } \usage{ \method{plot}{deSolve}(x, \dots, select = NULL, which = select, ask = NULL, obs = NULL, obspar = list(), subset = NULL) %% thpe: since 1.14 not anymore exported %\method{matplot}{deSolve}(x, \dots, select = NULL, which = select, % obs = NULL, obspar = list(), subset = NULL, % legend = list(x = "topright")) \method{hist}{deSolve}(x, select = 1:(ncol(x)-1), which = select, ask = NULL, subset = NULL, \dots) \method{image}{deSolve}(x, select = NULL, which = select, ask = NULL, add.contour = FALSE, grid = NULL, method = "image", legend = FALSE, subset = NULL, \dots) \method{subset}{deSolve}(x, subset = NULL, select = NULL, which = select, arr = FALSE, \dots) plot.1D (x, \dots, select = NULL, which = select, ask = NULL, obs = NULL, obspar = list(), grid = NULL, xyswap = FALSE, delay = 0, vertical = FALSE, subset = NULL) matplot.0D(x, \dots, select = NULL, which = select, obs = NULL, obspar = list(), subset = NULL, legend = list(x = "topright")) matplot.1D(x, select = NULL, which = select, ask = NULL, obs = NULL, obspar = list(), grid = NULL, xyswap = FALSE, vertical = FALSE, subset = NULL, \dots) } \arguments{ \item{x }{an object of class \code{deSolve}, as returned by the integrators, and to be plotted. For \code{plot.deSolve}, it is allowed to pass several objects of class \code{deSolve} after \code{x} (unnamed) - see second example. } \item{which }{the name(s) or the index to the variables that should be plotted or selected. Default = all variables, except \code{time}. For use with \code{matplot.0D} and \code{matplot.1D}, \code{which} or \code{select} can be a list, with vectors, each referring to a separate y-axis. } \item{select }{which variable/columns to be selected. This is added for consistency with the R-function \code{subset}. } \item{subset }{either a logical expression indicating elements or rows to keep in \code{select}, or a vector of integers denoting the indices of the elements over which to loop. Missing values are taken as \code{FALSE} } \item{ask }{logical; if \code{TRUE}, the user is \emph{ask}ed before each plot, if \code{NULL} the user is only asked if more than one page of plots is necessary and the current graphics device is set interactive, see \code{\link{par}(ask)} and \code{\link{dev.interactive}}.} \item{add.contour }{if \code{TRUE}, will add contours to the image plot.} \item{method }{the name of the plotting method to use, one of "image", "filled.contour", "persp", "contour".} \item{grid }{only for \code{image} plots and for \code{plot.1D}: the 1-D grid as a vector (for output generated with \code{ode.1D}), or the x- and y-grid, as a \code{list} (for output generated with \code{ode.2D}).} \item{xyswap }{if \code{TRUE}, then x-and y-values are swapped and the y-axis is from top to bottom. Useful for drawing vertical profiles.} \item{vertical }{if \code{TRUE}, then 1. x-and y-values are swapped, the y-axis is from top to bottom, the x-axis is on top, margin 3 and the main title gets the value of the x-axis. Useful for drawing vertical profiles; see example 2.} \item{delay }{adds a delay (in milliseconds) between consecutive plots of \code{plot.1D} to enable animations.} \item{obs }{a \code{data.frame} or \code{matrix} with "observed data" that will be added as \code{points} to the plots. \code{obs} can also be a \code{list} with multiple data.frames and/or matrices containing observed data. By default the first column of an observed data set should contain the \code{time}-variable. The other columns contain the observed values and they should have names that are known in \code{x}. If the first column of \code{obs} consists of factors or characters (strings), then it is assumed that the data are presented in long (database) format, where the first three columns contain (name, time, value). If \code{obs} is not \code{NULL} and \code{which} is \code{NULL}, then the variables, common to both \code{obs} and \code{x} will be plotted. } \item{obspar }{additional graphics arguments passed to \code{points}, for plotting the observed data. If \code{obs} is a \code{list} containing multiple observed data sets, then the graphics arguments can be a vector or a list (e.g. for \code{xlim}, \code{ylim}), specifying each data set separately. } \item{legend }{if \code{TRUE}, a color legend will be drawn on the right of each image. For use with \code{matplot.0D} and \code{matplot.1D}: a \code{list} with arguments passed to R-function \link{legend}. } \item{arr }{if \code{TRUE}, and the output is from a 2-D or 3-D model, an array will be returned with dimension = c(dimension of selected variable, nrow(x)). When \code{arr=TRUE} then only one variable can be selected. When the output is from a 0-D or 1-D model, then this argument is ignored. } \item{\dots}{additional arguments. The graphical arguments are passed to \code{\link{plot.default}}, \code{\link{image}} or \code{\link{hist}} For \code{plot.deSolve}, and \code{plot.1D}, the dots may contain other objects of class \code{deSolve}, as returned by the integrators, and to be plotted on the same graphs as \code{x} - see second example. In this case, \code{x} and and these other objects should be compatible, i.e. the column names should be the same. For \code{plot.deSolve}, the arguments after \ldots must be matched exactly. } } \value{ Function \code{subset} called with \code{arr = FALSE} will return a matrix with up to as many rows as selected by \code{subset} and as many columns as selected variables. When \code{arr = TRUE} then an array will be outputted with dimensions equal to the dimension of the selected variable, augmented with the number of rows selected by \code{subset}. This means that the last dimension points to \code{times}. Function \code{subset} also has an attribute that contains the \code{times} selected. } \details{ The number of panels per page is automatically determined up to 3 x 3 (\code{par(mfrow = c(3, 3))}). This default can be overwritten by specifying user-defined settings for \code{mfrow} or \code{mfcol}. Set \code{mfrow} equal to \code{NULL} to avoid the plotting function to change user-defined \code{mfrow} or \code{mfcol} settings. Other graphical parameters can be passed as well. Parameters are vectorized, either according to the number of plots (\code{xlab}, \code{ylab}, \code{main}, \code{sub}, \code{xlim}, \code{ylim}, \code{log}, \code{asp}, \code{ann}, \code{axes}, \code{frame.plot}, \code{panel.first}, \code{panel.last}, \code{cex.lab}, \code{cex.axis}, \code{cex.main}) or according to the number of lines within one plot (other parameters e.g. \code{col}, \code{lty}, \code{lwd} etc.) so it is possible to assign specific axis labels to individual plots, resp. different plotting style. Plotting parameter \code{ylim}, or \code{xlim} can also be a list to assign different axis limits to individual plots. Similarly, the graphical parameters for observed data, as passed by \code{obspar} can be vectorized, according to the number of observed data sets. Image plots will only work for 1-D and 2-D variables, as solved with \code{\link{ode.1D}} and \code{\link{ode.2D}}. In the first case, an image with \code{times} as x- and the \code{grid} as y-axis will be created. In the second case, an x-y plot will be created, for all times. Unless \code{ask = FALSE}, the user will be asked to confirm page changes. Via argument \code{mtext}, it is possible to label each page in case of 2D output. For images, it is possible to pass an argument \code{method} which can take the values "image" (default), "filled.contour", "contour" or "persp", in order to use the respective plotting method. \code{plot} and \code{matplot.0D} will always have \code{times} on the x-axis. For problems solved with \code{ode.1D}, it may be more useful to use \code{plot.1D} or \code{matplot.1D} which will plot how spatial variables change with time. These plots will have the \code{grid} on the x-axis. } \seealso{ \code{\link{deSolve}}, \code{\link{ode}}, \code{\link{print.deSolve}}, \code{\link[graphics]{hist}} \code{\link[graphics]{image}} \code{\link[graphics]{matplot}}, \code{\link[graphics]{plot}.default} for the underlying functions from package \pkg{graphics}, \code{\link{ode.2D}}, for an example of using \code{subset} with \code{arr = TRUE}. } \examples{ ## ======================================================================= ## Example 1. A Predator-Prey model with 4 species in matrix formulation ## ======================================================================= LVmatrix <- function(t, n, parms) { with(parms, { dn <- r * n + n * (A \%*\% n) return(list(c(dn))) }) } parms <- list( r = c(r1 = 0.1, r2 = 0.1, r3 = -0.1, r4 = -0.1), A = matrix(c(0.0, 0.0, -0.2, 0.01, # prey 1 0.0, 0.0, 0.02, -0.1, # prey 2 0.2, 0.02, 0.0, 0.0, # predator 1; prefers prey 1 0.01, 0.1, 0.0, 0.0), # predator 2; prefers prey 2 nrow = 4, ncol = 4, byrow=TRUE) ) times <- seq(from = 0, to = 500, by = 0.1) y <- c(prey1 = 1, prey2 = 1, pred1 = 2, pred2 = 2) out <- ode(y, times, LVmatrix, parms) ## Basic line plot plot(out, type = "l") ## User-specified axis labels plot(out, type = "l", ylab = c("Prey 1", "Prey 2", "Pred 1", "Pred 2"), xlab = "Time (d)", main = "Time Series") ## Set user-defined mfrow pm <- par (mfrow = c(2, 2)) ## "mfrow=NULL" keeps user-defined mfrow plot(out, which = c("prey1", "pred2"), mfrow = NULL, type = "l", lwd = 2) plot(out[,"prey1"], out[,"pred1"], xlab="prey1", ylab = "pred1", type = "l", lwd = 2) plot(out[,"prey2"], out[,"pred2"], xlab = "prey2", ylab = "pred2", type = "l",lwd = 2) ## restore graphics parameters par ("mfrow" = pm) ## Plot all in one figure, using matplot matplot.0D(out, lwd = 2) ## Split y-variables in two groups matplot.0D(out, which = list(c(1,3), c(2,4)), lty = c(1,2,1,2), col=c(4,4,5,5), ylab = c("prey1,pred1", "prey2,pred2")) ## ======================================================================= ## Example 2. Add second and third output, and observations ## ======================================================================= # New runs with different parameter settings parms2 <- parms parms2$r[1] <- 0.2 out2 <- ode(y, times, LVmatrix, parms2) # New runs with different parameter settings parms3 <- parms parms3$r[1] <- 0.05 out3 <- ode(y, times, LVmatrix, parms3) # plot all three outputs plot(out, out2, out3, type = "l", ylab = c("Prey 1", "Prey 2", "Pred 1", "Pred 2"), xlab = "Time (d)", main = c("Prey 1", "Prey 2", "Pred 1", "Pred 2"), col = c("red", "blue", "darkred")) ## 'observed' data obs <- as.data.frame(out[out[,1] \%in\% seq(10, 500, by = 30), ]) plot(out, which = "prey1", type = "l", obs = obs, obspar = list(pch = 18, cex = 2)) plot(out, type = "l", obs = obs, col = "red") matplot.0D(out, which = c("prey1", "pred1"), type = "l", obs = obs) ## second set of 'observed' data and two outputs obs2 <- as.data.frame(out2[out2[,1] \%in\% seq(10, 500, by = 50), ]) ## manual xlim, log plot(out, out2, type = "l", obs = list(obs, obs2), col = c("red", "blue"), obspar = list(pch = 18:19, cex = 2, col = c("red", "blue")), log = c("y", ""), which = c("prey1", "prey1"), xlim = list(c(100, 500), c(0, 400))) ## data in 'long' format OBS <- data.frame(name = c(rep("prey1", 3), rep("prey2", 2)), time = c(10, 100, 250, 10, 400), value = c(0.05, 0.04, 0.7, 0.5, 1)) OBS plot(out, obs = OBS, obspar = c(pch = 18, cex = 2)) # a subset only: plot(out, subset = prey1 < 0.5, type = "p") # Simple histogram hist(out, col = "darkblue", breaks = 50) hist(out, col = "darkblue", breaks = 50, subset = prey1<1 & prey2 < 1) # different parameters per plot hist(out, col = c("darkblue", "red", "orange", "black"), breaks = c(10,50)) ## ======================================================================= ## The Aphid model from Soetaert and Herman, 2009. ## A practical guide to ecological modelling. ## Using R as a simulation platform. Springer. ## ======================================================================= ## 1-D diffusion model ## ================ ## Model equations ## ================ Aphid <- function(t, APHIDS, parameters) { deltax <- c (0.5*delx, rep(delx, numboxes - 1), 0.5*delx) Flux <- -D * diff(c(0, APHIDS, 0))/deltax dAPHIDS <- -diff(Flux)/delx + APHIDS * r list(dAPHIDS, Flux = Flux) } ## ================== ## Model application ## ================== ## the model parameters: D <- 0.3 # m2/day diffusion rate r <- 0.01 # /day net growth rate delx <- 1 # m thickness of boxes numboxes <- 60 ## distance of boxes on plant, m, 1 m intervals Distance <- seq(from = 0.5, by = delx, length.out = numboxes) ## Initial conditions, ind/m2 ## aphids present only on two central boxes APHIDS <- rep(0, times = numboxes) APHIDS[30:31] <- 1 state <- c(APHIDS = APHIDS) # initialise state variables ## RUNNING the model: times <- seq(0, 200, by = 1) # output wanted at these time intervals out <- ode.1D(state, times, Aphid, parms = 0, nspec = 1, names = "Aphid") image(out, grid = Distance, main = "Aphid model", ylab = "distance, m", legend = TRUE) ## restricting time image(out, grid = Distance, main = "Aphid model", ylab = "distance, m", legend = TRUE, subset = time < 100) image(out, grid = Distance, main = "Aphid model", ylab = "distance, m", method = "persp", border = NA, theta = 30) FluxAphid <- subset(out, select = "Flux", subset = time < 50) matplot.1D(out, type = "l", lwd = 2, xyswap = TRUE, lty = 1) matplot.1D(out, type = "l", lwd = 2, xyswap = TRUE, lty = 1, subset = time < 50) matplot.1D(out, type = "l", lwd = 2, xyswap = TRUE, lty = 1, subset = time \%in\% seq(0, 200, by = 10), col = "grey") \dontrun{ plot(out, ask = FALSE, mfrow = c(1, 1)) plot.1D(out, ask = FALSE, type = "l", lwd = 2, xyswap = TRUE) } ## see help file for ode.2D for images of 2D variables } \keyword{ hplot } deSolve/man/ode.1D.Rd0000644000176000001440000003144613136461014013766 0ustar ripleyusers\name{ode.1D} \alias{ode.1D} \title{Solver For Multicomponent 1-D Ordinary Differential Equations} \description{ Solves a system of ordinary differential equations resulting from 1-Dimensional partial differential equations that have been converted to ODEs by numerical differencing. } \usage{ode.1D(y, times, func, parms, nspec = NULL, dimens = NULL, method= c("lsoda", "lsode", "lsodes", "lsodar", "vode", "daspk", "euler", "rk4", "ode23", "ode45", "radau", "bdf", "adams", "impAdams", "iteration"), names = NULL, bandwidth = 1, restructure = FALSE, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system, a vector. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the model definition) at time \code{t}, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms, ...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; \code{...} (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a character string then integrator \code{lsodes} will be used. See details. } \item{parms }{parameters passed to \code{func}.} \item{nspec }{the number of \bold{species} (components) in the model. If \code{NULL}, then \code{dimens} should be specified. } \item{dimens}{the number of \bold{boxes} in the model. If \code{NULL}, then \code{nspec} should be specified. } \item{method }{the integrator. Use \code{"vode", "lsode", "lsoda", "lsodar", "daspk"}, or \code{"lsodes"} if the model is very stiff; \code{"impAdams"} or \code{"radau"} may be best suited for mildly stiff problems; \code{"euler", "rk4", "ode23", "ode45", "adams"} are most efficient for non-stiff problems. Also allowed is to pass an integrator \code{function}. Use one of the other Runge-Kutta methods via \code{rkMethod}. For instance, \code{method = rkMethod("ode45ck")} will trigger the Cash-Karp method of order 4(5). Method \code{"iteration"} is special in that here the function \code{func} should return the new value of the state variables rather than the rate of change. This can be used for individual based models, for difference equations, or in those cases where the integration is performed within \code{func}) } \item{names }{the names of the components; used for plotting. } \item{bandwidth }{the number of adjacent boxes over which transport occurs. Normally equal to 1 (box i only interacts with box i-1, and i+1). Values larger than 1 will not work with \code{method = "lsodes"}. Ignored if the method is explicit. } \item{restructure }{whether or not the Jacobian should be restructured. Only used if the \code{method} is an integrator function. Should be \code{TRUE} if the method is implicit, \code{FALSE} if explicit. } \item{... }{additional arguments passed to the integrator.} } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in times and as many columns as elements in \code{y} plus the number of "global" values returned in the second element of the return from \code{func}, plus an additional column (the first) for the time value. There will be one row for each element in \code{times} unless the integrator returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. The output will have the attributes \code{istate}, and \code{rstate}, two vectors with several useful elements. The first element of istate returns the conditions under which the last call to the integrator returned. Normal is \code{istate = 2}. If \code{verbose = TRUE}, the settings of istate and rstate will be written to the screen. See the help for the selected integrator for details. } \note{ It is advisable though not mandatory to specify \bold{both} \code{nspec} and \code{dimens}. In this case, the solver can check whether the input makes sense (i.e. if \code{nspec * dimens == length(y)}). } \author{Karline Soetaert } \examples{ ## ======================================================================= ## example 1 ## a predator and its prey diffusing on a flat surface ## in concentric circles ## 1-D model with using cylindrical coordinates ## Lotka-Volterra type biology ## ======================================================================= ## ================ ## Model equations ## ================ lvmod <- function (time, state, parms, N, rr, ri, dr, dri) { with (as.list(parms), { PREY <- state[1:N] PRED <- state[(N+1):(2*N)] ## Fluxes due to diffusion ## at internal and external boundaries: zero gradient FluxPrey <- -Da * diff(c(PREY[1], PREY, PREY[N]))/dri FluxPred <- -Da * diff(c(PRED[1], PRED, PRED[N]))/dri ## Biology: Lotka-Volterra model Ingestion <- rIng * PREY * PRED GrowthPrey <- rGrow * PREY * (1-PREY/cap) MortPredator <- rMort * PRED ## Rate of change = Flux gradient + Biology dPREY <- -diff(ri * FluxPrey)/rr/dr + GrowthPrey - Ingestion dPRED <- -diff(ri * FluxPred)/rr/dr + Ingestion * assEff - MortPredator return (list(c(dPREY, dPRED))) }) } ## ================== ## Model application ## ================== ## model parameters: R <- 20 # total radius of surface, m N <- 100 # 100 concentric circles dr <- R/N # thickness of each layer r <- seq(dr/2,by = dr,len = N) # distance of center to mid-layer ri <- seq(0,by = dr,len = N+1) # distance to layer interface dri <- dr # dispersion distances parms <- c(Da = 0.05, # m2/d, dispersion coefficient rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of pred assEff = 0.5, # -, assimilation efficiency cap = 10) # density, carrying capacity ## Initial conditions: both present in central circle (box 1) only state <- rep(0, 2 * N) state[1] <- state[N + 1] <- 10 ## RUNNING the model: times <- seq(0, 200, by = 1) # output wanted at these time intervals ## the model is solved by the two implemented methods: ## 1. Default: banded reformulation print(system.time( out <- ode.1D(y = state, times = times, func = lvmod, parms = parms, nspec = 2, names = c("PREY", "PRED"), N = N, rr = r, ri = ri, dr = dr, dri = dri) )) ## 2. Using sparse method print(system.time( out2 <- ode.1D(y = state, times = times, func = lvmod, parms = parms, nspec = 2, names = c("PREY","PRED"), N = N, rr = r, ri = ri, dr = dr, dri = dri, method = "lsodes") )) ## ================ ## Plotting output ## ================ # the data in 'out' consist of: 1st col times, 2-N+1: the prey # N+2:2*N+1: predators PREY <- out[, 2:(N + 1)] filled.contour(x = times, y = r, PREY, color = topo.colors, xlab = "time, days", ylab = "Distance, m", main = "Prey density") # similar: image(out, which = "PREY", grid = r, xlab = "time, days", legend = TRUE, ylab = "Distance, m", main = "Prey density") image(out2, grid = r) # summaries of 1-D variables summary(out) # 1-D plots: matplot.1D(out, type = "l", subset = time == 10) matplot.1D(out, type = "l", subset = time > 10 & time < 20) ## ======================================================================= ## Example 2. ## Biochemical Oxygen Demand (BOD) and oxygen (O2) dynamics ## in a river ## ======================================================================= ## ================ ## Model equations ## ================ O2BOD <- function(t, state, pars) { BOD <- state[1:N] O2 <- state[(N+1):(2*N)] ## BOD dynamics FluxBOD <- v * c(BOD_0, BOD) # fluxes due to water transport FluxO2 <- v * c(O2_0, O2) BODrate <- r * BOD # 1-st order consumption ## rate of change = flux gradient - consumption + reaeration (O2) dBOD <- -diff(FluxBOD)/dx - BODrate dO2 <- -diff(FluxO2)/dx - BODrate + p * (O2sat-O2) return(list(c(dBOD = dBOD, dO2 = dO2))) } ## ================== ## Model application ## ================== ## parameters dx <- 25 # grid size of 25 meters v <- 1e3 # velocity, m/day x <- seq(dx/2, 5000, by = dx) # m, distance from river N <- length(x) r <- 0.05 # /day, first-order decay of BOD p <- 0.5 # /day, air-sea exchange rate O2sat <- 300 # mmol/m3 saturated oxygen conc O2_0 <- 200 # mmol/m3 riverine oxygen conc BOD_0 <- 1000 # mmol/m3 riverine BOD concentration ## initial conditions: state <- c(rep(200, N), rep(200, N)) times <- seq(0, 20, by = 0.1) ## running the model ## step 1 : model spinup out <- ode.1D(y = state, times, O2BOD, parms = NULL, nspec = 2, names = c("BOD", "O2")) ## ================ ## Plotting output ## ================ ## select oxygen (first column of out:time, then BOD, then O2 O2 <- out[, (N + 2):(2 * N + 1)] color = topo.colors filled.contour(x = times, y = x, O2, color = color, nlevels = 50, xlab = "time, days", ylab = "Distance from river, m", main = "Oxygen") ## or quicker plotting: image(out, grid = x, xlab = "time, days", ylab = "Distance from river, m") } \details{ This is the method of choice for multi-species 1-dimensional models, that are only subjected to transport between adjacent layers. More specifically, this method is to be used if the state variables are arranged per species: A[1], A[2], A[3],.... B[1], B[2], B[3],.... (for species A, B)) Two methods are implemented. \itemize{ \item The default method rearranges the state variables as A[1], B[1], ... A[2], B[2], ... A[3], B[3], .... This reformulation leads to a banded Jacobian with (upper and lower) half bandwidth = number of species. Then the selected integrator solves the banded problem. \item The second method uses \code{lsodes}. Based on the dimension of the problem, the method first calculates the sparsity pattern of the Jacobian, under the assumption that transport is only occurring between adjacent layers. Then \code{lsodes} is called to solve the problem. As \code{lsodes} is used to integrate, it may be necessary to specify the length of the real work array, \code{lrw}. Although a reasonable guess of \code{lrw} is made, it is possible that this will be too low. In this case, \code{ode.1D} will return with an error message telling the size of the work array actually needed. In the second try then, set \code{lrw} equal to this number. For instance, if you get the error: \preformatted{ DLSODES- RWORK length is insufficient to proceed. Length needed is .ge. LENRW (=I1), exceeds LRW (=I2) In above message, I1 = 27627 I2 = 25932 } set \code{lrw} equal to 27627 or a higher value } If the model is specified in compiled code (in a DLL), then option 2, based on \code{lsodes} is the only solution method. For single-species 1-D models, you may also use \code{\link{ode.band}}. See the selected integrator for the additional options. } \seealso{ \itemize{ \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for integrating models with a banded Jacobian \item \code{\link{ode.2D}} for integrating 2-D models \item \code{\link{ode.3D}} for integrating 3-D models \item \code{\link{lsodes}},\code{\link{lsode}}, \code{\link{lsoda}}, \code{\link{lsodar}},\code{\link{vode}} for the integration options. } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/deSolve-internal.Rd0000644000176000001440000000313613136461014016162 0ustar ripleyusers\name{deSolve-internal} \alias{timestep} \title{Internal deSolve Functions} \description{ Internal deSolve functions, these are not to be called by the user. } \usage{ timestep(prev = TRUE) } \arguments{ \item{prev }{if \code{TRUE} will return the timestep previously used; when \code{FALSE} will return the time step to be currently tried by the integrator. } } \details{ Function \code{timestep} is intended to return the current or next timestep of the integration. It works only under specific circumstances and should not be used by the end user. Instead of this, please see the example below for a pure \R solution. } \seealso{ \code{\link{diagnostics}} for information about the time steps used,\cr \code{\link{lagvalue}} and \code{\link{lagderiv}} that can be used for DDEs. } \examples{ ################################################### ### This example shows how to retrieve information ### about the used time steps. ################################################### ## a function closure ('lexical scoping') modelClosure <- function(t0) { t.old <- t.act <- t0 function(t, y, parms) { t.old <<- t.act t.act <<- t cat(t, "\t", t - t.old, "\n") with (as.list(c(y, parms)), { dP <- a * P - b * P * K dK <- b * P * K - c * K list(c(dP, dK)) }) } } model <- modelClosure(0) # initialization parms <- c(a = 0.1, b = 0.1, c = 0.1) y <- c(P = 1, K = 2) out <- ode(y = y, func = model, times = c(0, 2), parms = parms, method = "lsoda") ls() # prove that t.old and t.new are local within 'model' } \keyword{ internal }deSolve/man/dede.Rd0000644000176000001440000002003013136461014013640 0ustar ripleyusers\name{dede} \alias{dede} \title{ General Solver for Delay Differential Equations. } \description{ Function \code{dede} is a general solver for delay differential equations, i.e. equations where the derivative depends on past values of the state variables or their derivatives. } \usage{ dede(y, times, func=NULL, parms, method = c( "lsoda", "lsode", "lsodes", "lsodar", "vode", "daspk", "bdf", "adams", "impAdams", "radau"), control = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the DE system, a vector. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time. } \item{func }{an \R-function that computes the values of the derivatives in the ODE system (the model definition) at time \eqn{t}. \code{func} must be defined as: \code{func <- function(t, y, parms, ...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the DE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; \code{...} (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}.The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If method "daspk" is used, then \code{func} can be \code{NULL}, in which case \code{res} should be used. } \item{parms }{parameters passed to \code{func}. } \item{method }{the integrator to use, either a string (\code{"lsoda"}, \code{"lsode"}, \code{"lsodes"}, \code{"lsodar"}, \code{"vode"}, \code{"daspk"}, \code{"bdf"}, \code{"adams"}, \code{"impAdams"}, \code{"radau"}) or a function that performs the integration. The default integrator used is \link{lsoda}. } \item{control }{a list that can supply (1) the size of the history array, as \code{control$mxhist}; the default is 1e4 and (2) how to interpolate, as \code{control$interpol}, where \code{1} is hermitian interpolation, \code{2} is variable order interpolation, using the Nordsieck history array. Only for the two Adams methods is the second option recommended. } \item{... }{additional arguments passed to the integrator. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the second element of the return from \code{func}, plus an additional column (the first) for the time value. There will be one row for each element in \code{times} unless the integrator returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{Karline Soetaert } \details{ Functions \link{lagvalue} and \link{lagderiv} are to be used with \code{dede} as they provide access to past (lagged) values of state variables and derivatives. The number of past values that are to be stored in a history matrix, can be specified in \code{control$mxhist}. The default value (if unspecified) is 1e4. Cubic Hermite interpolation is used by default to obtain an accurate interpolant at the requested lagged time. For methods \code{adams, impAdams}, a more accurate interpolation method can be triggered by setting \code{control$interpol = 2}. \code{dede} does not deal explicitly with propagated derivative discontinuities, but relies on the integrator to control the stepsize in the region of a discontinuity. \code{dede} does not include methods to deal with delays that are smaller than the stepsize, although in some cases it may be possible to solve such models. For these reasons, it can only solve rather simple delay differential equations. When used together with integrator \code{lsodar}, or \code{lsode}, \code{dde} can simultaneously locate a root, and trigger an event. See last example. } \seealso{ \link{lagvalue}, \link{lagderiv},for how to specify lagged variables and derivatives. } \examples{ ## ============================================================================= ## A simple delay differential equation ## dy(t) = -y(t-1) ; y(t<0)=1 ## ============================================================================= ##----------------------------- ## the derivative function ##----------------------------- derivs <- function(t, y, parms) { if (t < 1) dy <- -1 else dy <- - lagvalue(t - 1) list(c(dy)) } ##----------------------------- ## initial values and times ##----------------------------- yinit <- 1 times <- seq(0, 30, 0.1) ##----------------------------- ## solve the model ##----------------------------- yout <- dede(y = yinit, times = times, func = derivs, parms = NULL) ##----------------------------- ## display, plot results ##----------------------------- plot(yout, type = "l", lwd = 2, main = "dy/dt = -y(t-1)") ## ============================================================================= ## The infectuous disease model of Hairer; two lags. ## example 4 from Shampine and Thompson, 2000 ## solving delay differential equations with dde23 ## ============================================================================= ##----------------------------- ## the derivative function ##----------------------------- derivs <- function(t,y,parms) { if (t < 1) lag1 <- 0.1 else lag1 <- lagvalue(t - 1,2) if (t < 10) lag10 <- 0.1 else lag10 <- lagvalue(t - 10,2) dy1 <- -y[1] * lag1 + lag10 dy2 <- y[1] * lag1 - y[2] dy3 <- y[2] - lag10 list(c(dy1, dy2, dy3)) } ##----------------------------- ## initial values and times ##----------------------------- yinit <- c(5, 0.1, 1) times <- seq(0, 40, by = 0.1) ##----------------------------- ## solve the model ##----------------------------- system.time( yout <- dede(y = yinit, times = times, func = derivs, parms = NULL) ) ##----------------------------- ## display, plot results ##----------------------------- matplot(yout[,1], yout[,-1], type = "l", lwd = 2, lty = 1, main = "Infectuous disease - Hairer") ## ============================================================================= ## time lags + EVENTS triggered by a root function ## The two-wheeled suitcase model ## example 8 from Shampine and Thompson, 2000 ## solving delay differential equations with dde23 ## ============================================================================= ##----------------------------- ## the derivative function ##----------------------------- derivs <- function(t, y, parms) { if (t < tau) lag <- 0 else lag <- lagvalue(t - tau) dy1 <- y[2] dy2 <- -sign(y[1]) * gam * cos(y[1]) + sin(y[1]) - bet * lag[1] + A * sin(omega * t + mu) list(c(dy1, dy2)) } ## root and event function root <- function(t,y,parms) ifelse(t>0, return(y), return(1)) event <- function(t,y,parms) return(c(y[1], y[2]*0.931)) gam = 0.248; bet = 1; tau = 0.1; A = 0.75 omega = 1.37; mu = asin(gam/A) ##----------------------------- ## initial values and times ##----------------------------- yinit <- c(y = 0, dy = 0) times <- seq(0, 12, len = 1000) ##----------------------------- ## solve the model ##----------------------------- ## Note: use a solver that supports both root finding and events, ## e.g. lsodar, lsode, lsoda, adams, bdf yout <- dede(y = yinit, times = times, func = derivs, parms = NULL, method = "lsodar", rootfun = root, events = list(func = event, root = TRUE)) ##----------------------------- ## display, plot results ##----------------------------- plot(yout, which = 1, type = "l", lwd = 2, main = "suitcase model", mfrow = c(1,2)) plot(yout[,2], yout[,3], xlab = "y", ylab = "dy", type = "l", lwd = 2) } \keyword{utilities} deSolve/man/ode.band.Rd0000644000176000001440000001505013274242145014424 0ustar ripleyusers\name{ode.band} \alias{ode.band} \title{Solver for Ordinary Differential Equations; Assumes a Banded Jacobian } \description{ Solves a system of ordinary differential equations. Assumes a banded Jacobian matrix, but does not rearrange the state variables (in contrast to ode.1D). Suitable for 1-D models that include transport only between adjacent layers and that model only one species. } \usage{ode.band(y, times, func, parms, nspec = NULL, dimens = NULL, bandup = nspec, banddown = nspec, method = "lsode", names = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system, a vector. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the model definition) at time \code{t}, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms, ...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; \code{...} (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}.The derivatives must be specified in the \bold{same order} as the state variables \code{y}. } \item{parms }{parameters passed to \code{func}. } \item{nspec }{the number of *species* (components) in the model. } \item{dimens}{the number of \bold{boxes} in the model. If \code{NULL}, then \code{nspec} should be specified. } \item{bandup }{the number of nonzero bands above the Jacobian diagonal. } \item{banddown }{the number of nonzero bands below the Jacobian diagonal. } \item{method }{the integrator to use, one of \code{"vode"}, \code{"lsode"}, \code{"lsoda"}, \code{"lsodar"}, \code{"radau"}. } \item{names }{the names of the components; used for plotting. } \item{... }{additional arguments passed to the integrator.} } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the second element of the return from \code{func}, plus an additional column (the first) for the time value. There will be one row for each element in \code{times} unless the integrator returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. The output will have the attributes \code{istate} and \code{rstate}, two vectors with several elements. See the help for the selected integrator for details. the first element of istate returns the conditions under which the last call to the integrator returned. Normal is \code{istate = 2}. If \code{verbose = TRUE}, the settings of \code{istate} and \code{rstate} will be written to the screen. } \author{Karline Soetaert } \examples{ ## ======================================================================= ## The Aphid model from Soetaert and Herman, 2009. ## A practical guide to ecological modelling. ## Using R as a simulation platform. Springer. ## ======================================================================= ## 1-D diffusion model ## ================ ## Model equations ## ================ Aphid <- function(t, APHIDS, parameters) { deltax <- c (0.5*delx, rep(delx, numboxes-1), 0.5*delx) Flux <- -D*diff(c(0, APHIDS, 0))/deltax dAPHIDS <- -diff(Flux)/delx + APHIDS*r list(dAPHIDS) # the output } ## ================== ## Model application ## ================== ## the model parameters: D <- 0.3 # m2/day diffusion rate r <- 0.01 # /day net growth rate delx <- 1 # m thickness of boxes numboxes <- 60 ## distance of boxes on plant, m, 1 m intervals Distance <- seq(from = 0.5, by = delx, length.out = numboxes) ## Initial conditions, ind/m2 ## aphids present only on two central boxes APHIDS <- rep(0, times = numboxes) APHIDS[30:31] <- 1 state <- c(APHIDS = APHIDS) # initialise state variables ## RUNNING the model: times <- seq(0, 200, by = 1) # output wanted at these time intervals out <- ode.band(state, times, Aphid, parms = 0, nspec = 1, names = "Aphid") ## ================ ## Plotting output ## ================ image(out, grid = Distance, method = "filled.contour", xlab = "time, days", ylab = "Distance on plant, m", main = "Aphid density on a row of plants") matplot.1D(out, grid = Distance, type = "l", subset = time \%in\% seq(0, 200, by = 10)) # add an observed dataset to 1-D plot (make sure to use correct name): data <- cbind(dist = c(0,10, 20, 30, 40, 50, 60), Aphid = c(0,0.1,0.25,0.5,0.25,0.1,0)) matplot.1D(out, grid = Distance, type = "l", subset = time \%in\% seq(0, 200, by = 10), obs = data, obspar = list(pch = 18, cex = 2, col="red")) \dontrun{ plot.1D(out, grid = Distance, type = "l") } } \details{ This is the method of choice for single-species 1-D reactive transport models. For multi-species 1-D models, this method can only be used if the state variables are arranged per box, per species (e.g. A[1], B[1], A[2], B[2], A[3], B[3], ... for species A, B). By default, the \bold{model} function will have the species arranged as A[1], A[2], A[3], ... B[1], B[2], B[3], ... in this case, use \code{ode.1D}. See the selected integrator for the additional options. } \seealso{ \itemize{ \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.1D}} for integrating 1-D models \item \code{\link{ode.2D}} for integrating 2-D models \item \code{\link{ode.3D}} for integrating 3-D models \item \code{\link{lsode}}, \code{\link{lsoda}}, \code{\link{lsodar}}, \code{\link{vode}} for the integration options. } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/radau.Rd0000644000176000001440000004557313136461014014056 0ustar ripleyusers\name{radau} \alias{radau} \title{Implicit Runge-Kutta RADAU IIA} \description{ Solves the initial value problem for stiff or nonstiff systems of ordinary differential equations (ODE) in the form: \deqn{dy/dt = f(t,y)} or linearly implicit differential algebraic equations in the form: \deqn{M dy/dt = f(t,y)}. The \R function \code{radau} provides an interface to the Fortran solver RADAU5, written by Ernst Hairer and G. Wanner, which implements the 3-stage RADAU IIA method. It implements the implicit Runge-Kutta method of order 5 with step size control and continuous output. The system of ODEs or DAEs is written as an \R function or can be defined in compiled code that has been dynamically loaded. } \usage{ radau(y, times, func, parms, nind = c(length(y), 0, 0), rtol = 1e-6, atol = 1e-6, jacfunc = NULL, jactype = "fullint", mass = NULL, massup = NULL, massdown = NULL, rootfunc = NULL, verbose = FALSE, nroot = 0, hmax = NULL, hini = 0, ynames = TRUE, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, events=NULL, lags = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time; if only one step is to be taken; set \code{times} = \code{NULL}. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time t, or the right-hand side of the equation \deqn{M dy/dt = f(t,y)} if a DAE. (if \code{mass} is supplied then the problem is assumed a DAE). \code{func} can also be a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{radau()} is called. See deSolve package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func} or \code{jacfunc}. } \item{nind }{if a DAE system: a three-valued vector with the number of variables of index 1, 2, 3 respectively. The equations must be defined such that the index 1 variables precede the index 2 variables which in turn precede the index 3 variables. The sum of the variables of different index should equal N, the total number of variables. This has implications on the scaling of the variables, i.e. index 2 variables are scaled by 1/h, index 3 variables are scaled by 1/h^2. } \item{rtol }{relative error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{atol }{absolute error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{jacfunc }{if not \code{NULL}, an \R function that computes the Jacobian of the system of differential equations \eqn{\partial\dot{y}_i/\partial y_j}{dydot(i)/dy(j)}, or a string giving the name of a function or subroutine in \file{dllname} that computes the Jacobian (see vignette \code{"compiledCode"} from package deSolve, for more about this option). In some circumstances, supplying \code{jacfunc} can speed up the computations, if the system is stiff. The \R calling sequence for \code{jacfunc} is identical to that of \code{func}. If the Jacobian is a full matrix, \code{jacfunc} should return a matrix \eqn{\partial\dot{y}/\partial y}{dydot/dy}, where the ith row contains the derivative of \eqn{dy_i/dt} with respect to \eqn{y_j}, or a vector containing the matrix elements by columns (the way \R and FORTRAN store matrices). \cr If the Jacobian is banded, \code{jacfunc} should return a matrix containing only the nonzero bands of the Jacobian, rotated row-wise. See example. } \item{jactype }{the structure of the Jacobian, one of \code{"fullint"}, \code{"fullusr"}, \code{"bandusr"} or \code{"bandint"} - either full or banded and estimated internally or by user. } \item{mass }{the mass matrix. If not \code{NULL}, the problem is a linearly implicit DAE and defined as \eqn{M\, dy/dt = f(t,y)}{M dy/dt = f(t,y)}. If the mass-matrix \eqn{M} is full, it should be of dimension \eqn{n^2}{n*n} where \eqn{n} is the number of \eqn{y}-values; if banded the number of rows should be less than \eqn{n}, and the mass-matrix is stored diagonal-wise with element \eqn{(i, j)} stored in \code{mass(i - j + mumas + 1, j)}. If \code{mass = NULL} then the model is an ODE (default) } \item{massup }{number of non-zero bands above the diagonal of the \code{mass} matrix, in case it is banded. } \item{massdown }{number of non-zero bands below the diagonal of the \code{mass} matrix, in case it is banded. } \item{rootfunc }{if not \code{NULL}, an \R function that computes the function whose root has to be estimated or a string giving the name of a function or subroutine in \file{dllname} that computes the root function. The \R calling sequence for \code{rootfunc} is identical to that of \code{func}. \code{rootfunc} should return a vector with the function values whose root is sought. } \item{verbose }{if \code{TRUE}: full output to the screen, e.g. will print the \code{diagnostiscs} of the integration - see details. } \item{nroot }{only used if \file{dllname} is specified: the number of constraint functions whose roots are desired during the integration; if \code{rootfunc} is an R-function, the solver estimates the number of roots. } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, \code{hmax} is set to the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. } \item{hini }{initial step size to be attempted; if 0, the initial step size is set equal to 1e-6. Usually 1e-3 to 1e-5 is good for stiff equations } \item{ynames }{logical, if \code{FALSE} names of state variables are not passed to function \code{func}; this may speed up the simulation especially for multi-D models. } \item{bandup }{number of non-zero bands above the diagonal, in case the Jacobian is banded. } \item{banddown }{number of non-zero bands below the diagonal, in case the Jacobian is banded. } \item{maxsteps }{average maximal number of steps per output interval taken by the solver. This argument is defined such as to ensure compatibility with the Livermore-solvers. RADAU only accepts the maximal number of steps for the entire integration, and this is calculated as \code{length(times) * maxsteps}. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func} and \code{jacfunc}. See vignette \code{"compiledCode"} from package \code{deSolve}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See vignette \code{"compiledCode"} from package \code{deSolve}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculed in the DLL - you have to perform this check in the code - See vignette \code{"compiledCode"} from package \code{deSolve}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. These names will be used to label the output matrix. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time, value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See \link{forcings} or vignette \code{compiledCode}. } \item{events }{A matrix or data frame that specifies events, i.e. when the value of a state variable is suddenly changed. See \link{events} for more information. } \item{lags }{A list that specifies timelags, i.e. the number of steps that has to be kept. To be used for delay differential equations. See \link{timelags}, \link{dede} for more information. } \item{... }{additional arguments passed to \code{func} and \code{jacfunc} allowing this to be a generic function. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the FORTRAN routine returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{Karline Soetaert } \examples{ ## ======================================================================= ## Example 1: ODE ## Various ways to solve the same model. ## ======================================================================= ## the model, 5 state variables f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } ## the Jacobian, written as a full matrix fulljac <- function (t, y, parms) { jac <- matrix(nrow = 5, ncol = 5, byrow = TRUE, data = c(0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1)) return(jac) } ## the Jacobian, written in banded form bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } ## initial conditions and output times yini <- 1:5 times <- 1:20 ## default: stiff method, internally generated, full Jacobian out <- radau(yini, times, f1, parms = 0) plot(out) ## stiff method, user-generated full Jacobian out2 <- radau(yini, times, f1, parms = 0, jactype = "fullusr", jacfunc = fulljac) ## stiff method, internally-generated banded Jacobian ## one nonzero band above (up) and below(down) the diagonal out3 <- radau(yini, times, f1, parms = 0, jactype = "bandint", bandup = 1, banddown = 1) ## stiff method, user-generated banded Jacobian out4 <- radau(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) ## ======================================================================= ## Example 2: ODE ## stiff problem from chemical kinetics ## ======================================================================= Chemistry <- function (t, y, p) { dy1 <- -.04*y[1] + 1.e4*y[2]*y[3] dy2 <- .04*y[1] - 1.e4*y[2]*y[3] - 3.e7*y[2]^2 dy3 <- 3.e7*y[2]^2 list(c(dy1, dy2, dy3)) } times <- 10^(seq(0, 10, by = 0.1)) yini <- c(y1 = 1.0, y2 = 0, y3 = 0) out <- radau(func = Chemistry, times = times, y = yini, parms = NULL) plot(out, log = "x", type = "l", lwd = 2) ## ============================================================================= ## Example 3: DAE ## Car axis problem, index 3 DAE, 8 differential, 2 algebraic equations ## from ## F. Mazzia and C. Magherini. Test Set for Initial Value Problem Solvers, ## release 2.4. Department ## of Mathematics, University of Bari and INdAM, Research Unit of Bari, ## February 2008. ## Available at http://www.dm.uniba.it/~testset. ## ============================================================================= ## Problem is written as M*y' = f(t,y,p). ## caraxisfun implements the right-hand side: caraxisfun <- function(t, y, parms) { with(as.list(y), { yb <- r * sin(w * t) xb <- sqrt(L * L - yb * yb) Ll <- sqrt(xl^2 + yl^2) Lr <- sqrt((xr - xb)^2 + (yr - yb)^2) dxl <- ul; dyl <- vl; dxr <- ur; dyr <- vr dul <- (L0-Ll) * xl/Ll + 2 * lam2 * (xl-xr) + lam1*xb dvl <- (L0-Ll) * yl/Ll + 2 * lam2 * (yl-yr) + lam1*yb - k * g dur <- (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr) dvr <- (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k * g c1 <- xb * xl + yb * yl c2 <- (xl - xr)^2 + (yl - yr)^2 - L * L list(c(dxl, dyl, dxr, dyr, dul, dvl, dur, dvr, c1, c2)) }) } eps <- 0.01; M <- 10; k <- M * eps^2/2; L <- 1; L0 <- 0.5; r <- 0.1; w <- 10; g <- 1 yini <- c(xl = 0, yl = L0, xr = L, yr = L0, ul = -L0/L, vl = 0, ur = -L0/L, vr = 0, lam1 = 0, lam2 = 0) # the mass matrix Mass <- diag(nrow = 10, 1) Mass[5,5] <- Mass[6,6] <- Mass[7,7] <- Mass[8,8] <- M * eps * eps/2 Mass[9,9] <- Mass[10,10] <- 0 Mass # index of the variables: 4 of index 1, 4 of index 2, 2 of index 3 index <- c(4, 4, 2) times <- seq(0, 3, by = 0.01) out <- radau(y = yini, mass = Mass, times = times, func = caraxisfun, parms = NULL, nind = index) plot(out, which = 1:4, type = "l", lwd = 2) } \references{ E. Hairer and G. Wanner, 1996. Solving Ordinary Differential Equations II. Stiff and Differential-algebraic problems. Springer series in computational mathematics 14, Springer-Verlag, second edition. } \details{ The work is done by the FORTRAN subroutine \code{RADAU5}, whose documentation should be consulted for details. The implementation is based on the Fortran 77 version from January 18, 2002. There are four standard choices for the Jacobian which can be specified with \code{jactype}. The options for \bold{jactype} are \describe{ \item{jactype = "fullint"}{a full Jacobian, calculated internally by the solver. } \item{jactype = "fullusr"}{a full Jacobian, specified by user function \code{jacfunc}. } \item{jactype = "bandusr"}{a banded Jacobian, specified by user function \code{jacfunc}; the size of the bands specified by \code{bandup} and \code{banddown}. } \item{jactype = "bandint"}{a banded Jacobian, calculated by radau; the size of the bands specified by \code{bandup} and \code{banddown}. } } Inspection of the example below shows how to specify both a banded and full Jacobian. The input parameters \code{rtol}, and \code{atol} determine the \bold{error control} performed by the solver, which roughly keeps the local error of \eqn{y(i)} below \eqn{rtol(i)*abs(y(i))+atol(i)}. The diagnostics of the integration can be printed to screen by calling \code{\link{diagnostics}}. If \code{verbose} = \code{TRUE}, the diagnostics will be written to the screen at the end of the integration. See vignette("deSolve") from the \code{deSolve} package for an explanation of each element in the vectors containing the diagnostic properties and how to directly access them. \bold{Models} may be defined in compiled C or FORTRAN code, as well as in an R-function. See package vignette \code{"compiledCode"} from package \code{deSolve} for details. Information about linking forcing functions to compiled code is in \link{forcings} (from package \code{deSolve}). \code{radau} can find the root of at least one of a set of constraint functions \code{rootfunc} of the independent and dependent variables. It then returns the solution at the root if that occurs sooner than the specified stop condition, and otherwise returns the solution according the specified stop condition. Caution: Because of numerical errors in the function \code{rootfun} due to roundoff and integration error, \code{radau} may return false roots, or return the same root at two or more nearly equal values of \code{time}. } \seealso{ \itemize{ \item \code{\link{ode}} for a general interface to most of the ODE solvers , \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, \item \code{\link{daspk}} for integrating DAE models up to index 1 } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/rk4.Rd0000644000176000001440000002335713136461014013456 0ustar ripleyusers\name{rk4} \alias{rk4} \alias{euler} \alias{euler.1D} \title{Solve System of ODE (Ordinary Differential Equation)s by Euler's Method or Classical Runge-Kutta 4th Order Integration. } \description{Solving initial value problems for systems of first-order ordinary differential equations (ODEs) using Euler's method or the classical Runge-Kutta 4th order integration. } \usage{ euler(y, times, func, parms, verbose = FALSE, ynames = TRUE, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, ...) rk4(y, times, func, parms, verbose = FALSE, ynames = TRUE, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, ...) euler.1D(y, times, func, parms, nspec = NULL, dimens = NULL, names = NULL, verbose = FALSE, ynames = TRUE, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{times at which explicit estimates for \code{y} are desired. The first value in \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time t, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{rk4} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func}. } \item{nspec }{for 1D models only: the number of \bold{species} (components) in the model. If \code{NULL}, then \code{dimens} should be specified. } \item{dimens}{for 1D models only: the number of \bold{boxes} in the model. If \code{NULL}, then \code{nspec} should be specified. } \item{names }{for 1D models only: the names of the components; used for plotting. } \item{verbose }{a logical value that, when \code{TRUE}, triggers more verbose output from the ODE solver. } \item{ynames }{if \code{FALSE}: names of state variables are not passed to function \code{func} ; this may speed up the simulation especially for large models. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}, } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the DLL: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the DLL-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the DLL - you have to perform this check in the code. See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time, value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See \link{forcings} or vignette \code{compiledCode}. } \item{... }{additional arguments passed to \code{func} allowing this to be a generic function. } } \author{Thomas Petzoldt \email{thomas.petzoldt@tu-dresden.de}} \details{ \code{rk4} and \code{euler} are special versions of the two fixed step solvers with less overhead and less functionality (e.g. no interpolation and no events) compared to the generic Runge-Kutta codes called by \code{\link{ode}} resp. \code{\link{rk}}. If you need different internal and external time steps or want to use events, please use: \code{rk(y, times, func, parms, method = "rk4")} or \code{rk(y, times, func, parms, method = "euler")}. See help pages of \code{\link{rk}} and \code{\link{rkMethod}} for details. Function \code{euler.1D} essentially calls function\code{euler} but contains additional code to support plotting of 1D models, see \code{\link{ode.1D}} and \code{\link{plot.1D}} for details. } \note{ For most practical cases, solvers with flexible timestep (e.g. \code{rk(method = "ode45")} and especially solvers of the Livermore family (ODEPACK, e.g. \code{\link{lsoda}}) are superior. } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the integration routine returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \examples{ ## ======================================================================= ## Example: Analytical and numerical solutions of logistic growth ## ======================================================================= ## the derivative of the logistic logist <- function(t, x, parms) { with(as.list(parms), { dx <- r * x[1] * (1 - x[1]/K) list(dx) }) } time <- 0:100 N0 <- 0.1; r <- 0.5; K <- 100 parms <- c(r = r, K = K) x <- c(N = N0) ## analytical solution plot(time, K/(1 + (K/N0-1) * exp(-r*time)), ylim = c(0, 120), type = "l", col = "red", lwd = 2) ## reasonable numerical solution with rk4 time <- seq(0, 100, 2) out <- as.data.frame(rk4(x, time, logist, parms)) points(out$time, out$N, pch = 16, col = "blue", cex = 0.5) ## same time step with euler, systematic under-estimation time <- seq(0, 100, 2) out <- as.data.frame(euler(x, time, logist, parms)) points(out$time, out$N, pch = 1) ## unstable result time <- seq(0, 100, 4) out <- as.data.frame(euler(x, time, logist, parms)) points(out$time, out$N, pch = 8, cex = 0.5) ## method with automatic time step out <- as.data.frame(lsoda(x, time, logist, parms)) points(out$time, out$N, pch = 1, col = "green") legend("bottomright", c("analytical","rk4, h=2", "euler, h=2", "euler, h=4", "lsoda"), lty = c(1, NA, NA, NA, NA), lwd = c(2, 1, 1, 1, 1), pch = c(NA, 16, 1, 8, 1), col = c("red", "blue", "black", "black", "green")) } \seealso{ \itemize{ \item \code{\link{rkMethod}} for a list of available Runge-Kutta parameter sets, \item \code{\link{rk}} for the more general Runge-Code, \item \code{\link{lsoda}}, \code{\link{lsode}}, \code{\link{lsodes}}, \code{\link{lsodar}}, \code{\link{vode}}, \code{\link{daspk}} for solvers of the Livermore family, \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, \item \code{\link{dede}} for integrating models with delay differential equations, } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/rkMethod.Rd0000644000176000001440000003025013137120052014514 0ustar ripleyusers\name{rkMethod} \alias{rkMethod} \title{Collection of Parameter Sets (Butcher Arrays) for the Runge-Kutta Family of ODE Solvers } \description{ This function returns a list specifying coefficients and properties of ODE solver methods from the Runge-Kutta family. } \usage{ rkMethod(method = NULL, ...) } \arguments{ \item{method }{a string constant naming one of the pre-defined methods of the Runge-Kutta family of solvers. The most common methods are the fixed-step methods \code{"euler"}, \code{"rk2"}, \code{"rk4"} or the variable step methods \code{"rk23bs"} (alias \code{"ode23"}), \code{"rk45dp7"} (alias \code{"ode45"}) or \code{"rk78f"}. } \item{\dots }{specification of a user-defined solver, see \emph{Value} and example below. } } \details{ This function supplies \code{method} settings for \code{\link{rk}} or \code{\link{ode}}. If called without arguments, the names of all currently implemented solvers of the Runge-Kutta family are returned. The following comparison gives an idea how the algorithms of \pkg{deSolve} are related to similar algorithms of other simulation languages: \tabular{lll}{ \bold{rkMethod} \tab | \tab \bold{Description} \cr "euler" \tab | \tab Euler's Method\cr "rk2" \tab | \tab 2nd order Runge-Kutta, fixed time step (Heun's method)\cr "rk4" \tab | \tab classical 4th order Runge-Kutta, fixed time step\cr "rk23" \tab | \tab Runge-Kutta, order 2(3); Octave: ode23\cr "rk23bs", "ode23" \tab | \tab Bogacki-Shampine, order 2(3); Matlab: ode23\cr "rk34f" \tab | \tab Runge-Kutta-Fehlberg, order 3(4)\cr "rk45ck" \tab | \tab Runge-Kutta Cash-Karp, order 4(5)\cr "rk45f" \tab | \tab Runge-Kutta-Fehlberg, order 4(5); Octave: ode45, pair=1 \cr "rk45e" \tab | \tab Runge-Kutta-England, order 4(5)\cr "rk45dp6" \tab | \tab Dormand-Prince, order 4(5), local order 6\cr "rk45dp7", "ode45" \tab | \tab Dormand-Prince 4(5), local order 7 \cr \tab | \tab (also known as dopri5; MATLAB: ode45; Octave: ode45, pair=0)\cr "rk78f" \tab | \tab Runge-Kutta-Fehlberg, order 7(8)\cr "rk78dp" \tab | \tab Dormand-Prince, order 7(8)\cr } Note that this table is based on the Runge-Kutta coefficients only, but the algorithms differ also in their implementation, in their stepsize adaption strategy and interpolation methods. The table reflects the state at time of writing and it is of course possible that implementations change. Methods \code{"rk45dp7"} (alias \code{"ode45"}) and \code{"rk45ck"} contain specific and efficient built-in interpolation schemes (dense output). As an alternative, Neville-Aitken polynomials can be used to interpolate between time steps. This is available for all RK methods and may be useful to speed up computation if no dense-output formula is available. Note however, that this can introduce considerable local error; it is disabled by default (see \code{nknots} below). } \note{ \itemize{ \item Adaptive stepsize Runge-Kuttas are preferred if the solution contains parts when the states change fast, and parts when not much happens. They will take small steps over bumpy ground and long steps over uninteresting terrain. \item As a suggestion, one may use \code{"rk23"} (alias \code{"ode23"}) for simple problems and \code{"rk45dp7"} (alias \code{"ode45"}) for rough problems. The default solver is \code{"rk45dp7"} (alias "ode45"), because of its relatively high order (4), re-use of the last intermediate steps (FSAL = first same as last) and built-in polynomial interpolation (dense output). \item Solver \code{"rk23bs"}, that supports also FSAL, may be useful for slightly stiff systems if demands on precision are relatively low. \item Another good choice, assuring medium accuracy, is the Cash-Karp Runge-Kutta method, \code{"rk45ck"}. \item Classical \code{"rk4"} is traditionally used in cases where an adequate stepsize is known a-priori or if external forcing data are provided for fixed time steps only and frequent interpolation of external data needs to be avoided. \item Method \code{"rk45dp7"} (alias \code{"ode45"}) contains an efficient built-in interpolation scheme (dense output) based on intermediate function evaluations. } Starting with version 1.8 implicit Runge-Kutta (\code{irk}) methods are also supported by the general \code{rk} interface, however their implementation is still experimental. Instead of this you may consider \code{\link{radau}} for a specific full implementation of an implicit Runge-Kutta method. } \value{ A list with the following elements: \item{ID}{name of the method (character)} \item{varstep}{boolean value specifying if the method allows for variable time step (\code{TRUE}) or not (\code{FALSE}). } \item{FSAL}{(first same as last) optional boolean value specifying if the method allows re-use of the last function evaluation (\code{TRUE}) or not (\code{FALSE} or \code{NULL}). } \item{A}{coefficient matrix of the method. As \code{link{rk}} supports only explicit methods, this matrix must be lower triangular. \code{A} must be a vector for fixed step methods where only the subdiagonal values are different from zero. } \item{b1}{coefficients of the lower order Runge-Kutta pair. } \item{b2}{coefficients of the higher order Runge-Kutta pair (optional, for embedded methods that allow variable time step). } \item{c}{coefficients for calculating the intermediate time steps.} \item{d}{optional coefficients for built-in polynomial interpolation of the outputs from internal steps (dense output), currently only available for method \code{rk45dp7} (Dormand-Prince). } \item{densetype}{optional integer value specifying the dense output formula; currently only \code{densetype = 1} for \code{rk45dp7} (Dormand-Prince) and \code{densetype = 2} for \code{rk45ck} (Cash-Karp) are supported. Undefined values (e.g., \code{densetype = NULL}) disable dense output. } \item{stage}{number of function evaluations needed (corresponds to number of rows in A). } \item{Qerr}{global error order of the method, important for automatic time-step adjustment. } \item{nknots}{integer value specifying the order of interpolation polynomials for methods without dense output. If \code{nknots} < 2 (the default) then internal interpolation is switched off and integration is performed step by step between external time steps. If \code{nknots} is between 3 and 8, Neville-Aitken polynomials are used, which need at least \code{nknots + 1} internal time steps. Interpolation may speed up integration but can lead to local errors higher than the tolerance, especially if external and internal time steps are very different. } \item{alpha}{optional tuning parameter for stepsize adjustment. If \code{alpha} is omitted, it is set to \eqn{1/Qerr - 0.75 beta}. The default value is \eqn{1/Qerr} (for \code{beta} = 0).} \item{beta}{optional tuning parameter for stepsize adjustment. Typical values are \eqn{0} (default) or \eqn{0.4/Qerr}. } } \references{ Bogacki, P. and Shampine L.F. (1989) A 3(2) pair of Runge-Kutta formulas, Appl. Math. Lett. \bold{2}, 1--9. Butcher, J. C. (1987) The numerical analysis of ordinary differential equations, Runge-Kutta and general linear methods, Wiley, Chichester and New York. Cash, J. R. and Karp A. H., 1990. A variable order Runge-Kutta method for initial value problems with rapidly varying right-hand sides, ACM Transactions on Mathematical Software \bold{16}, 201--222. Dormand, J. R. and Prince, P. J. (1980) A family of embedded Runge-Kutta formulae, J. Comput. Appl. Math. \bold{6}(1), 19--26. Engeln-Muellges, G. and Reutter, F. (1996) Numerik Algorithmen: Entscheidungshilfe zur Auswahl und Nutzung. VDI Verlag, Duesseldorf. Fehlberg, E. (1967) Klassische Runge-Kutta-Formeln fuenfter and siebenter Ordnung mit Schrittweiten-Kontrolle, Computing (Arch. Elektron. Rechnen) \bold{4}, 93--106. Kutta, W. (1901) Beitrag zur naeherungsweisen Integration totaler Differentialgleichungen, Z. Math. Phys. \bold{46}, 435--453. Octave-Forge - Extra Packages for GNU Octave, Package OdePkg. \url{http://octave.sourceforge.io} Prince, P. J. and Dormand, J. R. (1981) High order embedded Runge-Kutta formulae, J. Comput. Appl. Math. \bold{7}(1), 67--75. Runge, C. (1895) Ueber die numerische Aufloesung von Differentialgleichungen, Math. Ann. \bold{46}, 167--178. MATLAB (R) is a registed property of The Mathworks Inc. \url{http://www.mathworks.com/} } \author{Thomas Petzoldt \email{thomas.petzoldt@tu-dresden.de}} \seealso{\code{\link{rk}}, \code{\link{ode}}} \examples{ rkMethod() # returns the names of all available methods rkMethod("rk45dp7") # parameters of the Dormand-Prince 5(4) method rkMethod("ode45") # an alias for the same method func <- function(t, x, parms) { with(as.list(c(parms, x)),{ dP <- a * P - b * C * P dC <- b * P * C - c * C res <- c(dP, dC) list(res) }) } times <- seq(0, 200, length = 101) parms <- c(a = 0.1, b = 0.1, c = 0.1) x <- c(P = 2, C = 1) ## rk using ode45 as the default method out <- rk(x, times, func, parms) ## all methods can be called also from 'ode' by using rkMethod out <- ode(x, times, func, parms, method = rkMethod("rk4")) ## 'ode' has aliases for the most common RK methods out <- ode(x, times, func, parms, method = "ode45") ##=========================================================================== ## Comparison of local error from different interpolation methods ##=========================================================================== ## lsoda with lower tolerances (1e-10) used as reference o0 <- ode(x, times, func, parms, method = "lsoda", atol = 1e-10, rtol = 1e-10) ## rk45dp7 with hmax = 10 > delta_t = 2 o1 <- ode(x, times, func, parms, method = rkMethod("rk45dp7"), hmax = 10) ## disable dense-output interpolation ## and use only Neville-Aitken polynomials instead o2 <- ode(x, times, func, parms, method = rkMethod("rk45dp7", densetype = NULL, nknots = 5), hmax = 10) ## stop and go: disable interpolation completely ## and integrate explicitly between external time steps o3 <- ode(x, times, func, parms, method = rkMethod("rk45dp7", densetype = NULL, nknots = 0, hmax=10)) ## compare different interpolation methods with lsoda mf <- par("mfrow" = c(4, 1)) matplot(o1[,1], o1[,-1], type = "l", xlab = "Time", main = "State Variables", ylab = "P, C") matplot(o0[,1], o0[,-1] - o1[,-1], type = "l", xlab = "Time", ylab = "Diff.", main="Difference between lsoda and ode45 with dense output") abline(h = 0, col = "grey") matplot(o0[,1], o0[,-1] - o2[,-1], type = "l", xlab = "Time", ylab = "Diff.", main="Difference between lsoda and ode45 with Neville-Aitken") abline(h = 0, col = "grey") matplot(o0[,1], o0[,-1] - o3[,-1], type = "l", xlab = "Time", ylab = "Diff.", main="Difference between lsoda and ode45 in 'stop and go' mode") abline(h = 0, col = "grey") par(mf) ##=========================================================================== ## rkMethod allows to define user-specified Runge-Kutta methods ##=========================================================================== out <- ode(x, times, func, parms, method = rkMethod(ID = "midpoint", varstep = FALSE, A = c(0, 1/2), b1 = c(0, 1), c = c(0, 1/2), stage = 2, Qerr = 1 ) ) plot(out) ## compare method diagnostics times <- seq(0, 200, length = 10) o1 <- ode(x, times, func, parms, method = rkMethod("rk45ck")) o2 <- ode(x, times, func, parms, method = rkMethod("rk78dp")) diagnostics(o1) diagnostics(o2) } \keyword{ math } deSolve/man/ccl4model.Rd0000644000176000001440000000770613136461014014624 0ustar ripleyusers\name{ccl4model} \alias{ccl4model} \title{The CCl4 Inhalation Model} \description{The CCl4 inhalation model implemented in \code{.Fortran}} \usage{ccl4model(times, y, parms, ...)} \arguments{ \item{times }{time sequence for which the model has to be integrated.} \item{y }{the initial values for the state variables ("AI", "AAM", "AT", "AF", "AL", "CLT" and "AM"), in that order. } \item{parms }{vector or list holding the ccl4 model parameters; see the example for the order in which these have to be defined. } \item{... }{any other parameters passed to the integrator \code{ode} (which solves the model). } } \author{R. Woodrow Setzer } \examples{ ## ================= ## Parameter values ## ================= Pm <- c( ## Physiological parameters BW = 0.182, # Body weight (kg) QP = 4.0 , # Alveolar ventilation rate (hr^-1) QC = 4.0 , # Cardiac output (hr^-1) VFC = 0.08, # Fraction fat tissue (kg/(kg/BW)) VLC = 0.04, # Fraction liver tissue (kg/(kg/BW)) VMC = 0.74, # Fraction of muscle tissue (kg/(kg/BW)) QFC = 0.05, # Fractional blood flow to fat ((hr^-1)/QC QLC = 0.15, # Fractional blood flow to liver ((hr^-1)/QC) QMC = 0.32, # Fractional blood flow to muscle ((hr^-1)/QC) ## Chemical specific parameters for chemical PLA = 16.17, # Liver/air partition coefficient PFA = 281.48, # Fat/air partition coefficient PMA = 13.3, # Muscle/air partition coefficient PTA = 16.17, # Viscera/air partition coefficient PB = 5.487, # Blood/air partition coefficient MW = 153.8, # Molecular weight (g/mol) VMAX = 0.04321671, # Max. velocity of metabolism (mg/hr) -calibrated KM = 0.4027255, # Michaelis-Menten constant (mg/l) -calibrated ## Parameters for simulated experiment CONC = 1000, # Inhaled concentration KL = 0.02, # Loss rate from empty chamber /hr RATS = 1.0, # Number of rats enclosed in chamber VCHC = 3.8 # Volume of closed chamber (l) ) ## ================ ## State variables ## ================ y <- c( AI = 21, # total mass , mg AAM = 0, AT = 0, AF = 0, AL = 0, CLT = 0, # area under the conc.-time curve in the liver AM = 0 # the amount metabolized (AM) ) ## ================== ## Model application ## ================== times <- seq(0, 6, by = 0.1) ## initial inhaled concentration-calibrated conc <- c(26.496, 90.197, 245.15, 951.46) plot(ChamberConc ~ time, data = ccl4data, xlab = "Time (hours)", xlim = range(c(0, ccl4data$time)), ylab = "Chamber Concentration (ppm)", log = "y", main = "ccl4model") for (cc in conc) { Pm["CONC"] <- cc VCH <- Pm[["VCHC"]] - Pm[["RATS"]] * Pm[["BW"]] AI0 <- VCH * Pm[["CONC"]] * Pm[["MW"]]/24450 y["AI"] <- AI0 ## run the model: out <- as.data.frame(ccl4model(times, y, Pm)) lines(out$time, out$CP, lwd = 2) } legend("topright", lty = c(NA, 1), pch = c(1, NA), lwd = c(NA, 2), legend = c("data", "model")) ## ================================== ## An example with tracer injection ## ================================== ## every day, a conc of 2 is added to AI. ## 1. implemented as a data.frame eventdat <- data.frame(var = rep("AI", 6), time = 1:6 , value = rep(1, 6), method = rep("add", 6)) eventdat print(system.time( out <-ccl4model(times, y, Pm, events = list(data = eventdat)) )) plot(out, mfrow = c(3, 4), type = "l", lwd = 2) # 2. implemented as a function in a DLL! print(system.time( out2 <-ccl4model(times, y, Pm, events = list(func = "eventfun", time = 1:6)) )) plot(out2, mfrow=c(3, 4), type = "l", lwd = 2) } \details{ The model is implemented primarily to demonstrate the linking of FORTRAN with R-code. The source can be found in the \file{/doc/examples/dynload} subdirectory of the package. } \seealso{ Try \code{demo(CCL4model)} for how this model has been fitted to the dataset \code{\link{ccl4data},} \code{\link{aquaphy}}, another FORTRAN model, describing growth in aquatic phytoplankton. } \keyword{models} deSolve/man/ode.Rd0000644000176000001440000003100313136461014013510 0ustar ripleyusers\name{ode} \alias{ode} \alias{print.deSolve} \alias{summary.deSolve} \title{General Solver for Ordinary Differential Equations} \description{Solves a system of ordinary differential equations; a wrapper around the implemented ODE solvers} \usage{ode(y, times, func, parms, method = c("lsoda", "lsode", "lsodes", "lsodar", "vode", "daspk", "euler", "rk4", "ode23", "ode45", "radau", "bdf", "bdf_d", "adams", "impAdams", "impAdams_d", "iteration"), ...) \method{print}{deSolve}(x, \dots) \method{summary}{deSolve}(object, select = NULL, which = select, subset = NULL, \dots) } \arguments{ \item{y }{the initial (state) values for the ODE system, a vector. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the model definition) at time t, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{ode} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{parameters passed to \code{func}.} \item{method }{the integrator to use, either a \bold{function} that performs integration, or a \bold{list} of class \code{\link{rkMethod}}, or a \bold{string} (\code{"lsoda"}, \code{"lsode"}, \code{"lsodes"},\code{"lsodar"},\code{"vode"}, \code{"daspk"}, \code{"euler"}, \code{"rk4"}, \code{"ode23"}, \code{"ode45"}, \code{"radau"}, \code{"bdf"}, \code{"bdf_d"}, \code{"adams"}, \code{"impAdams"} or \code{"impAdams_d"} ,"iteration"). Options "bdf", "bdf_d", "adams", "impAdams" or "impAdams_d" are the backward differentiation formula, the BDF with diagonal representation of the Jacobian, the (explicit) Adams and the implicit Adams method, and the implicit Adams method with diagonal representation of the Jacobian respectively (see details). The default integrator used is \link{lsoda}. Method \code{"iteration"} is special in that here the function \code{func} should return the new value of the state variables rather than the rate of change. This can be used for individual based models, for difference equations, or in those cases where the integration is performed within \code{func}). See last example. } \item{x }{an object of class \code{deSolve}, as returned by the integrators, and to be printed or to be subsetted. } \item{object }{an object of class \code{deSolve}, as returned by the integrators, and whose summary is to be calculated. In contrast to R's default, this returns a data.frame. It returns one summary column for a multi-dimensional variable. } \item{which }{the name(s) or the index to the variables whose summary should be estimated. Default = all variables. } \item{select }{which variable/columns to be selected. } \item{subset }{logical expression indicating elements or rows to keep when calculating a \code{summary}: missing values are taken as \code{FALSE} } \item{... }{additional arguments passed to the integrator or to the methods.} } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the second element of the return from \code{func}, plus an additional column (the first) for the time value. There will be one row for each element in \code{times} unless the integrator returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{Karline Soetaert } \details{ This is simply a wrapper around the various ode solvers. See package vignette for information about specifying the model in compiled code. See the selected integrator for the additional options. The default integrator used is \code{\link{lsoda}}. The option \code{method = "bdf"} provdes a handle to the backward differentiation formula (it is equal to using \code{method = "lsode"}). It is best suited to solve stiff (systems of) equations. The option \code{method = "bdf_d"} selects the backward differentiation formula that uses Jacobi-Newton iteration (neglecting the off-diagonal elements of the Jacobian (it is equal to using \code{method = "lsode", mf = 23}). It is best suited to solve stiff (systems of) equations. \code{method = "adams"} triggers the Adams method that uses functional iteration (no Jacobian used); (equal to \code{method = "lsode", mf = 10}. It is often the best choice for solving non-stiff (systems of) equations. Note: when functional iteration is used, the method is often said to be explicit, although it is in fact implicit. \code{method = "impAdams"} selects the implicit Adams method that uses Newton- Raphson iteration (equal to \code{method = "lsode", mf = 12}. \code{method = "impAdams_d"} selects the implicit Adams method that uses Jacobi- Newton iteration, i.e. neglecting all off-diagonal elements (equal to \code{method = "lsode", mf = 13}. For very stiff systems, \code{method = "daspk"} may outperform \code{method = "bdf"}. } \seealso{ \itemize{ \item \code{\link{plot.deSolve}} for plotting the outputs, \item \code{\link{dede}} general solver for delay differential equations \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, \item \code{\link{aquaphy}}, \code{\link{ccl4model}}, where \code{ode} is used, \item \code{\link{lsoda}}, \code{\link{lsode}}, \code{\link{lsodes}}, \code{\link{lsodar}}, \code{\link{vode}}, \code{\link{daspk}}, \code{\link{radau}}, \item \code{\link{rk}}, \code{\link{rkMethod}} for additional Runge-Kutta methods, \item \code{\link{forcings}} and \code{\link{events}}, \item \code{\link{diagnostics}} to print diagnostic messages. } } \keyword{math} \examples{ ## ======================================================================= ## Example1: Predator-Prey Lotka-Volterra model (with logistic prey) ## ======================================================================= LVmod <- function(Time, State, Pars) { with(as.list(c(State, Pars)), { Ingestion <- rIng * Prey * Predator GrowthPrey <- rGrow * Prey * (1 - Prey/K) MortPredator <- rMort * Predator dPrey <- GrowthPrey - Ingestion dPredator <- Ingestion * assEff - MortPredator return(list(c(dPrey, dPredator))) }) } pars <- c(rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of predator assEff = 0.5, # -, assimilation efficiency K = 10) # mmol/m3, carrying capacity yini <- c(Prey = 1, Predator = 2) times <- seq(0, 200, by = 1) out <- ode(yini, times, LVmod, pars) summary(out) ## Default plot method plot(out) ## User specified plotting matplot(out[ , 1], out[ , 2:3], type = "l", xlab = "time", ylab = "Conc", main = "Lotka-Volterra", lwd = 2) legend("topright", c("prey", "predator"), col = 1:2, lty = 1:2) ## ======================================================================= ## Example2: Substrate-Producer-Consumer Lotka-Volterra model ## ======================================================================= ## Note: ## Function sigimp passed as an argument (input) to model ## (see also lsoda and rk examples) SPCmod <- function(t, x, parms, input) { with(as.list(c(parms, x)), { import <- input(t) dS <- import - b*S*P + g*C # substrate dP <- c*S*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dS, dP, dC) list(res) }) } ## The parameters parms <- c(b = 0.001, c = 0.1, d = 0.1, e = 0.1, f = 0.1, g = 0.0) ## vector of timesteps times <- seq(0, 200, length = 101) ## external signal with rectangle impulse signal <- data.frame(times = times, import = rep(0, length(times))) signal$import[signal$times >= 10 & signal$times <= 11] <- 0.2 sigimp <- approxfun(signal$times, signal$import, rule = 2) ## Start values for steady state xstart <- c(S = 1, P = 1, C = 1) ## Solve model out <- ode(y = xstart, times = times, func = SPCmod, parms = parms, input = sigimp) ## Default plot method plot(out) ## User specified plotting mf <- par(mfrow = c(1, 2)) matplot(out[,1], out[,2:4], type = "l", xlab = "time", ylab = "state") legend("topright", col = 1:3, lty = 1:3, legend = c("S", "P", "C")) plot(out[,"P"], out[,"C"], type = "l", lwd = 2, xlab = "producer", ylab = "consumer") par(mfrow = mf) ## ======================================================================= ## Example3: Discrete time model - using method = "iteration" ## The host-parasitoid model from Soetaert and Herman, 2009, ## Springer - p. 284. ## ======================================================================= Parasite <- function(t, y, ks) { P <- y[1] H <- y[2] f <- A * P / (ks + H) Pnew <- H * (1 - exp(-f)) Hnew <- H * exp(rH * (1 - H) - f) list (c(Pnew, Hnew)) } rH <- 2.82 # rate of increase A <- 100 # attack rate ks <- 15 # half-saturation density out <- ode(func = Parasite, y = c(P = 0.5, H = 0.5), times = 0:50, parms = ks, method = "iteration") out2<- ode(func = Parasite, y = c(P = 0.5, H = 0.5), times = 0:50, parms = 25, method = "iteration") out3<- ode(func = Parasite, y = c(P = 0.5, H = 0.5), times = 0:50, parms = 35, method = "iteration") ## Plot all 3 scenarios in one figure plot(out, out2, out3, lty = 1, lwd = 2) ## Same like "out", but *output* every two steps ## hini = 1 ensures that the same *internal* timestep of 1 is used outb <- ode(func = Parasite, y = c(P = 0.5, H = 0.5), times = seq(0, 50, 2), hini = 1, parms = ks, method = "iteration") plot(out, outb, type = c("l", "p")) \dontrun{ ## ======================================================================= ## Example4: Playing with the Jacobian options - see e.g. lsoda help page ## ## IMPORTANT: The following example is temporarily broken because of ## incompatibility with R 3.0 on some systems. ## A fix is on the way. ## ======================================================================= ## a stiff equation, exponential decay, run 500 times stiff <- function(t, y, p) { # y and r are a 500-valued vector list(- r * y) } N <- 500 r <- runif(N, 15, 20) yini <- runif(N, 1, 40) times <- 0:10 ## Using the default print(system.time( out <- ode(y = yini, parms = NULL, times = times, func = stiff) )) # diagnostics(out) shows that the method used = bdf (2), so it it stiff ## Specify that the Jacobian is banded, with nonzero values on the ## diagonal, i.e. the bandwidth up and down = 0 print(system.time( out2 <- ode(y = yini, parms = NULL, times = times, func = stiff, jactype = "bandint", bandup = 0, banddown = 0) )) ## Now we also specify the Jacobian function jacob <- function(t, y, p) -r print(system.time( out3 <- ode(y = yini, parms = NULL, times = times, func = stiff, jacfunc = jacob, jactype = "bandusr", bandup = 0, banddown = 0) )) ## The larger the value of N, the larger the time gain... } } deSolve/man/deSolve.Rd0000644000176000001440000001302413561547564014366 0ustar ripleyusers\name{deSolve-package} \alias{deSolve-package} \alias{deSolve} \docType{package} \title{ General Solvers for Initial Value Problems of Ordinary Differential Equations (ODE), Partial Differential Equations (PDE), Differential Algebraic Equations (DAE) and delay differential equations (DDE). } \description{ Functions that solve initial value problems of a system of first-order ordinary differential equations (ODE), of partial differential equations (PDE), of differential algebraic equations (DAE) and delay differential equations. The functions provide an interface to the FORTRAN functions lsoda, lsodar, lsode, lsodes of the ODEPACK collection, to the FORTRAN functions dvode, zvode and daspk and a C-implementation of solvers of the Runge-Kutta family with fixed or variable time steps. The package contains routines designed for solving ODEs resulting from 1-D, 2-D and 3-D partial differential equations (PDE) that have been converted to ODEs by numerical differencing. It includes root-finding (or event location) and provides access to lagged variables and derivatives. The system of differential equations is written as an \R{} function or defined in compiled code that has been dynamically loaded, see package vignette \href{../doc/compiledCode.pdf}{compiledCode} for details. The solvers may be used as part of a modeling package for differential equations, or for parameter estimation using any appropriate modeling tool for non-linear models in \R{} such as \code{\link{optim}}, \code{\link{nls}}, \code{\link{nlm}} or \code{\link[nlme]{nlme}}, or \code{\link[FME]{FME}}. \bold{Package Vignettes, Examples, Online Resources} \itemize{ \item Solving Initial Value Differential Equations in R (\href{../doc/deSolve.pdf}{pdf}, \href{../doc/deSolve.R}{R code}) \item Writing Code in Compiled Languages (\href{../doc/compiledCode.pdf}{pdf}, \href{../doc/compiledCode.R}{R code}) \item Examples in R (\url{../doc/examples}), and in Fortran or C (\url{../doc/dynload}, \url{../doc/dynload-dede}) \item deSolve homepage: \url{http://desolve.r-forge.r-project.org} (Papers, Books, PDFs) \item Mailing list: \url{mailto:r-sig-dynamic-models@r-project.org} } } \author{ Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer } \references{ Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer (2010): Solving Differential Equations in R: Package deSolve Journal of Statistical Software, 33(9), 1--25. \url{https://www.jstatsoft.org/v33/i09/} Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer (2010): Solving differential equations in R. The R Journal 2(2), 5-15. \href{https://journal.r-project.org/archive/2010-2/RJournal_2010-2_Soetaert~et~al.pdf}{pdf} Karline Soetaert, Thomas Petzoldt (2011): Solving ODEs, DAEs, DDEs and PDEs in R. Journal of Numerical Analysis, Industrial and Applied Mathematics (JNAIAM) 6(1-2), 51-65. %\href{http://jnaiam.org/uploads/jnaiam_6_4.pdf}{pdf} Karline Soetaert, Jeff Cash, Francesca Mazzia, (2012): Solving Differential Equations in R. Springer, 248 pp. Alan C. Hindmarsh (1983): ODEPACK, A Systematized Collection of ODE Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), North-Holland, Amsterdam, pp. 55-64. L. R. Petzold, (1983): A Description of DASSL: A Differential/Algebraic System Solver, in Scientific Computing, R. S. Stepleman et al. (Eds.), North-Holland, Amsterdam, pp. 65-68. P. N. Brown, G. D. Byrne, A. C. Hindmarsh (1989): VODE: A Variable Coefficient ODE Solver, SIAM J. Sci. Stat. Comput., 10, pp. 1038-1051. See also the references given on the specific help pages of the different methods. } \seealso{ \code{\link{ode}} for a general interface to most of the ODE solvers, \code{\link{ode.band}} for solving models with a banded Jacobian, \code{\link{ode.1D}}, \code{\link{ode.2D}}, \code{\link{ode.3D}}, for integrating 1-D, 2-D and 3-D models, \code{\link{dede}} for a general interface to the delay differential equation solvers, \code{\link{lsoda}}, \code{\link{lsode}}, \code{\link{lsodes}}, \code{\link{lsodar}}, \code{\link{vode}}, for ODE solvers of the Livermore family, \code{\link{daspk}}, for a DAE solver up to index 1, of the Livermore family, \code{\link{radau}} for integrating DAEs up to index 3 using an implicit Runge-Kutta, \code{\link{rk}}, \code{\link{rkMethod}}, \code{\link{rk4}}, \code{\link{euler}} for Runge-Kutta solvers, \code{\link{DLLfunc}}, \code{\link{DLLres}}, for testing model implementations in compiled code, \code{\link{forcings}}, \code{\link{events}}, for how to implement forcing functions (external variables) and events (sudden changes in state variables), \code{\link{lagvalue}}, \code{\link{lagderiv}}, for how to get access to lagged values of state variables and derivatives. } \examples{ library(deSolve) ## Chaos in the atmosphere Lorenz <- function(t, state, parameters) { with(as.list(c(state, parameters)), { dX <- a * X + Y * Z dY <- b * (Y - Z) dZ <- -X * Y + c * Y - Z list(c(dX, dY, dZ)) }) } parameters <- c(a = -8/3, b = -10, c = 28) state <- c(X = 1, Y = 1, Z = 1) times <- seq(0, 100, by = 0.01) out <- ode(y = state, times = times, func = Lorenz, parms = parameters) plot(out) ## add a 3D figure if package scatterplot3D is available if (require(scatterplot3d)) scatterplot3d(out[,-1], type = "l") } \keyword{ package } deSolve/man/DLLfunc.Rd0000644000176000001440000001061213136461014014233 0ustar ripleyusers\name{DLLfunc} \alias{DLLfunc} \title{Evaluates a Derivative Function Represented in a DLL} \description{Calls a function, defined in a compiled language as a DLL} \usage{DLLfunc(func, times, y, parms, dllname, initfunc = dllname, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL) } \arguments{ \item{func }{the name of the function in the dynamically loaded shared library, } \item{times }{first value = the time at which the function needs to be evaluated, } \item{y }{the values of the dependent variables for which the function needs to be evaluated, } \item{parms }{the parameters that are passed to the initialiser function, } \item{dllname }{a string giving the name of the shared library (without extension) that contains the compiled function or subroutine definitions referred to in \code{func}, } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See details. } \item{rpar }{a vector with double precision values passed to the DLL-function \code{func} and \code{jacfunc} present in the DLL, via argument rpar, } \item{ipar }{a vector with integer values passed to the dll-function \code{func} and \code{jacfunc} present in the DLL, via function argument ipar, } \item{nout }{the number of output variables. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time, value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See package vignette \code{"compiledCode"}. } } \value{ a list containing: \item{dy }{the rate of change estimated by the function, } \item{var }{the ordinary output variables of the function. } } \details{ This function is meant to help developing FORTRAN or C models that are to be used to solve ordinary differential equations (ODE) in packages \code{deSolve} and/or \code{rootSolve}. } \author{Karline Soetaert } \examples{ ## ========================================================================== ## ex. 1 ## ccl4model ## ========================================================================== ## Parameter values and initial conditions ## see example(ccl4model) for a more comprehensive implementation Parms <- c(0.182, 4.0, 4.0, 0.08, 0.04, 0.74, 0.05, 0.15, 0.32, 16.17, 281.48, 13.3, 16.17, 5.487, 153.8, 0.04321671, 0.4027255, 1000, 0.02, 1.0, 3.8) yini <- c(AI = 21, AAM = 0, AT = 0, AF = 0, AL = 0, CLT = 0, AM = 0) ## the rate of change DLLfunc(y = yini, dllname = "deSolve", func = "derivsccl4", initfunc = "initccl4", parms = Parms, times = 1, nout = 3, outnames = c("DOSE", "MASS", "CP") ) ## ========================================================================== ## ex. 2 ## SCOC model, in fortran - to see the FORTRAN code: ## ========================================================================== ## Forcing function "data" Flux <- matrix(ncol = 2, byrow = TRUE, data = c(1, 0.654, 2, 0.167)) parms <- c(k = 0.01) Yini <- 60 DLLfunc(y=Yini, times=1, func = "scocder", parms = parms, dllname = "deSolve", initforc = "scocforc", forcings = Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation","Depo")) ## correct value = dy = flux - k * y = 0.654 - 0.01 * 60 DLLfunc(y = Yini, times = 2, func = "scocder", parms = parms, dllname = "deSolve", initforc = "scocforc", forcings = Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation", "Depo")) } \keyword{utilities} \seealso{ \code{\link{ode}} for a general interface to most of the ODE solvers } deSolve/man/lsodar.Rd0000644000176000001440000004411013531001311014215 0ustar ripleyusers\name{lsodar} \alias{lsodar} \title{Solver for Ordinary Differential Equations (ODE), Switching Automatically Between Stiff and Non-stiff Methods and With Root Finding } \description{Solving initial value problems for stiff or non-stiff systems of first-order ordinary differential equations (ODEs) and including root-finding. The \R function \code{lsodar} provides an interface to the FORTRAN ODE solver of the same name, written by Alan C. Hindmarsh and Linda R. Petzold. The system of ODE's is written as an \R function or be defined in compiled code that has been dynamically loaded. - see description of \code{\link{lsoda}} for details. \code{lsodar} differs from \code{lsode} in two respects. \itemize{ \item It switches automatically between stiff and nonstiff methods (similar as lsoda). \item It finds the root of at least one of a set of constraint functions g(i) of the independent and dependent variables. } Two uses of \code{lsodar} are: \itemize{ \item To stop the simulation when a certain condition is met \item To trigger \link{events}, i.e. sudden changes in one of the state variables when a certain condition is met. } when a particular condition is met. } \usage{lsodar(y, times, func, parms, rtol = 1e-6, atol = 1e-6, jacfunc = NULL, jactype = "fullint", rootfunc = NULL, verbose = FALSE, nroot = 0, tcrit = NULL, hmin = 0, hmax = NULL, hini = 0, ynames = TRUE, maxordn = 12, maxords = 5, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, events=NULL, lags = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{times at which explicit estimates for \code{y} are desired. The first value in \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time t, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{lsodar()} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func} or \code{jacfunc}. } \item{rtol }{relative error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{atol }{absolute error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{jacfunc }{if not \code{NULL}, an \R function, that computes the Jacobian of the system of differential equations \eqn{\partial\dot{y}_i/\partial y_j}{dydot(i)/dy(j)}, or a string giving the name of a function or subroutine in \file{dllname} that computes the Jacobian (see vignette \code{"compiledCode"} for more about this option). In some circumstances, supplying \code{jacfunc} can speed up the computations, if the system is stiff. The \R calling sequence for \code{jacfunc} is identical to that of \code{func}. If the Jacobian is a full matrix, \code{jacfunc} should return a matrix \eqn{\partial\dot{y}/\partial y}{dydot/dy}, where the ith row contains the derivative of \eqn{dy_i/dt} with respect to \eqn{y_j}, or a vector containing the matrix elements by columns (the way \R and FORTRAN store matrices). If the Jacobian is banded, \code{jacfunc} should return a matrix containing only the nonzero bands of the Jacobian, rotated row-wise. See first example of \link{lsode}. } \item{jactype }{the structure of the Jacobian, one of \code{"fullint"}, \code{"fullusr"}, \code{"bandusr"} or \code{"bandint"} - either full or banded and estimated internally or by user. } \item{rootfunc }{if not \code{NULL}, an \R function that computes the function whose root has to be estimated or a string giving the name of a function or subroutine in \file{dllname} that computes the root function. The \R calling sequence for \code{rootfunc} is identical to that of \code{func}. \code{rootfunc} should return a vector with the function values whose root is sought. } \item{verbose }{a logical value that, when \code{TRUE}, will print the \code{diagnostiscs} of the integration - see details. } \item{nroot }{only used if \file{dllname} is specified: the number of constraint functions whose roots are desired during the integration; if \code{rootfunc} is an R-function, the solver estimates the number of roots. } \item{tcrit }{if not \code{NULL}, then \code{lsodar} cannot integrate past \code{tcrit}. The FORTRAN routine \code{lsodar} overshoots its targets (times points in the vector \code{times}), and interpolates values for the desired time points. If there is a time beyond which integration should not proceed (perhaps because of a singularity), that should be provided in \code{tcrit}. } \item{hmin }{an optional minimum value of the integration stepsize. In special situations this parameter may speed up computations with the cost of precision. Don't use \code{hmin} if you don't know why! } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, \code{hmax} is set to the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. } \item{hini }{initial step size to be attempted; if 0, the initial step size is determined by the solver. } \item{ynames }{logical, if \code{FALSE}: names of state variables are not passed to function \code{func}; this may speed up the simulation especially for large models. } \item{maxordn }{the maximum order to be allowed in case the method is non-stiff. Should be <= 12. Reduce \code{maxord} to save storage space. } \item{maxords }{the maximum order to be allowed in case the method is stiff. Should be <= 5. Reduce maxord to save storage space. } \item{bandup }{number of non-zero bands above the diagonal, in case the Jacobian is banded. } \item{banddown }{number of non-zero bands below the diagonal, in case the Jacobian is banded. } \item{maxsteps }{maximal number of steps per output interval taken by the solver. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func} and \code{jacfunc}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the dll - you have to perform this check in the code - See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. These names will be used to label the output matrix. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See \link{forcings} or vignette \code{compiledCode}. } \item{events }{A matrix or data frame that specifies events, i.e. when the value of a state variable is suddenly changed. See \link{events} for more information. } \item{lags }{A list that specifies timelags, i.e. the number of steps that has to be kept. To be used for delay differential equations. See \link{timelags}, \link{dede} for more information. } \item{... }{additional arguments passed to \code{func} and \code{jacfunc} allowing this to be a generic function. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the FORTRAN routine `lsodar' returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. If a root has been found, the output will have the attribute \code{iroot}, an integer indicating which root has been found. } \author{Karline Soetaert } \examples{ ## ======================================================================= ## Example 1: ## from lsodar source code ## ======================================================================= Fun <- function (t, y, parms) { ydot <- vector(len = 3) ydot[1] <- -.04*y[1] + 1.e4*y[2]*y[3] ydot[3] <- 3.e7*y[2]*y[2] ydot[2] <- -ydot[1] - ydot[3] return(list(ydot, ytot = sum(y))) } rootFun <- function (t, y, parms) { yroot <- vector(len = 2) yroot[1] <- y[1] - 1.e-4 yroot[2] <- y[3] - 1.e-2 return(yroot) } y <- c(1, 0, 0) times <- c(0, 0.4*10^(0:8)) out <- lsodar(y = y, times = times, fun = Fun, rootfun = rootFun, rtol = 1e-4, atol = c(1e-6, 1e-10, 1e-6), parms = NULL) print(paste("root is found for eqn", which(attributes(out)$iroot == 1))) print(out[nrow(out),]) diagnostics(out) ## ======================================================================= ## Example 2: ## using lsodar to estimate steady-state conditions ## ======================================================================= ## Bacteria (Bac) are growing on a substrate (Sub) model <- function(t, state, pars) { with (as.list(c(state, pars)), { ## substrate uptake death respiration dBact <- gmax*eff*Sub/(Sub+ks)*Bact - dB*Bact - rB*Bact dSub <- -gmax *Sub/(Sub+ks)*Bact + dB*Bact + input return(list(c(dBact,dSub))) }) } ## root is the condition where sum of |rates of change| ## is very small rootfun <- function (t, state, pars) { dstate <- unlist(model(t, state, pars)) # rate of change vector return(sum(abs(dstate)) - 1e-10) } pars <- list(Bini = 0.1, Sini = 100, gmax = 0.5, eff = 0.5, ks = 0.5, rB = 0.01, dB = 0.01, input = 0.1) tout <- c(0, 1e10) state <- c(Bact = pars$Bini, Sub = pars$Sini) out <- lsodar(state, tout, model, pars, rootfun = rootfun) print(out) ## ======================================================================= ## Example 3: ## using lsodar to trigger an event ## ======================================================================= ## a state variable is decaying at a first-order rate. ## when it reaches the value 0.1, a random amount is added. derivfun <- function (t,y,parms) list (-0.05 * y) rootfun <- function (t,y,parms) return(y - 0.1) eventfun <- function(t,y,parms) return(y + runif(1)) yini <- 0.8 times <- 0:200 out <- lsodar(func=derivfun, y = yini, times=times, rootfunc = rootfun, events = list(func=eventfun, root = TRUE)) plot(out, type = "l", lwd = 2, main = "lsodar with event") } \references{ Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), North-Holland, Amsterdam, 1983, pp. 55-64. Linda R. Petzold, Automatic Selection of Methods for Solving Stiff and Nonstiff Systems of Ordinary Differential Equations, Siam J. Sci. Stat. Comput. 4 (1983), pp. 136-148. Kathie L. Hiebert and Lawrence F. Shampine, Implicitly Defined Output Points for Solutions of ODEs, Sandia Report SAND80-0180, February 1980. Netlib: \url{http://www.netlib.org} } \details{ The work is done by the FORTRAN subroutine \code{lsodar}, whose documentation should be consulted for details (it is included as comments in the source file \file{src/opkdmain.f}). The implementation is based on the November, 2003 version of lsodar, from Netlib. \code{lsodar} switches automatically between stiff and nonstiff methods (similar as \code{lsoda}). This means that the user does not have to determine whether the problem is stiff or not, and the solver will automatically choose the appropriate method. It always starts with the nonstiff method. \code{lsodar} can find the root of at least one of a set of constraint functions \code{rootfunc} of the independent and dependent variables. It then returns the solution at the root if that occurs sooner than the specified stop condition, and otherwise returns the solution according the specified stop condition. Caution: Because of numerical errors in the function \code{rootfun} due to roundoff and integration error, \code{lsodar} may return false roots, or return the same root at two or more nearly equal values of \code{time}. The form of the \bold{Jacobian} can be specified by \code{jactype} which can take the following values: \describe{ \item{jactype = "fullint":}{a full Jacobian, calculated internally by lsodar, the default, } \item{jactype = "fullusr":}{a full Jacobian, specified by user function \code{jacfunc}, } \item{jactype = "bandusr":}{a banded Jacobian, specified by user function \code{jacfunc}; the size of the bands specified by \code{bandup} and \code{banddown}, } \item{jactype = "bandint":}{banded Jacobian, calculated by lsodar; the size of the bands specified by \code{bandup} and \code{banddown}. } } If \code{jactype} = "fullusr" or "bandusr" then the user must supply a subroutine \code{jacfunc}. The input parameters \code{rtol}, and \code{atol} determine the \bold{error control} performed by the solver. See \code{\link{lsoda}} for details. The output will have the attribute \bold{iroot}, if a root was found \bold{iroot} is a vector, its length equal to the number of constraint functions it will have a value of 1 for the constraint function whose root that has been found and 0 otherwise. The diagnostics of the integration can be printed to screen by calling \code{\link{diagnostics}}. If \code{verbose} = \code{TRUE}, the diagnostics will written to the screen at the end of the integration. See vignette("deSolve") for an explanation of each element in the vectors containing the diagnostic properties and how to directly access them. \bold{Models} may be defined in compiled C or FORTRAN code, as well as in an R-function. See package vignette \code{"compiledCode"} for details. More information about models defined in compiled code is in the package vignette ("compiledCode"); information about linking forcing functions to compiled code is in \link{forcings}. Examples in both C and FORTRAN are in the \file{dynload} subdirectory of the \code{deSolve} package directory. } \seealso{ \itemize{ \item \code{\link{roots}} for more examples on roots and events \item \code{\link{rk}}, \code{\link{rkMethod}}, \code{\link{rk4}} and \code{\link{euler}} for Runge-Kutta integrators. \item \code{\link{lsoda}}, \code{\link{lsode}}, \code{\link{lsodes}}, \code{\link{vode}}, \code{\link{daspk}} for other solvers of the Livermore family, \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/zvode.Rd0000644000176000001440000003241413136461014014077 0ustar ripleyusers\name{zvode} \alias{zvode} \title{Solver for Ordinary Differential Equations (ODE) for COMPLEX variables} \description{ Solves the initial value problem for stiff or nonstiff systems of ordinary differential equations (ODE) in the form: \deqn{dy/dt = f(t,y)} where \eqn{dy} and \eqn{y} are complex variables. The \R function \code{zvode} provides an interface to the FORTRAN ODE solver of the same name, written by Peter N. Brown, Alan C. Hindmarsh and George D. Byrne. } \usage{zvode(y, times, func, parms, rtol = 1e-6, atol = 1e-6, jacfunc = NULL, jactype = "fullint", mf = NULL, verbose = FALSE, tcrit = NULL, hmin = 0, hmax = NULL, hini = 0, ynames = TRUE, maxord = NULL, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. \emph{y has to be complex} } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time; if only one step is to be taken; set \code{times = NULL}. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time \code{t}, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms, ...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. They should be \emph{complex numbers}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{zvode()} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func} or \code{jacfunc}. } \item{rtol }{relative error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{atol }{absolute error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{jacfunc }{if not \code{NULL}, an \R function that computes the Jacobian of the system of differential equations \eqn{\partial\dot{y}_i/\partial y_j}{dydot(i)/dy(j)}, or a string giving the name of a function or subroutine in \file{dllname} that computes the Jacobian (see vignette \code{"compiledCode"} for more about this option). In some circumstances, supplying \code{jacfunc} can speed up the computations, if the system is stiff. The \R calling sequence for \code{jacfunc} is identical to that of \code{func}. If the Jacobian is a full matrix, \code{jacfunc} should return a matrix \eqn{\dot{dy}/dy}{dydot/dy}, where the ith row contains the derivative of \eqn{dy_i/dt} with respect to \eqn{y_j}, or a vector containing the matrix elements by columns (the way \R and FORTRAN store matrices). Its elements should be \emph{complex numbers}. If the Jacobian is banded, \code{jacfunc} should return a matrix containing only the nonzero bands of the Jacobian, rotated row-wise. See first example of \code{lsode}. } \item{jactype }{the structure of the Jacobian, one of \code{"fullint"}, \code{"fullusr"}, \code{"bandusr"} or \code{"bandint"} - either full or banded and estimated internally or by user; overruled if \code{mf} is not \code{NULL}. } \item{mf }{the "method flag" passed to function \code{zvode} - overrules \code{jactype} - provides more options than \code{jactype} - see details. } \item{verbose }{if TRUE: full output to the screen, e.g. will print the \code{diagnostiscs} of the integration - see details. } \item{tcrit }{if not \code{NULL}, then \code{zvode} cannot integrate past \code{tcrit}. The FORTRAN routine \code{dvode} overshoots its targets (times points in the vector \code{times}), and interpolates values for the desired time points. If there is a time beyond which integration should not proceed (perhaps because of a singularity), that should be provided in \code{tcrit}. } \item{hmin }{an optional minimum value of the integration stepsize. In special situations this parameter may speed up computations with the cost of precision. Don't use hmin if you don't know why! } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, hmax is set to the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. } \item{hini }{initial step size to be attempted; if 0, the initial step size is determined by the solver. } \item{ynames }{logical; if \code{FALSE}: names of state variables are not passed to function \code{func} ; this may speed up the simulation especially for multi-D models. } \item{maxord }{the maximum order to be allowed. \code{NULL} uses the default, i.e. order 12 if implicit Adams method (\code{meth = 1}), order 5 if BDF method (\code{meth = 2}). Reduce maxord to save storage space. } \item{bandup }{number of non-zero bands above the diagonal, in case the Jacobian is banded. } \item{banddown }{number of non-zero bands below the diagonal, in case the Jacobian is banded. } \item{maxsteps }{maximal number of steps per output interval taken by the solver. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func} and \code{jacfunc}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the DLL-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the DLL - you have to perform this check in the code - See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. These names will be used to label the output matrix. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. \link{forcings} or package vignette \code{"compiledCode"} } \item{... }{additional arguments passed to \code{func} and \code{jacfunc} allowing this to be a generic function. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the FORTRAN routine `zvode' returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{Karline Soetaert } \examples{ ## ======================================================================= ## Example 1 - very simple example ## df/dt = 1i*f, where 1i is the imaginary unit ## The initial value is f(0) = 1 = 1+0i ## ======================================================================= ZODE <- function(Time, f, Pars) { df <- 1i*f return(list(df)) } pars <- NULL yini <- c(f = 1+0i) times <- seq(0, 2*pi, length = 100) out <- zvode(func = ZODE, y = yini, parms = pars, times = times, atol = 1e-10, rtol = 1e-10) # The analytical solution to this ODE is the exp-function: # f(t) = exp(1i*t) # = cos(t)+1i*sin(t) (due to Euler's equation) analytical.solution <- exp(1i * times) ## compare numerical and analytical solution tail(cbind(out[,2], analytical.solution)) ## ======================================================================= ## Example 2 - example in "zvode.f", ## df/dt = 1i*f (same as above ODE) ## dg/dt = -1i*g*g*f (an additional ODE depending on f) ## ## Initial values are ## g(0) = 1/2.1 and ## z(0) = 1 ## ======================================================================= ZODE2<-function(Time,State,Pars) { with(as.list(State), { df <- 1i * f dg <- -1i * g*g * f return(list(c(df, dg))) }) } yini <- c(f = 1 + 0i, g = 1/2.1 + 0i) times <- seq(0, 2*pi, length = 100) out <- zvode(func = ZODE2, y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10) ## The analytical solution is ## f(t) = exp(1i*t) (same as above) ## g(t) = 1/(f(t) + 1.1) analytical <- cbind(f = exp(1i * times), g = 1/(exp(1i * times) + 1.1)) ## compare numerical solution and the two analytical ones: tail(cbind(out[,2], analytical[,1])) } \references{ P. N. Brown, G. D. Byrne, and A. C. Hindmarsh, 1989. VODE: A Variable Coefficient ODE Solver, SIAM J. Sci. Stat. Comput., 10, pp. 1038-1051. \cr Also, LLNL Report UCRL-98412, June 1988. G. D. Byrne and A. C. Hindmarsh, 1975. A Polyalgorithm for the Numerical Solution of Ordinary Differential Equations. ACM Trans. Math. Software, 1, pp. 71-96. A. C. Hindmarsh and G. D. Byrne, 1977. EPISODE: An Effective Package for the Integration of Systems of Ordinary Differential Equations. LLNL Report UCID-30112, Rev. 1. G. D. Byrne and A. C. Hindmarsh, 1976. EPISODEB: An Experimental Package for the Integration of Systems of Ordinary Differential Equations with Banded Jacobians. LLNL Report UCID-30132, April 1976. A. C. Hindmarsh, 1983. ODEPACK, a Systematized Collection of ODE Solvers. in Scientific Computing, R. S. Stepleman et al., eds., North-Holland, Amsterdam, pp. 55-64. K. R. Jackson and R. Sacks-Davis, 1980. An Alternative Implementation of Variable Step-Size Multistep Formulas for Stiff ODEs. ACM Trans. Math. Software, 6, pp. 295-318. Netlib: \url{http://www.netlib.org} } \details{ see \code{\link{vode}}, the double precision version, for details. } \note{ From version 1.10.4, the default of atol was changed from 1e-8 to 1e-6, to be consistent with the other solvers. The following text is adapted from the zvode.f source code: When using \code{zvode} for a stiff system, it should only be used for the case in which the function f is analytic, that is, when each f(i) is an analytic function of each y(j). Analyticity means that the partial derivative df(i)/dy(j) is a unique complex number, and this fact is critical in the way \code{zvode} solves the dense or banded linear systems that arise in the stiff case. For a complex stiff ODE system in which f is not analytic, \code{zvode} is likely to have convergence failures, and for this problem one should instead use \code{ode} on the equivalent real system (in the real and imaginary parts of y). } \seealso{ \code{\link{vode}} for the double precision version } \keyword{math} deSolve/man/lsode.Rd0000644000176000001440000005037113136461014014060 0ustar ripleyusers\name{lsode} \alias{lsode} \title{Solver for Ordinary Differential Equations (ODE)} \description{ Solves the initial value problem for stiff or nonstiff systems of ordinary differential equations (ODE) in the form: \deqn{dy/dt = f(t,y)}. The \R function \code{lsode} provides an interface to the FORTRAN ODE solver of the same name, written by Alan C. Hindmarsh and Andrew H. Sherman. It combines parts of the code \code{lsodar} and can thus find the root of at least one of a set of constraint functions g(i) of the independent and dependent variables. This can be used to stop the simulation or to trigger \link{events}, i.e. a sudden change in one of the state variables. The system of ODE's is written as an \R function or be defined in compiled code that has been dynamically loaded. In contrast to \code{\link{lsoda}}, the user has to specify whether or not the problem is stiff and choose the appropriate solution method. \code{lsode} is very similar to \code{\link{vode}}, but uses a fixed-step-interpolate method rather than the variable-coefficient method in \code{\link{vode}}. In addition, in \code{vode} it is possible to choose whether or not a copy of the Jacobian is saved for reuse in the corrector iteration algorithm; In \code{lsode}, a copy is not kept. } \usage{ lsode(y, times, func, parms, rtol = 1e-6, atol = 1e-6, jacfunc = NULL, jactype = "fullint", mf = NULL, rootfunc = NULL, verbose = FALSE, nroot = 0, tcrit = NULL, hmin = 0, hmax = NULL, hini = 0, ynames = TRUE, maxord = NULL, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, events=NULL, lags = NULL,...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time; if only one step is to be taken; set \code{times} = \code{NULL}. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time t, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{lsode()} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func} or \code{jacfunc}. } \item{rtol }{relative error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{atol }{absolute error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{jacfunc }{if not \code{NULL}, an \R function that computes the Jacobian of the system of differential equations \eqn{\partial\dot{y}_i/\partial y_j}{dydot(i)/dy(j)}, or a string giving the name of a function or subroutine in \file{dllname} that computes the Jacobian (see vignette \code{"compiledCode"} for more about this option). In some circumstances, supplying \code{jacfunc} can speed up the computations, if the system is stiff. The \R calling sequence for \code{jacfunc} is identical to that of \code{func}. If the Jacobian is a full matrix, \code{jacfunc} should return a matrix \eqn{\partial\dot{y}/\partial y}{dydot/dy}, where the ith row contains the derivative of \eqn{dy_i/dt} with respect to \eqn{y_j}, or a vector containing the matrix elements by columns (the way \R and FORTRAN store matrices). \cr If the Jacobian is banded, \code{jacfunc} should return a matrix containing only the nonzero bands of the Jacobian, rotated row-wise. See first example of \link{lsode}. } \item{jactype }{the structure of the Jacobian, one of \code{"fullint"}, \code{"fullusr"}, \code{"bandusr"} or \code{"bandint"} - either full or banded and estimated internally or by user; overruled if \code{mf}is not \code{NULL}. } \item{mf }{the "method flag" passed to function lsode - overrules \code{jactype} - provides more options than \code{jactype} - see details. } \item{rootfunc }{if not \code{NULL}, an \R function that computes the function whose root has to be estimated or a string giving the name of a function or subroutine in \file{dllname} that computes the root function. The \R calling sequence for \code{rootfunc} is identical to that of \code{func}. \code{rootfunc} should return a vector with the function values whose root is sought. } \item{verbose }{if TRUE: full output to the screen, e.g. will print the \code{diagnostiscs} of the integration - see details. } \item{nroot }{only used if \file{dllname} is specified: the number of constraint functions whose roots are desired during the integration; if \code{rootfunc} is an R-function, the solver estimates the number of roots. } \item{tcrit }{if not \code{NULL}, then \code{lsode} cannot integrate past \code{tcrit}. The FORTRAN routine \code{lsode} overshoots its targets (times points in the vector \code{times}), and interpolates values for the desired time points. If there is a time beyond which integration should not proceed (perhaps because of a singularity), that should be provided in \code{tcrit}. } \item{hmin }{an optional minimum value of the integration stepsize. In special situations this parameter may speed up computations with the cost of precision. Don't use \code{hmin} if you don't know why! } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, \code{hmax} is set to the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. } \item{hini }{initial step size to be attempted; if 0, the initial step size is determined by the solver. } \item{ynames }{logical, if \code{FALSE} names of state variables are not passed to function \code{func}; this may speed up the simulation especially for multi-D models. } \item{maxord }{the maximum order to be allowed. \code{NULL} uses the default, i.e. order 12 if implicit Adams method (meth = 1), order 5 if BDF method (meth = 2). Reduce maxord to save storage space. } \item{bandup }{number of non-zero bands above the diagonal, in case the Jacobian is banded. } \item{banddown }{number of non-zero bands below the diagonal, in case the Jacobian is banded. } \item{maxsteps }{maximal number of steps per output interval taken by the solver. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func} and \code{jacfunc}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the dll - you have to perform this check in the code - See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. These names will be used to label the output matrix. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See \link{forcings} or vignette \code{compiledCode}. } \item{events }{A matrix or data frame that specifies events, i.e. when the value of a state variable is suddenly changed. See \link{events} for more information. } \item{lags }{A list that specifies timelags, i.e. the number of steps that has to be kept. To be used for delay differential equations. See \link{timelags}, \link{dede} for more information. } \item{... }{additional arguments passed to \code{func} and \code{jacfunc} allowing this to be a generic function. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the FORTRAN routine `lsode' returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{Karline Soetaert } \examples{ ## ======================================================================= ## Example 1: ## Various ways to solve the same model. ## ======================================================================= ## the model, 5 state variables f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } ## the Jacobian, written as a full matrix fulljac <- function (t, y, parms) { jac <- matrix(nrow = 5, ncol = 5, byrow = TRUE, data = c(0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1)) return(jac) } ## the Jacobian, written in banded form bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } ## initial conditions and output times yini <- 1:5 times <- 1:20 ## default: stiff method, internally generated, full Jacobian out <- lsode(yini, times, f1, parms = 0, jactype = "fullint") ## stiff method, user-generated full Jacobian out2 <- lsode(yini, times, f1, parms = 0, jactype = "fullusr", jacfunc = fulljac) ## stiff method, internally-generated banded Jacobian ## one nonzero band above (up) and below(down) the diagonal out3 <- lsode(yini, times, f1, parms = 0, jactype = "bandint", bandup = 1, banddown = 1) ## stiff method, user-generated banded Jacobian out4 <- lsode(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) ## non-stiff method out5 <- lsode(yini, times, f1, parms = 0, mf = 10) ## ======================================================================= ## Example 2: ## diffusion on a 2-D grid ## partially specified Jacobian ## ======================================================================= diffusion2D <- function(t, Y, par) { y <- matrix(nrow = n, ncol = n, data = Y) dY <- r*y # production ## diffusion in X-direction; boundaries = 0-concentration Flux <- -Dx * rbind(y[1,],(y[2:n,]-y[1:(n-1),]),-y[n,])/dx dY <- dY - (Flux[2:(n+1),]-Flux[1:n,])/dx ## diffusion in Y-direction Flux <- -Dy * cbind(y[,1],(y[,2:n]-y[,1:(n-1)]),-y[,n])/dy dY <- dY - (Flux[,2:(n+1)]-Flux[,1:n])/dy return(list(as.vector(dY))) } ## parameters dy <- dx <- 1 # grid size Dy <- Dx <- 1 # diffusion coeff, X- and Y-direction r <- 0.025 # production rate times <- c(0, 1) n <- 50 y <- matrix(nrow = n, ncol = n, 0) pa <- par(ask = FALSE) ## initial condition for (i in 1:n) { for (j in 1:n) { dst <- (i - n/2)^2 + (j - n/2)^2 y[i, j] <- max(0, 1 - 1/(n*n) * (dst - n)^2) } } filled.contour(y, color.palette = terrain.colors) ## ======================================================================= ## jacfunc need not be estimated exactly ## a crude approximation, with a smaller bandwidth will do. ## Here the half-bandwidth 1 is used, whereas the true ## half-bandwidths are equal to n. ## This corresponds to ignoring the y-direction coupling in the ODEs. ## ======================================================================= print(system.time( for (i in 1:20) { out <- lsode(func = diffusion2D, y = as.vector(y), times = times, parms = NULL, jactype = "bandint", bandup = 1, banddown = 1) filled.contour(matrix(nrow = n, ncol = n, out[2,-1]), zlim = c(0,1), color.palette = terrain.colors, main = i) y <- out[2, -1] } )) par(ask = pa) } \references{ Alan C. Hindmarsh, "ODEPACK, A Systematized Collection of ODE Solvers," in Scientific Computing, R. S. Stepleman, et al., Eds. (North-Holland, Amsterdam, 1983), pp. 55-64. } \details{ The work is done by the FORTRAN subroutine \code{lsode}, whose documentation should be consulted for details (it is included as comments in the source file \file{src/opkdmain.f}). The implementation is based on the November, 2003 version of lsode, from Netlib. Before using the integrator \code{lsode}, the user has to decide whether or not the problem is stiff. If the problem is nonstiff, use method flag \code{mf} = 10, which selects a nonstiff (Adams) method, no Jacobian used.\cr If the problem is stiff, there are four standard choices which can be specified with \code{jactype} or \code{mf}. The options for \bold{jactype} are \describe{ \item{jactype = "fullint"}{a full Jacobian, calculated internally by lsode, corresponds to \code{mf} = 22, } \item{jactype = "fullusr"}{a full Jacobian, specified by user function \code{jacfunc}, corresponds to \code{mf} = 21, } \item{jactype = "bandusr"}{a banded Jacobian, specified by user function \code{jacfunc}; the size of the bands specified by \code{bandup} and \code{banddown}, corresponds to \code{mf} = 24, } \item{jactype = "bandint"}{a banded Jacobian, calculated by lsode; the size of the bands specified by \code{bandup} and \code{banddown}, corresponds to \code{mf} = 25. } } More options are available when specifying \bold{mf} directly. \cr The legal values of \code{mf} are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, 25.\cr \code{mf} is a positive two-digit integer, \code{mf} = (10*METH + MITER), where \describe{ \item{METH}{indicates the basic linear multistep method: METH = 1 means the implicit Adams method. METH = 2 means the method based on backward differentiation formulas (BDF-s). } \item{MITER}{indicates the corrector iteration method: MITER = 0 means functional iteration (no Jacobian matrix is involved). MITER = 1 means chord iteration with a user-supplied full (NEQ by NEQ) Jacobian. MITER = 2 means chord iteration with an internally generated (difference quotient) full Jacobian (using NEQ extra calls to \code{func} per df/dy value). MITER = 3 means chord iteration with an internally generated diagonal Jacobian approximation (using 1 extra call to \code{func} per df/dy evaluation). MITER = 4 means chord iteration with a user-supplied banded Jacobian. MITER = 5 means chord iteration with an internally generated banded Jacobian (using ML+MU+1 extra calls to \code{func} per df/dy evaluation).} } If MITER = 1 or 4, the user must supply a subroutine \code{jacfunc}. Inspection of the example below shows how to specify both a banded and full Jacobian. The input parameters \code{rtol}, and \code{atol} determine the \bold{error control} performed by the solver. See \code{\link{lsoda}} for details. The diagnostics of the integration can be printed to screen by calling \code{\link{diagnostics}}. If \code{verbose} = \code{TRUE}, the diagnostics will written to the screen at the end of the integration. See vignette("deSolve") for an explanation of each element in the vectors containing the diagnostic properties and how to directly access them. \bold{Models} may be defined in compiled C or FORTRAN code, as well as in an R-function. See package vignette \code{"compiledCode"} for details. More information about models defined in compiled code is in the package vignette ("compiledCode"); information about linking forcing functions to compiled code is in \link{forcings}. Examples in both C and FORTRAN are in the \file{dynload} subdirectory of the \code{deSolve} package directory. \code{lsode} can find the root of at least one of a set of constraint functions \code{rootfunc} of the independent and dependent variables. It then returns the solution at the root if that occurs sooner than the specified stop condition, and otherwise returns the solution according the specified stop condition. Caution: Because of numerical errors in the function \code{rootfun} due to roundoff and integration error, \code{lsode} may return false roots, or return the same root at two or more nearly equal values of \code{time}. } \seealso{ \itemize{ \item \code{\link{rk}}, \item \code{\link{rk4}} and \code{\link{euler}} for Runge-Kutta integrators. \item \code{\link{lsoda}}, \code{\link{lsodes}}, \code{\link{lsodar}}, \code{\link{vode}}, \code{\link{daspk}} for other solvers of the Livermore family, \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/DLLres.Rd0000644000176000001440000000771313136461014014101 0ustar ripleyusers\name{DLLres} \alias{DLLres} \title{Evaluates a Residual Derivative Function Represented in a DLL } \description{ Calls a residual function, \eqn{F(t,y,y')} of a DAE system (differential algebraic equations) defined in a compiled language as a DLL. To be used for testing the implementation of DAE problems in compiled code } \usage{DLLres(res, times, y, dy, parms, dllname, initfunc = dllname, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL) } \arguments{ \item{res }{the name of the function in the dynamically loaded shared library, } \item{times }{first value = the time at which the function needs to be evaluated, } \item{y }{the values of the dependent variables for which the function needs to be evaluated, } \item{dy }{the derivative of the values of the dependent variables for which the function needs to be evaluated, } \item{parms }{the parameters that are passed to the initialiser function, } \item{dllname }{a string giving the name of the shared library (without extension) that contains the compiled function or subroutine definitions referred to in \code{func}, } \item{initfunc }{if not NULL, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See details, } \item{rpar }{a vector with double precision values passed to the DLL-function \code{func} and \code{jacfunc} present in the DLL, via argument \code{rpar}, } \item{ipar }{a vector with integer values passed to the DLL-function \code{func} and \code{jacfunc} present in the DLL, via function argument \code{ipar}, } \item{nout }{the number of output variables. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See package vignette \code{"compiledCode"}. } } \value{ a list containing: \item{res }{the residual of derivative estimated by the function} \item{var }{the ordinary output variables of the function} } \details{ This function is meant to help developing FORTRAN or C models that are to be used to solve differential algebraic equations (DAE) in package \code{deSolve}. } \author{Karline Soetaert } \keyword{utilities} \examples{ ## ========================================================================= ## Residuals from the daspk chemical model, production a forcing function ## ========================================================================= ## Parameter values and initial conditions ## see example(daspk) for a more comprehensive implementation pars <- c(K = 1, ka = 1e6, r = 1) ## Initial conc; D is in equilibrium with A,B y <- c(A = 2, B = 3, D = 2 * 3/pars["K"]) ## Initial rate of change dy <- c(dA = 0, dB = 0, dD = 0) ## production increases with time prod <- matrix(ncol = 2, data = c(seq(0, 100, by = 10), seq(0.1, 0.5, len = 11))) DLLres(y = y, dy = dy, times = 5, res = "chemres", dllname = "deSolve", initfunc = "initparms", initforc = "initforcs", parms = pars, forcings = prod, nout = 2, outnames = c("CONC", "Prod")) } \seealso{ \link{daspk} to solve DAE problems } deSolve/man/cleanEventTimes.Rd0000644000176000001440000000402013136461014016026 0ustar ripleyusers\name{cleanEventTimes} \alias{cleanEventTimes} \alias{nearestEvent} \title{ Find Nearest Event for Each Time Step and Clean Time Steps to Avoid Doubles } \description{ These functions can be used for checking time steps and events used by ode solver functions. They are normally called internally within the solvers. } \usage{ nearestEvent(times, eventtimes) cleanEventTimes(times, eventtimes, eps = .Machine$double.eps * 10) } \arguments{ \item{times}{the vector of output times,} \item{eventtimes}{a vector with the event times,} \item{eps}{relative tolerance value below which two numbers are assumed to be numerically equal.} } \details{ In floating point arithmetics, problems can occur if values have to be compared for 'equality' but are only close to each other and not exactly the same. The utility functions can be used to add all \code{eventtimes} to the output \code{times} vector, but without including times that are very close to an event. This means that all values of \code{eventtimes} are contained but only the subset of \code{times} that have no close neighbors in \code{eventtimes}. These checks are normally performed internally by the integration solvers. } \value{ \code{nearestEvent} returns a vector with the closest events for each time step and \code{cleanEventTimes} returns a vector with the output times without all those that are 'very close' to an event. } \author{ Thomas Petzoldt } \seealso{ \code{\link{events}} } \examples{ events <- sort(c(0, 2, 3, 4 + 1e-10, 5, 7 - 1e-10, 7 + 6e-15, 7.5, 9, 24.9999, 25, 80, 1001, 1e300)) times <- sort(c(0, 1:7, 4.5, 6.75, 7.5, 9.2, 9.0001, 25, 879, 1e3, 1e300+5)) nearest <- nearestEvent(times, events) data.frame(times=times, nearest = nearest) ## typical usage: include all events in times after removing values that ## are numerically close together, events have priority times unique_times <- cleanEventTimes(times, events) newtimes <- sort(c(unique_times, events)) newtimes } \keyword{ misc } deSolve/man/ode.3D.Rd0000644000176000001440000002043713136461014013766 0ustar ripleyusers\name{ode.3D} \alias{ode.3D} \title{Solver for 3-Dimensional Ordinary Differential Equations} \description{ Solves a system of ordinary differential equations resulting from 3-Dimensional partial differential equations that have been converted to ODEs by numerical differencing. } \usage{ode.3D(y, times, func, parms, nspec = NULL, dimens, method = c("lsodes", "euler", "rk4", "ode23", "ode45", "adams", "iteration"), names = NULL, cyclicBnd = NULL, ...)} \arguments{ \item{y }{the initial (state) values for the ODE system, a vector. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the model definition) at time \code{t}, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms, ...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; \code{...} (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. } \item{parms }{parameters passed to \code{func}.} \item{nspec }{the number of \bold{species} (components) in the model.} \item{dimens}{3-valued vector with the number of \bold{boxes} in three dimensions in the model. } \item{names }{the names of the components; used for plotting. } \item{cyclicBnd }{if not \code{NULL} then a number or a 3-valued vector with the dimensions where a cyclic boundary is used - \code{1}: x-dimension, \code{2}: y-dimension; \code{3}: z-dimension. } \item{method }{the integrator. Use \code{"lsodes"} if the model is very stiff; "impAdams" may be best suited for mildly stiff problems; \code{"euler", "rk4", "ode23", "ode45", "adams"} are most efficient for non-stiff problems. Also allowed is to pass an integrator \code{function}. Use one of the other Runge-Kutta methods via \code{rkMethod}. For instance, \code{method = rkMethod("ode45ck")} will trigger the Cash-Karp method of order 4(5). Method \code{"iteration"} is special in that here the function \code{func} should return the new value of the state variables rather than the rate of change. This can be used for individual based models, for difference equations, or in those cases where the integration is performed within \code{func}) } \item{... }{additional arguments passed to \code{lsodes}.} } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in times and as many columns as elements in \code{y} plus the number of "global" values returned in the second element of the return from \code{func}, plus an additional column (the first) for the time value. There will be one row for each element in \code{times} unless the integrator returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. The output will have the attributes \code{istate}, and \code{rstate}, two vectors with several useful elements. The first element of istate returns the conditions under which the last call to the integrator returned. Normal is \code{istate = 2}. If \code{verbose = TRUE}, the settings of istate and rstate will be written to the screen. See the help for the selected integrator for details. } \note{ It is advisable though not mandatory to specify \bold{both} \code{nspec} and \code{dimens}. In this case, the solver can check whether the input makes sense (as \code{nspec*dimens[1]*dimens[2]*dimens[3] == length(y)}). Do \bold{not} use this method for problems that are not 3D! } \author{Karline Soetaert } \examples{ ## ======================================================================= ## Diffusion in 3-D; imposed boundary conditions ## ======================================================================= diffusion3D <- function(t, Y, par) { ## function to bind two matrices to an array mbind <- function (Mat1, Array, Mat2, along = 1) { dimens <- dim(Array) + c(0, 0, 2) if (along == 3) array(dim = dimens, data = c(Mat1, Array, Mat2)) else if (along == 1) aperm(array(dim = dimens, data=c(Mat1, aperm(Array, c(3, 2, 1)), Mat2)), c(3, 2, 1)) else if (along == 2) aperm(array(dim = dimens, data = c(Mat1, aperm(Array, c(1, 3, 2)), Mat2)), c(1, 3, 2)) } yy <- array(dim=c(n, n, n), data = Y) # vector to 3-D array dY <- -r*yy # consumption BND <- matrix(nrow = n, ncol = n, data = 1) # boundary concentration ## diffusion in x-direction ## new array including boundary concentrations in X-direction BNDx <- mbind(BND, yy, BND, along = 1) ## diffusive Flux Flux <- -Dx * (BNDx[2:(n+2),,] - BNDx[1:(n+1),,])/dx ## rate of change = - flux gradient dY[] <- dY[] - (Flux[2:(n+1),,] - Flux[1:n,,])/dx ## diffusion in y-direction BNDy <- mbind(BND, yy, BND, along = 2) Flux <- -Dy * (BNDy[,2:(n+2),] - BNDy[,1:(n+1),])/dy dY[] <- dY[] - (Flux[,2:(n+1),] - Flux[,1:n,])/dy ## diffusion in z-direction BNDz <- mbind(BND, yy, BND, along = 3) Flux <- -Dz * (BNDz[,,2:(n+2)] - BNDz[,,1:(n+1)])/dz dY[] <- dY[] - (Flux[,,2:(n+1)] - Flux[,,1:n])/dz return(list(as.vector(dY))) } ## parameters dy <- dx <- dz <-1 # grid size Dy <- Dx <- Dz <-1 # diffusion coeff, X- and Y-direction r <- 0.025 # consumption rate n <- 10 y <- array(dim=c(n,n,n),data=10.) ## use lsodes, the default (for n>20, Runge-Kutta more efficient) print(system.time( RES <- ode.3D(y, func = diffusion3D, parms = NULL, dimens = c(n, n, n), times = 1:20, lrw = 120000, atol = 1e-10, rtol = 1e-10, verbose = TRUE) )) y <- array(dim = c(n, n, n), data = RES[nrow(RES), -1]) filled.contour(y[, , n/2], color.palette = terrain.colors) summary(RES) \dontrun{ for (i in 2:nrow(RES)) { y <- array(dim=c(n,n,n),data=RES[i,-1]) filled.contour(y[,,n/2],main=i,color.palette=terrain.colors) } } } \details{ This is the method of choice for 3-dimensional models, that are only subjected to transport between adjacent layers. Based on the dimension of the problem, the method first calculates the sparsity pattern of the Jacobian, under the assumption that transport is only occurring between adjacent layers. Then \code{lsodes} is called to solve the problem. As \code{lsodes} is used to integrate, it will probably be necessary to specify the length of the real work array, \code{lrw}. Although a reasonable guess of \code{lrw} is made, it is likely that this will be too low. In this case, \code{ode.2D} will return with an error message telling the size of the work array actually needed. In the second try then, set \code{lrw} equal to this number. For instance, if you get the error: \preformatted{ DLSODES- RWORK length is insufficient to proceed. Length needed is .ge. LENRW (=I1), exceeds LRW (=I2) In above message, I1 = 27627 I2 = 25932 } set \code{lrw} equal to 27627 or a higher value. See \link{lsodes} for the additional options. } \seealso{ \itemize{ \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for integrating models with a banded Jacobian \item \code{\link{ode.1D}} for integrating 1-D models \item \code{\link{ode.2D}} for integrating 2-D models \item \code{\link{lsodes}} for the integration options. } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/aquaphy.Rd0000644000176000001440000001530013136461014014413 0ustar ripleyusers\name{aquaphy} \alias{aquaphy} \title{A Physiological Model of Unbalanced Algal Growth} \description{A phytoplankton model with uncoupled carbon and nitrogen assimilation as a function of light and Dissolved Inorganic Nitrogen (DIN) concentration. Algal biomass is described via 3 different state variables: \itemize{ \item low molecular weight carbohydrates (LMW), the product of photosynthesis, \item storage molecules (RESERVE) and \item the biosynthetic and photosynthetic apparatus (PROTEINS). } All algal state variables are expressed in \eqn{\rm mmol\, C\, m^{-3}}{mmol C / m^3}. Only proteins contain nitrogen and chlorophyll, with a fixed stoichiometric ratio. As the relative amount of proteins changes in the algae, so does the N:C and the Chl:C ratio. An additional state variable, dissolved inorganic nitrogen (DIN) has units of \eqn{\rm mmol\, N\, m^{-3}}{mmol N / m^3}. The algae grow in a dilution culture (chemostat): there is constant inflow of DIN and outflow of culture water, including DIN and algae, at the same rate. Two versions of the model are included. \itemize{ \item In the default model, there is a day-night illumination regime, i.e. the light is switched on and off at fixed times (where the sum of illuminated + dark period = 24 hours). \item In another version, the light is imposed as a forcing function data set. } This model is written in \code{FORTRAN}. } \usage{aquaphy(times, y, parms, PAR = NULL, ...)} \arguments{ \item{times}{time sequence for which output is wanted; the first value of times must be the initial time,} \item{y}{the initial (state) values ("DIN", "PROTEIN", "RESERVE", "LMW"), in that order,} \item{parms }{vector or list with the aquaphy model parameters; see the example for the order in which these have to be defined.} \item{PAR }{a data set of the photosynthetically active radiation (light intensity), if \code{NULL}, on-off PAR is used, } \item{...}{any other parameters passed to the integrator \code{ode} (which solves the model).} } \author{Karline Soetaert } \examples{ ## ====================================================== ## ## Example 1. PAR an on-off function ## ## ====================================================== ## ----------------------------- ## the model parameters: ## ----------------------------- parameters <- c(maxPhotoSynt = 0.125, # mol C/mol C/hr rMortPHY = 0.001, # /hr alpha = -0.125/150, # uEinst/m2/s/hr pExudation = 0.0, # - maxProteinSynt = 0.136, # mol C/mol C/hr ksDIN = 1.0, # mmol N/m3 minpLMW = 0.05, # mol C/mol C maxpLMW = 0.15, # mol C/mol C minQuotum = 0.075, # mol C/mol C maxStorage = 0.23, # /h respirationRate= 0.0001, # /h pResp = 0.4, # - catabolismRate = 0.06, # /h dilutionRate = 0.01, # /h rNCProtein = 0.2, # mol N/mol C inputDIN = 10.0, # mmol N/m3 rChlN = 1, # g Chl/mol N parMean = 250., # umol Phot/m2/s dayLength = 15. # hours ) ## ----------------------------- ## The initial conditions ## ----------------------------- state <- c(DIN = 6., # mmol N/m3 PROTEIN = 20.0, # mmol C/m3 RESERVE = 5.0, # mmol C/m3 LMW = 1.0) # mmol C/m3 ## ----------------------------- ## Running the model ## ----------------------------- times <- seq(0, 24*20, 1) out <- as.data.frame(aquaphy(times, state, parameters)) ## ----------------------------- ## Plotting model output ## ----------------------------- par(mfrow = c(2, 2), oma = c(0, 0, 3, 0)) col <- grey(0.9) ii <- 1:length(out$PAR) plot(times[ii], out$Chlorophyll[ii], type = "l", main = "Chlorophyll", xlab = "time, hours",ylab = "ug/l") polygon(times[ii], out$PAR[ii]-10, col = col, border = NA); box() lines(times[ii], out$Chlorophyll[ii], lwd = 2 ) plot (times[ii], out$DIN[ii], type = "l", main = "DIN", xlab = "time, hours",ylab = "mmolN/m3") polygon(times[ii], out$PAR[ii]-10, col = col, border = NA); box() lines(times[ii], out$DIN[ii], lwd = 2 ) plot (times[ii], out$NCratio[ii], type = "n", main = "NCratio", xlab = "time, hours", ylab = "molN/molC") polygon(times[ii], out$PAR[ii]-10, col = col, border = NA); box() lines(times[ii], out$NCratio[ii], lwd = 2 ) plot (times[ii], out$PhotoSynthesis[ii],type = "l", main = "PhotoSynthesis", xlab = "time, hours", ylab = "mmolC/m3/hr") polygon(times[ii], out$PAR[ii]-10, col = col, border = NA); box() lines(times[ii], out$PhotoSynthesis[ii], lwd = 2 ) mtext(outer = TRUE, side = 3, "AQUAPHY, PAR= on-off", cex = 1.5) ## ----------------------------- ## Summary model output ## ----------------------------- t(summary(out)) ## ====================================================== ## ## Example 2. PAR a forcing function data set ## ## ====================================================== times <- seq(0, 24*20, 1) ## ----------------------------- ## create the forcing functions ## ----------------------------- ftime <- seq(0,500,by=0.5) parval <- pmax(0,250 + 350*sin(ftime*2*pi/24)+ (runif(length(ftime))-0.5)*250) Par <- matrix(nc=2,c(ftime,parval)) state <- c(DIN = 6., # mmol N/m3 PROTEIN = 20.0, # mmol C/m3 RESERVE = 5.0, # mmol C/m3 LMW = 1.0) # mmol C/m3 out <- aquaphy(times, state, parameters, Par) plot(out, which = c("PAR", "Chlorophyll", "DIN", "NCratio"), xlab = "time, hours", ylab = c("uEinst/m2/s", "ug/l", "mmolN/m3", "molN/molC")) mtext(outer = TRUE, side = 3, "AQUAPHY, PAR=forcing", cex = 1.5) # Now all variables plotted in one figure... plot(out, which = 1:9, type = "l") par(mfrow = c(1, 1)) } \references{ Lancelot, C., Veth, C. and Mathot, S. (1991). Modelling ice-edge phytoplankton bloom in the Scotia-Weddel sea sector of the Southern Ocean during spring 1988. Journal of Marine Systems 2, 333--346. Soetaert, K. and Herman, P. (2008). A practical guide to ecological modelling. Using R as a simulation platform. Springer. } \details{ The model is implemented primarily to demonstrate the linking of FORTRAN with \R-code. The source can be found in the \file{doc/examples/dynload} subdirectory of the package. } \seealso{ \code{\link{ccl4model}}, the CCl4 inhalation model. } \keyword{models} deSolve/man/diagnostics.Rd0000644000176000001440000000207113136461014015253 0ustar ripleyusers\name{diagnostics} \alias{diagnostics} \alias{diagnostics.default} \title{Print Diagnostic Characteristics of Solvers} \description{ Prints several diagnostics of the simulation to the screen, e.g. number of steps taken, the last step size, ... } \usage{ diagnostics(obj, ...) \method{diagnostics}{default}(obj, ...) } \arguments{ \item{obj}{is an output data structure produced by one of the solver routines. } \item{...}{optional arguments allowing to extend \code{diagnostics} as a generic function. } } \details{ Detailed information obout the success of a simulation is printed, if a \code{diagnostics} function exists for a specific solver routine. A warning is printed, if no class-specific diagnostics exists. Please consult the class-specific help page for details. } \seealso{ \code{\link{diagnostics.deSolve}} for diagnostics of differential equaton solvers. %% enable this when bvpSolve is on CRAN % \code{\link[bvpSolve:diagnostics]{diagnostics.bvpSolve}} for % diagnostics of boundary value problem solvers. } \keyword{ utilities }deSolve/man/events.Rd0000644000176000001440000003022213136461014014247 0ustar ripleyusers\name{events} \alias{events} \alias{roots} \title{ Implementing Events and Roots in Differential Equation Models. } \description{ An \code{event} occurs when the value of a state variable is suddenly changed, e.g. because a value is added, subtracted, or multiplied. The integration routines cannot deal easily with such state variable changes. Typically these events occur only at specific times. In \code{deSolve}, events can be imposed by means of an input data.frame, that specifies at which time and how a certain state variable is altered, or via an event function. Roots occur when a root function becomes zero. By default when a root is found, the simulation either stops (no event), or triggers an event. } \details{ The \code{events} are specified by means of argument \code{events} passed to the integration routines. \code{events} should be a list that contains one of the following: \enumerate{ \item{func: }{an R-function or the name of a function in compiled code that specifies the event, } \item{data: }{a data.frame that specifies the state variables, times, values and types of the events. Note that the event times must also be part of the integration output times, else the event will not take place. As from version 1.9.1, this is checked by the solver, and a warning message is produced if event times are missing in times; see also \code{\link{cleanEventTimes}} for utility functions to check and solve such issues. } \item{time: }{when events are specified by an event function: the times at which the events take place. Note that these event times must also be part of the integration output times exactly, else the event would not take place. As from version 1.9.1 this is checked by the solver, and an error message produced if event times are missing in times; see also \code{\link{cleanEventTimes}} for utility functions to check and solve such issues. } \item{root: }{when events are specified by a function and triggered by a root, this logical should be set equal to \code{TRUE} } \item{terminalroot }{when events are triggered by a root, the default is that the simulation continues after the event is executed. In \code{terminalroot}, we can specify which roots should terminate the simulation. } \item{maxroot: }{when \code{root = TRUE}, the maximal number of times at with a root is found and that are kept; defaults to 100. If the number of roots > \code{maxroot}, then only the first \code{maxroot} will be outputted. } \item{ties: }{if events, as specified by a data.frame are "ordered", set to "ordered", the default is "notordered". This will save some computational time. } } In case the events are specified by means of an \R \bold{function} (argument \code{events$func}), it must be defined as: \code{function(t, y, parms, ...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{events$func}. \code{parms} is a vector or list of parameters; \code{...} (optional) are any other arguments passed to the function via the call to the integration method. The event function should return the y-values (some of which modified), as a \emph{vector}. If \code{events$func} is a string, this indicates that the events are specified by a \code{function} in compiled code. This function has as arguments, the number of state variables, the time, and the state variable vector. See package vignette "compiledCode" for more details. In case events are specified by an \R-function, this requires either: input of the \emph{time} of the events, a vector as defined in \code{events$time} OR the specification of a \emph{root} function. In the latter case, the model must be solved with an integration routine with root-finding capability The root function itself should be specified with argument \code{rootfunc}. In this case, the integrator is informed that the simulation it to be continued after a root is found by setting \code{events$root} equal to \code{TRUE}. If the events are specified by a \bold{data frame} (argument \code{events$data}), this should contain the following columns (and in that order): \enumerate{ \item{var }{the state variable \emph{name} or \emph{number} that is affected by the event} \item{time }{the time at which the event is to take place; the solvers will check if the time is embraced by the simulation time} \item{value }{the value, magnitude of the event} \item{method }{which event is to take place; should be one of ("replace", "add", "multiply"); also allowed is to specify the number (1 = replace, 2 = add, 3 = multiply) } } For instance, the following line \code{"v1" 10 2 "add"} will cause the value 2 to be added to a state variable, called \code{"v1"} at \code{time = 10}. From deSolve version 1.9.1 the following routines have \bold{root-finding} capability: \link{lsoda}, \link{lsode}, \link{lsodes}, and \link{radau}. For the first 3 integration methods, the root finding algorithm is based on the algorithm in solver LSODAR, and is implemented in FORTRAN. For radau, the root solving algorithm is written in C-code, and it works slightly different. Thus, some problems involving roots may be more efficiently solved with either lsoda, lsode, or lsodes, while other problems are more efficiently solved with radau. If a root function is defined, but not an event function, then by default the solver will stop at a root. If this is not desirable, e.g. because we want to record the position of many roots, then a dummy "event" function can be defined which returns the values of the state variables - unaltered. If roots and events are combined, and roots are found, then the output will have attribute \code{troot} which will contain the \code{times} at which a root was found (and the event trigerred). There will be at most \code{events$maxroot} such values. The default is 100. See two last examples; also see example of \code{\link{ccl4model}}. } \author{ Karline Soetaert } \seealso{ \link{forcings}, for how to implement forcing functions. \link{lsodar}, for more examples of roots } \examples{ ## ============================================================================= ## 1. EVENTS in a data.frame ## ============================================================================= ## derivative function: derivatives set to 0 derivs <- function(t, var, parms) { list(dvar = rep(0, 2)) } yini <- c(v1 = 1, v2 = 2) times <- seq(0, 10, by = 0.1) eventdat <- data.frame(var = c("v1", "v2", "v2", "v1"), time = c(1, 1, 5, 9) , value = c(1, 2, 3, 4), method = c("add", "mult", "rep", "add")) eventdat out <- vode(func = derivs, y = yini, times = times, parms = NULL, events = list(data = eventdat)) plot(out) ## eventdat <- data.frame(var = c(rep("v1", 10), rep("v2", 10)), time = c(1:10, 1:10), value = runif(20), method = rep("add", 20)) eventdat out <- ode(func = derivs, y = yini, times = times, parms = NULL, events = list(data = eventdat)) plot(out) ## ============================================================================= ## 2. EVENTS in a function ## ============================================================================= ## derivative function: rate of change v1 = 0, v2 reduced at first-order rate derivs <- function(t, var, parms) { list(c(0, -0.5 * var[2])) } # events: add 1 to v1, multiply v2 with random number eventfun <- function(t, y, parms){ with (as.list(y),{ v1 <- v1 + 1 v2 <- 5 * runif(1) return(c(v1, v2)) }) } yini <- c(v1 = 1, v2 = 2) times <- seq(0, 10, by = 0.1) out <- ode(func = derivs, y = yini, times = times, parms = NULL, events = list(func = eventfun, time = c(1:9, 2.2, 2.4)) ) plot(out, type = "l") ## ============================================================================= ## 3. EVENTS triggered by a root function ## ============================================================================= ## derivative: simple first-order decay derivs <- function(t, y, pars) { return(list(-0.1 * y)) } ## event triggered if state variable = 0.5 rootfun <- function (t, y, pars) { return(y - 0.5) } ## sets state variable = 1 eventfun <- function(t, y, pars) { return(y = 1) } yini <- 2 times <- seq(0, 100, 0.1) ## uses ode to solve; root = TRUE specifies that the event is ## triggered by a root. out <- ode(times = times, y = yini, func = derivs, parms = NULL, events = list(func = eventfun, root = TRUE), rootfun = rootfun) plot(out, type = "l") ## time of the root: troot <- attributes(out)$troot points(troot, rep(0.5, length(troot))) ## ============================================================================= ## 4. More ROOT examples: Rotation function ## ============================================================================= Rotate <- function(t, x, p ) list(c( x[2], -x[1] )) ## Root = when second state variable = 0 rootfun <- function(t, x, p) x[2] ## "event" returns state variables unchanged eventfun <- function(t, x, p) x times <- seq(from = 0, to = 15, by = 0.1) ## 1. No event: stops at first root out1 <- ode(func = Rotate, y = c(5, 5), parms = 0, times = times, rootfun = rootfun) tail(out1) ## 2. Continues till end of times and records the roots out <- ode(func = Rotate, y = c(5, 5), parms = 0, times = times, rootfun = rootfun, events = list(func = eventfun, root = TRUE) ) plot(out) troot <- attributes(out)$troot # time of roots points(troot,rep(0, length (troot))) ## Multiple roots: either one of the state variables = 0 root2 <- function(t, x, p) x out2 <- ode(func = Rotate, y = c(5, 5), parms = 0, times = times, rootfun = root2, events = list(func = eventfun, root = TRUE) ) plot(out2, which = 2) troot <- attributes(out2)$troot indroot <- attributes(out2)$indroot # which root was found points(troot, rep(0, length (troot)), col = indroot, pch = 18, cex = 2) ## Multiple roots and stop at first time root 1. out3 <- ode(func = Rotate, y = c(5, 5), parms = 0, times = times, rootfun = root2, events = list(func = eventfun, root = TRUE, terminalroot = 1)) ## ============================================================================= ## 5. Stop at 5th root - only works with radau. ## ============================================================================= Rotate <- function(t, x, p ) list(c( x[2], -x[1], 0 )) ## Root = when second state variable = 0 root3 <- function(t, x, p) c(x[2], x[3] - 5) event3 <- function (t, x, p) c(x[1:2], x[3]+1) times <- seq(0, 15, 0.1) out3 <- ode(func = Rotate, y = c(x1 = 5, x2 = 5, nroot = 0), parms = 0, method = "radau", times = times, rootfun = root3, events = list(func = event3, root = TRUE, terminalroot = 2)) plot(out3) attributes(out3)[c("troot", "nroot", "indroot")] ## ============================================================================= ## 6 Event in R-code, model function in compiled code - based on vode example ## ============================================================================= times <- 1:365 Flux <- cbind(times, sin(pi*times/365)^2) # forcing function # run without events out <- ode(y = c(C = 1), times, func = "scocder", parms = c(k=0.01), dllname = "deSolve", initforc = "scocforc", forcings = Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation", "Depo")) # Event halves the concentration EventMin <- function(t, y , p) y/2 out2 <- ode(y = c(C = 1), times, func = "scocder", parms = c(k=0.01), dllname = "deSolve", initforc = "scocforc", forcings = Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation", "Depo"), events = list (func = EventMin, time = c(50.1, 200, 210.5))) plot(out, out2) } \keyword{utilities}deSolve/DESCRIPTION0000644000176000001440000000656113603425022013416 0ustar ripleyusersPackage: deSolve Version: 1.27.1 Title: Solvers for Initial Value Problems of Differential Equations ('ODE', 'DAE', 'DDE') Authors@R: c(person("Karline","Soetaert", role = c("aut"), email = "karline.soetaert@nioz.nl", comment = c(ORCID = "0000-0003-4603-7100")), person("Thomas","Petzoldt", role = c("aut", "cre"), email = "thomas.petzoldt@tu-dresden.de", comment = c(ORCID = "0000-0002-4951-6468")), person("R. Woodrow","Setzer", role = c("aut"), email = "setzer.woodrow@epa.gov", comment = c(ORCID = "0000-0002-6709-9186")), person("Peter N.","Brown", role = "ctb", comment = "files ddaspk.f, dvode.f, zvode.f"), person("George D.","Byrne", role = "ctb", comment = "files dvode.f, zvode.f"), person("Ernst","Hairer", role = "ctb", comment = "files radau5.f, radau5a"), person("Alan C.","Hindmarsh", role = "ctb", comment = "files ddaspk.f, dlsode.f, dvode.f, zvode.f, opdkmain.f, opdka1.f"), person("Cleve","Moler", role = "ctb", comment = "file dlinpck.f"), person("Linda R.","Petzold", role = "ctb", comment = "files ddaspk.f, dlsoda.f"), person("Youcef", "Saad", role = "ctb", comment = "file dsparsk.f"), person("Clement W.","Ulrich", role = "ctb", comment = "file ddaspk.f") ) Author: Karline Soetaert [aut] (), Thomas Petzoldt [aut, cre] (), R. Woodrow Setzer [aut] (), Peter N. Brown [ctb] (files ddaspk.f, dvode.f, zvode.f), George D. Byrne [ctb] (files dvode.f, zvode.f), Ernst Hairer [ctb] (files radau5.f, radau5a), Alan C. Hindmarsh [ctb] (files ddaspk.f, dlsode.f, dvode.f, zvode.f, opdkmain.f, opdka1.f), Cleve Moler [ctb] (file dlinpck.f), Linda R. Petzold [ctb] (files ddaspk.f, dlsoda.f), Youcef Saad [ctb] (file dsparsk.f), Clement W. Ulrich [ctb] (file ddaspk.f) Maintainer: Thomas Petzoldt Depends: R (>= 3.3.0) Imports: methods, graphics, grDevices, stats Suggests: scatterplot3d, FME Description: Functions that solve initial value problems of a system of first-order ordinary differential equations ('ODE'), of partial differential equations ('PDE'), of differential algebraic equations ('DAE'), and of delay differential equations. The functions provide an interface to the FORTRAN functions 'lsoda', 'lsodar', 'lsode', 'lsodes' of the 'ODEPACK' collection, to the FORTRAN functions 'dvode', 'zvode' and 'daspk' and a C-implementation of solvers of the 'Runge-Kutta' family with fixed or variable time steps. The package contains routines designed for solving 'ODEs' resulting from 1-D, 2-D and 3-D partial differential equations ('PDE') that have been converted to 'ODEs' by numerical differencing. License: GPL (>= 2) URL: http://desolve.r-forge.r-project.org/ LazyData: yes NeedsCompilation: yes Packaged: 2020-01-02 15:43:34 UTC; ripley Repository: CRAN Date/Publication: 2020-01-02 17:36:18 UTC deSolve/build/0000755000176000001440000000000013576731645013023 5ustar ripleyusersdeSolve/build/vignette.rds0000644000176000001440000000051113576731645015357 0ustar ripleyusers}QAO02a4&$N2z}oKcig7 "Ca~'AhkJw@Gߵ#O8J_\4P[r _#s{aD%Tά ƕD-8> ?)2AΑ"Р9TBҚ'G3<`ۡ645;! |iM[mP`V(} 2ǩ`jQpS]S-J% mNgcc'j{NS9@ ϸZRr?vigCe٬;J%#9T0 OQideSolve/src/0000755000176000001440000000000013603407646012503 5ustar ripleyusersdeSolve/src/ex_SCOC.c0000644000176000001440000000156113136461013014062 0ustar ripleyusers/* -------- ex_SCOC.c -> ex_SCOC.dll / ex_SCOC.so ------ */ /* compile in R with: system("gcc -shared -o scoc.dll ex_SCOC.c") */ /* or with system("R CMD SHLIB ex_SCOC.c") */ /* Initialiser for parameter commons */ #include static double parms[1]; #define k parms[0] static double forcs[1]; #define depo forcs[0] void scocpar(void (* odeparms)(int *, double *)) { int N=1; odeparms(&N, parms); } /* Initialiser for forcing commons */ void scocforc(void (* odeforcs)(int *, double *)) { int N=1; odeforcs(&N, forcs); } /* Derivatives and output variable */ void scocder (int *neq, double *t, double *y, double *ydot, double *out, int *ip) { if (ip[0] <2) error("nout should be at least 2"); ydot[0] = -k*y[0] + depo; out[0]= k*y[0]; out[1]= depo; } deSolve/src/R_init_deSolve.c0000644000176000001440000001337113603407222015547 0ustar ripleyusers#ifndef R_R_H # include #endif #ifndef R_EXT_DYNLOAD_H_ # include #endif #define EXTERN #include "deSolve.h" #undef EXTERN #include #include // for NULL /* register native routines ------------------------------------------------ */ /* ToDo: - consider replacing SEXP with REALSXP, INTSXP, STRSXP (character), VEXSXP (lists) etc. - unlock */ /* .C calls */ extern void unlock_solver(); /* Examples (manually added) */ extern void initccl4(void (* odeparms)(int *, double *)); extern void eventfun(int *n, double *t, double *y); extern void derivsccl4(int *neq, double *t, double *y, double *ydot, double *out, int *ip); extern void initparms(void (* daspkparms)(int *, double *)); extern void initforcs(void (* daspkforcs)(int *, double *)); extern void chemres (double *t, double *y, double *ydot, double *cj, double *delta, int *ires, double *out, int *ip); extern void scocpar(void (* odeparms)(int *, double *)); extern void scocforc(void (* odeforcs)(int *, double *)); extern void scocder (int *neq, double *t, double *y, double *ydot, double *out, int *ip); extern void iniaqua(void (* odeparms)(int *, double *)); extern void initaqforc(void (* odeforc)(int *, double *)); extern void aquaphy (int *neq, double *t, double *y, double *ydot, double *out, int *ip); extern void aquaphyforc (int *neq, double *t, double *y, double *ydot, double *out, int *ip); /* .Call calls */ extern SEXP call_daspk(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_DLL(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_euler(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_iteration(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_lsoda(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_radau(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_rk4(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_rkAuto(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_rkFixed(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_rkImplicit(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_zvode(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP getLagDeriv(SEXP, SEXP); extern SEXP getLagValue(SEXP, SEXP); extern SEXP getTimestep(); static const R_CMethodDef CEntries[] = { {"unlock_solver", (DL_FUNC) &unlock_solver, 0}, {"initccl4", (DL_FUNC) &initccl4, 1}, {"initparms", (DL_FUNC) &initparms, 1}, {"initforcs", (DL_FUNC) &initforcs, 1}, {"eventfun", (DL_FUNC) &eventfun, 3}, {"derivsccl4", (DL_FUNC) &derivsccl4, 6}, {"chemres", (DL_FUNC) &chemres, 8}, {"scocpar", (DL_FUNC) &scocpar, 1}, {"scocforc", (DL_FUNC) &scocforc, 1}, {"scocder", (DL_FUNC) &scocder, 6}, {"iniaqua", (DL_FUNC) &iniaqua, 1}, {"initaqforc", (DL_FUNC) &initaqforc, 1}, {"aquaphy", (DL_FUNC) &aquaphy, 6}, {"aquaphyforc", (DL_FUNC) &aquaphy, 6}, {NULL, NULL, 0} }; static const R_CallMethodDef CallEntries[] = { {"call_daspk", (DL_FUNC) &call_daspk, 28}, {"call_DLL", (DL_FUNC) &call_DLL, 11}, {"call_euler", (DL_FUNC) &call_euler, 11}, {"call_iteration", (DL_FUNC) &call_iteration, 12}, {"call_lsoda", (DL_FUNC) &call_lsoda, 28}, {"call_radau", (DL_FUNC) &call_radau, 26}, {"call_rk4", (DL_FUNC) &call_rk4, 11}, {"call_rkAuto", (DL_FUNC) &call_rkAuto, 21}, {"call_rkFixed", (DL_FUNC) &call_rkFixed, 17}, {"call_rkImplicit", (DL_FUNC) &call_rkImplicit, 17}, {"call_zvode", (DL_FUNC) &call_zvode, 21}, {"getLagDeriv", (DL_FUNC) &getLagDeriv, 2}, {"getLagValue", (DL_FUNC) &getLagValue, 2}, {"getTimestep", (DL_FUNC) &getTimestep, 0}, {NULL, NULL, 0} }; /* C callable functions ---------------------------------------------------- */ SEXP get_deSolve_gparms(void); void lagvalue(double T, int* nr, int N, double* ytau); void lagderiv(double T, int* nr, int N, double* ytau); double glob_timesteps[] = {0, 0}; /* Initialization ---------------------------------------------------------- */ void R_init_deSolve(DllInfo *dll) { // thpe 2017-03-22, register entry points R_registerRoutines(dll, CEntries, CallEntries, NULL, NULL); // the following two lines protect against accidentially finding entry points R_useDynamicSymbols(dll, FALSE); // disable dynamic searching //R_forceSymbols(dll, TRUE); // entry points as R objects, not as strings /* thpe: register C callable to support compiled dede functions The direct way would be: R_RegisterCCallable("deSolve", "get_deSolve_gparms", (DL_FUNC) get_deSolve_gparms); while the following macro (taken from package Matrix) makes this more compact. */ #define RREGDEF(name) R_RegisterCCallable("deSolve", #name, (DL_FUNC) name) RREGDEF(get_deSolve_gparms); RREGDEF(lagvalue); RREGDEF(lagderiv); /* initialize global variables */ timesteps = glob_timesteps; } deSolve/src/opkdmain.f0000644000176000001440000126022013572134421014450 0ustar ripleyusersC The code in this file is was taken from C https://www.netlib.org/odepack/ C Original author: Hindmarsh, Alan C., (LLNL) C Adapted for use in R package deSolve by the deSolve authors. C *DECK DLSODE SUBROUTINE DLSODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF, 2 rpar, ipar) EXTERNAL F, JAC CKS: added rpar, ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW) C***BEGIN PROLOGUE DLSODE C***PURPOSE Livermore Solver for Ordinary Differential Equations. C DLSODE solves the initial-value problem for stiff or C nonstiff systems of first-order ODE's, C dy/dt = f(t,y), or, in component form, C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(N)), i=1,...,N. C***CATEGORY I1A C***TYPE DOUBLE PRECISION (SLSODE-S, DLSODE-D) C***KEYWORDS ORDINARY DIFFERENTIAL EQUATIONS, INITIAL VALUE PROBLEM, C STIFF, NONSTIFF C***AUTHOR Hindmarsh, Alan C., (LLNL) C Center for Applied Scientific Computing, L-561 C Lawrence Livermore National Laboratory C Livermore, CA 94551. C***DESCRIPTION C C NOTE: The "Usage" and "Arguments" sections treat only a subset of C available options, in condensed fashion. The options C covered and the information supplied will support most C standard uses of DLSODE. C C For more sophisticated uses, full details on all options are C given in the concluding section, headed "Long Description." C A synopsis of the DLSODE Long Description is provided at the C beginning of that section; general topics covered are: C - Elements of the call sequence; optional input and output C - Optional supplemental routines in the DLSODE package C - internal COMMON block C C changes by Karline Soetaert. C NOTE for inclusion in R-package: the interface to F, Res and Jac has C been changed: now a double precision and an integer vector C rpar(*) and ipar(*) is also passed. This to allow output of C ordinary output variables. C These changes have been made consistently throughout the code C including subroutines in opkda1.f C *Usage: C Communication between the user and the DLSODE package, for normal C situations, is summarized here. This summary describes a subset C of the available options. See "Long Description" for complete C details, including optional communication, nonstandard options, C and instructions for special situations. C C A sample program is given in the "Examples" section. C C Refer to the argument descriptions for the definitions of the C quantities that appear in the following sample declarations. C C For MF = 10, C PARAMETER (LRW = 20 + 16*NEQ, LIW = 20) C For MF = 21 or 22, C PARAMETER (LRW = 22 + 9*NEQ + NEQ**2, LIW = 20 + NEQ) C For MF = 24 or 25, C PARAMETER (LRW = 22 + 10*NEQ + (2*ML+MU)*NEQ, C * LIW = 20 + NEQ) C C EXTERNAL F, JAC C INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK(LIW), C * LIW, MF C DOUBLE PRECISION Y(NEQ), T, TOUT, RTOL, ATOL(ntol), RWORK(LRW) C C CALL DLSODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, C * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) C C *Arguments: C F :EXT Name of subroutine for right-hand-side vector f. C This name must be declared EXTERNAL in calling C program. The form of F must be: C C SUBROUTINE F (NEQ, T, Y, YDOT) C INTEGER NEQ C DOUBLE PRECISION T, Y(*), YDOT(*) C C The inputs are NEQ, T, Y. F is to set C C YDOT(i) = f(i,T,Y(1),Y(2),...,Y(NEQ)), C i = 1, ..., NEQ . C C NEQ :IN Number of first-order ODE's. C C Y :INOUT Array of values of the y(t) vector, of length NEQ. C Input: For the first call, Y should contain the C values of y(t) at t = T. (Y is an input C variable only if ISTATE = 1.) C Output: On return, Y will contain the values at the C new t-value. C C T :INOUT Value of the independent variable. On return it C will be the current value of t (normally TOUT). C C TOUT :IN Next point where output is desired (.NE. T). C C ITOL :IN 1 or 2 according as ATOL (below) is a scalar or C an array. C C RTOL :IN Relative tolerance parameter (scalar). C C ATOL :IN Absolute tolerance parameter (scalar or array). C If ITOL = 1, ATOL need not be dimensioned. C If ITOL = 2, ATOL must be dimensioned at least NEQ. C C The estimated local error in Y(i) will be controlled C so as to be roughly less (in magnitude) than C C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. C C Thus the local error test passes if, in each C component, either the absolute error is less than C ATOL (or ATOL(i)), or the relative error is less C than RTOL. C C Use RTOL = 0.0 for pure absolute error control, and C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative C error control. Caution: Actual (global) errors may C exceed these local tolerances, so choose them C conservatively. C C ITASK :IN Flag indicating the task DLSODE is to perform. C Use ITASK = 1 for normal computation of output C values of y at t = TOUT. C C ISTATE:INOUT Index used for input and output to specify the state C of the calculation. C Input: C 1 This is the first call for a problem. C 2 This is a subsequent call. C Output: C 1 Nothing was done, because TOUT was equal to T. C 2 DLSODE was successful (otherwise, negative). C Note that ISTATE need not be modified after a C successful return. C -1 Excess work done on this call (perhaps wrong C MF). C -2 Excess accuracy requested (tolerances too C small). C -3 Illegal input detected (see printed message). C -4 Repeated error test failures (check all C inputs). C -5 Repeated convergence failures (perhaps bad C Jacobian supplied or wrong choice of MF or C tolerances). C -6 Error weight became zero during problem C (solution component i vanished, and ATOL or C ATOL(i) = 0.). C C IOPT :IN Flag indicating whether optional inputs are used: C 0 No. C 1 Yes. (See "Optional inputs" under "Long C Description," Part 1.) C C RWORK :WORK Real work array of length at least: C 20 + 16*NEQ for MF = 10, C 22 + 9*NEQ + NEQ**2 for MF = 21 or 22, C 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25. C C LRW :IN Declared length of RWORK (in user's DIMENSION C statement). C C IWORK :WORK Integer work array of length at least: C 20 for MF = 10, C 20 + NEQ for MF = 21, 22, 24, or 25. C C If MF = 24 or 25, input in IWORK(1),IWORK(2) the C lower and upper Jacobian half-bandwidths ML,MU. C C On return, IWORK contains information that may be C of interest to the user: C C Name Location Meaning C ----- --------- ----------------------------------------- C NST IWORK(11) Number of steps taken for the problem so C far. C NFE IWORK(12) Number of f evaluations for the problem C so far. C NJE IWORK(13) Number of Jacobian evaluations (and of C matrix LU decompositions) for the problem C so far. C NQU IWORK(14) Method order last used (successfully). C LENRW IWORK(17) Length of RWORK actually required. This C is defined on normal returns and on an C illegal input return for insufficient C storage. C LENIW IWORK(18) Length of IWORK actually required. This C is defined on normal returns and on an C illegal input return for insufficient C storage. C C LIW :IN Declared length of IWORK (in user's DIMENSION C statement). C C JAC :EXT Name of subroutine for Jacobian matrix (MF = C 21 or 24). If used, this name must be declared C EXTERNAL in calling program. If not used, pass a C dummy name. The form of JAC must be: C C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) C INTEGER NEQ, ML, MU, NROWPD C DOUBLE PRECISION T, Y(*), PD(NROWPD,*) C C See item c, under "Description" below for more C information about JAC. C C MF :IN Method flag. Standard values are: C 10 Nonstiff (Adams) method, no Jacobian used. C 21 Stiff (BDF) method, user-supplied full Jacobian. C 22 Stiff method, internally generated full C Jacobian. C 24 Stiff method, user-supplied banded Jacobian. C 25 Stiff method, internally generated banded C Jacobian. C C *Description: C DLSODE solves the initial value problem for stiff or nonstiff C systems of first-order ODE's, C C dy/dt = f(t,y) , C C or, in component form, C C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) C (i = 1, ..., NEQ) . C C DLSODE is a package based on the GEAR and GEARB packages, and on C the October 23, 1978, version of the tentative ODEPACK user C interface standard, with minor modifications. C C The steps in solving such a problem are as follows. C C a. First write a subroutine of the form C C SUBROUTINE F (NEQ, T, Y, YDOT,rpar,ipar) C INTEGER NEQ,ipar(*) C DOUBLE PRECISION T, Y(*), YDOT(*),rpar(*) C C which supplies the vector function f by loading YDOT(i) with C f(i). C C b. Next determine (or guess) whether or not the problem is stiff. C Stiffness occurs when the Jacobian matrix df/dy has an C eigenvalue whose real part is negative and large in magnitude C compared to the reciprocal of the t span of interest. If the C problem is nonstiff, use method flag MF = 10. If it is stiff, C there are four standard choices for MF, and DLSODE requires the C Jacobian matrix in some form. This matrix is regarded either C as full (MF = 21 or 22), or banded (MF = 24 or 25). In the C banded case, DLSODE requires two half-bandwidth parameters ML C and MU. These are, respectively, the widths of the lower and C upper parts of the band, excluding the main diagonal. Thus the C band consists of the locations (i,j) with C C i - ML <= j <= i + MU , C C and the full bandwidth is ML + MU + 1 . C C c. If the problem is stiff, you are encouraged to supply the C Jacobian directly (MF = 21 or 24), but if this is not feasible, C DLSODE will compute it internally by difference quotients (MF = C 22 or 25). If you are supplying the Jacobian, write a C subroutine of the form C C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD,rpar,ipar) C INTEGER NEQ, ML, MU, NRWOPD,ipar(*) C DOUBLE PRECISION T, Y(*), PD(NROWPD,*),rpar(*) C C which provides df/dy by loading PD as follows: C - For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j), C the partial derivative of f(i) with respect to y(j). (Ignore C the ML and MU arguments in this case.) C - For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with C df(i)/dy(j); i.e., load the diagonal lines of df/dy into the C rows of PD from the top down. C - In either case, only nonzero elements need be loaded. C C d. Write a main program that calls subroutine DLSODE once for each C point at which answers are desired. This should also provide C for possible use of logical unit 6 for output of error messages C by DLSODE. C C Before the first call to DLSODE, set ISTATE = 1, set Y and T to C the initial values, and set TOUT to the first output point. To C continue the integration after a successful return, simply C reset TOUT and call DLSODE again. No other parameters need be C reset. C C *Examples: C The following is a simple example problem, with the coding needed C for its solution by DLSODE. The problem is from chemical kinetics, C and consists of the following three rate equations: C C dy1/dt = -.04*y1 + 1.E4*y2*y3 C dy2/dt = .04*y1 - 1.E4*y2*y3 - 3.E7*y2**2 C dy3/dt = 3.E7*y2**2 C C on the interval from t = 0.0 to t = 4.E10, with initial conditions C y1 = 1.0, y2 = y3 = 0. The problem is stiff. C C The following coding solves this problem with DLSODE, using C MF = 21 and printing results at t = .4, 4., ..., 4.E10. It uses C ITOL = 2 and ATOL much smaller for y2 than for y1 or y3 because y2 C has much smaller values. At the end of the run, statistical C quantities of interest are printed. C C EXTERNAL FEX, JEX C INTEGER IOPT, IOUT, ISTATE, ITASK, ITOL, IWORK(23), LIW, LRW, C * MF, NEQ C DOUBLE PRECISION ATOL(3), RTOL, RWORK(58), T, TOUT, Y(3) C NEQ = 3 C Y(1) = 1.D0 C Y(2) = 0.D0 C Y(3) = 0.D0 C T = 0.D0 C TOUT = .4D0 C ITOL = 2 C RTOL = 1.D-4 C ATOL(1) = 1.D-6 C ATOL(2) = 1.D-10 C ATOL(3) = 1.D-6 C ITASK = 1 C ISTATE = 1 C IOPT = 0 C LRW = 58 C LIW = 23 C MF = 21 C DO 40 IOUT = 1,12 C CALL DLSODE (FEX, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, C * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JEX, MF) C WRITE(6,20) T, Y(1), Y(2), Y(3) C 20 FORMAT(' At t =',D12.4,' y =',3D14.6) C IF (ISTATE .LT. 0) GO TO 80 C 40 TOUT = TOUT*10.D0 C WRITE(6,60) IWORK(11), IWORK(12), IWORK(13) C 60 FORMAT(/' No. steps =',i4,', No. f-s =',i4,', No. J-s =',i4) C STOP C 80 WRITE(6,90) ISTATE C 90 FORMAT(///' Error halt.. ISTATE =',I3) C STOP C END C C SUBROUTINE FEX (NEQ, T, Y, YDOT, rpar, ipar) C INTEGER NEQ, ipar(*) C DOUBLE PRECISION T, Y(3), YDOT(3), rpar(*) C YDOT(1) = -.04D0*Y(1) + 1.D4*Y(2)*Y(3) C YDOT(3) = 3.D7*Y(2)*Y(2) C YDOT(2) = -YDOT(1) - YDOT(3) C RETURN C END C C SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD, rpar, ipar) C INTEGER NEQ, ML, MU, NRPD, ipar(*) C DOUBLE PRECISION T, Y(3), PD(NRPD,3), rpar(*) C PD(1,1) = -.04D0 C PD(1,2) = 1.D4*Y(3) C PD(1,3) = 1.D4*Y(2) C PD(2,1) = .04D0 C PD(2,3) = -PD(1,3) C PD(3,2) = 6.D7*Y(2) C PD(2,2) = -PD(1,2) - PD(3,2) C RETURN C END C C The output from this program (on a Cray-1 in single precision) C is as follows. C C At t = 4.0000e-01 y = 9.851726e-01 3.386406e-05 1.479357e-02 C At t = 4.0000e+00 y = 9.055142e-01 2.240418e-05 9.446344e-02 C At t = 4.0000e+01 y = 7.158050e-01 9.184616e-06 2.841858e-01 C At t = 4.0000e+02 y = 4.504846e-01 3.222434e-06 5.495122e-01 C At t = 4.0000e+03 y = 1.831701e-01 8.940379e-07 8.168290e-01 C At t = 4.0000e+04 y = 3.897016e-02 1.621193e-07 9.610297e-01 C At t = 4.0000e+05 y = 4.935213e-03 1.983756e-08 9.950648e-01 C At t = 4.0000e+06 y = 5.159269e-04 2.064759e-09 9.994841e-01 C At t = 4.0000e+07 y = 5.306413e-05 2.122677e-10 9.999469e-01 C At t = 4.0000e+08 y = 5.494530e-06 2.197825e-11 9.999945e-01 C At t = 4.0000e+09 y = 5.129458e-07 2.051784e-12 9.999995e-01 C At t = 4.0000e+10 y = -7.170603e-08 -2.868241e-13 1.000000e+00 C C No. steps = 330, No. f-s = 405, No. J-s = 69 C C *Accuracy: C The accuracy of the solution depends on the choice of tolerances C RTOL and ATOL. Actual (global) errors may exceed these local C tolerances, so choose them conservatively. C C *Cautions: C The work arrays should not be altered between calls to DLSODE for C the same problem, except possibly for the conditional and optional C inputs. C C *Portability: C Since NEQ is dimensioned inside DLSODE, some compilers may object C to a call to DLSODE with NEQ a scalar variable. In this event, C use DIMENSION NEQ(1). Similar remarks apply to RTOL and ATOL. C C Note to Cray users: C For maximum efficiency, use the CFT77 compiler. Appropriate C compiler optimization directives have been inserted for CFT77. C C *Reference: C Alan C. Hindmarsh, "ODEPACK, A Systematized Collection of ODE C Solvers," in Scientific Computing, R. S. Stepleman, et al., Eds. C (North-Holland, Amsterdam, 1983), pp. 55-64. C C *Long Description: C The following complete description of the user interface to C DLSODE consists of four parts: C C 1. The call sequence to subroutine DLSODE, which is a driver C routine for the solver. This includes descriptions of both C the call sequence arguments and user-supplied routines. C Following these descriptions is a description of optional C inputs available through the call sequence, and then a C description of optional outputs in the work arrays. C C 2. Descriptions of other routines in the DLSODE package that may C be (optionally) called by the user. These provide the ability C to alter error message handling, save and restore the internal C COMMON, and obtain specified derivatives of the solution y(t). C C 3. Descriptions of COMMON block to be declared in overlay or C similar environments, or to be saved when doing an interrupt C of the problem and continued solution later. C C 4. Description of two routines in the DLSODE package, either of C which the user may replace with his own version, if desired. C These relate to the measurement of errors. C C C Part 1. Call Sequence C ---------------------- C C Arguments C --------- C The call sequence parameters used for input only are C C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF, C C and those used for both input and output are C C Y, T, ISTATE. C C The work arrays RWORK and IWORK are also used for conditional and C optional inputs and optional outputs. (The term output here C refers to the return from subroutine DLSODE to the user's calling C program.) C C The legality of input parameters will be thoroughly checked on the C initial call for the problem, but not checked thereafter unless a C change in input parameters is flagged by ISTATE = 3 on input. C C The descriptions of the call arguments are as follows. C C F The name of the user-supplied subroutine defining the ODE C system. The system must be put in the first-order form C dy/dt = f(t,y), where f is a vector-valued function of C the scalar t and the vector y. Subroutine F is to compute C the function f. It is to have the form C C SUBROUTINE F (NEQ, T, Y, YDOT,rpar,ipar) C INTEGER NEQ,ipar(*) C DOUBLE PRECISION T, Y(*), YDOT(*),rpar(*) C C where NEQ, T, and Y are input, and the array YDOT = C f(T,Y) is output. Y and YDOT are arrays of length NEQ. C Subroutine F should not alter Y(1),...,Y(NEQ). F must be C declared EXTERNAL in the calling program. C C Subroutine F may access user-defined quantities in C NEQ(2),... and/or in Y(NEQ(1)+1),..., if NEQ is an array C (dimensioned in F) and/or Y has length exceeding NEQ(1). C See the descriptions of NEQ and Y below. C C If quantities computed in the F routine are needed C externally to DLSODE, an extra call to F should be made C for this purpose, for consistent and accurate results. C If only the derivative dy/dt is needed, use DINTDY C instead. C C NEQ The size of the ODE system (number of first-order C ordinary differential equations). Used only for input. C NEQ may be decreased, but not increased, during the C problem. If NEQ is decreased (with ISTATE = 3 on input), C the remaining components of Y should be left undisturbed, C if these are to be accessed in F and/or JAC. C C Normally, NEQ is a scalar, and it is generally referred C to as a scalar in this user interface description. C However, NEQ may be an array, with NEQ(1) set to the C system size. (The DLSODE package accesses only NEQ(1).) C In either case, this parameter is passed as the NEQ C argument in all calls to F and JAC. Hence, if it is an C array, locations NEQ(2),... may be used to store other C integer data and pass it to F and/or JAC. Subroutines C F and/or JAC must include NEQ in a DIMENSION statement C in that case. C C Y A real array for the vector of dependent variables, of C length NEQ or more. Used for both input and output on C the first call (ISTATE = 1), and only for output on C other calls. On the first call, Y must contain the C vector of initial values. On output, Y contains the C computed solution vector, evaluated at T. If desired, C the Y array may be used for other purposes between C calls to the solver. C C This array is passed as the Y argument in all calls to F C and JAC. Hence its length may exceed NEQ, and locations C Y(NEQ+1),... may be used to store other real data and C pass it to F and/or JAC. (The DLSODE package accesses C only Y(1),...,Y(NEQ).) C C T The independent variable. On input, T is used only on C the first call, as the initial point of the integration. C On output, after each call, T is the value at which a C computed solution Y is evaluated (usually the same as C TOUT). On an error return, T is the farthest point C reached. C C TOUT The next value of T at which a computed solution is C desired. Used only for input. C C When starting the problem (ISTATE = 1), TOUT may be equal C to T for one call, then should not equal T for the next C call. For the initial T, an input value of TOUT .NE. T C is used in order to determine the direction of the C integration (i.e., the algebraic sign of the step sizes) C and the rough scale of the problem. Integration in C either direction (forward or backward in T) is permitted. C C If ITASK = 2 or 5 (one-step modes), TOUT is ignored C after the first call (i.e., the first call with C TOUT .NE. T). Otherwise, TOUT is required on every call. C C If ITASK = 1, 3, or 4, the values of TOUT need not be C monotone, but a value of TOUT which backs up is limited C to the current internal T interval, whose endpoints are C TCUR - HU and TCUR. (See "Optional Outputs" below for C TCUR and HU.) C C C ITOL An indicator for the type of error control. See C description below under ATOL. Used only for input. C C RTOL A relative error tolerance parameter, either a scalar or C an array of length NEQ. See description below under C ATOL. Input only. C C ATOL An absolute error tolerance parameter, either a scalar or C an array of length NEQ. Input only. C C The input parameters ITOL, RTOL, and ATOL determine the C error control performed by the solver. The solver will C control the vector e = (e(i)) of estimated local errors C in Y, according to an inequality of the form C C rms-norm of ( e(i)/EWT(i) ) <= 1, C C where C C EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i), C C and the rms-norm (root-mean-square norm) here is C C rms-norm(v) = SQRT(sum v(i)**2 / NEQ). C C Here EWT = (EWT(i)) is a vector of weights which must C always be positive, and the values of RTOL and ATOL C should all be nonnegative. The following table gives the C types (scalar/array) of RTOL and ATOL, and the C corresponding form of EWT(i). C C ITOL RTOL ATOL EWT(i) C ---- ------ ------ ----------------------------- C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) C C When either of these parameters is a scalar, it need not C be dimensioned in the user's calling program. C C If none of the above choices (with ITOL, RTOL, and ATOL C fixed throughout the problem) is suitable, more general C error controls can be obtained by substituting C user-supplied routines for the setting of EWT and/or for C the norm calculation. See Part 4 below. C C If global errors are to be estimated by making a repeated C run on the same problem with smaller tolerances, then all C components of RTOL and ATOL (i.e., of EWT) should be C scaled down uniformly. C C ITASK An index specifying the task to be performed. Input C only. ITASK has the following values and meanings: C 1 Normal computation of output values of y(t) at C t = TOUT (by overshooting and interpolating). C 2 Take one step only and return. C 3 Stop at the first internal mesh point at or beyond C t = TOUT and return. C 4 Normal computation of output values of y(t) at C t = TOUT but without overshooting t = TCRIT. TCRIT C must be input as RWORK(1). TCRIT may be equal to or C beyond TOUT, but not behind it in the direction of C integration. This option is useful if the problem C has a singularity at or beyond t = TCRIT. C 5 Take one step, without passing TCRIT, and return. C TCRIT must be input as RWORK(1). C C Note: If ITASK = 4 or 5 and the solver reaches TCRIT C (within roundoff), it will return T = TCRIT (exactly) to C indicate this (unless ITASK = 4 and TOUT comes before C TCRIT, in which case answers at T = TOUT are returned C first). C C ISTATE An index used for input and output to specify the state C of the calculation. C C On input, the values of ISTATE are as follows: C 1 This is the first call for the problem C (initializations will be done). See "Note" below. C 2 This is not the first call, and the calculation is to C continue normally, with no change in any input C parameters except possibly TOUT and ITASK. (If ITOL, C RTOL, and/or ATOL are changed between calls with C ISTATE = 2, the new values will be used but not C tested for legality.) C 3 This is not the first call, and the calculation is to C continue normally, but with a change in input C parameters other than TOUT and ITASK. Changes are C allowed in NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, C ML, MU, and any of the optional inputs except H0. C (See IWORK description for ML and MU.) C C Note: A preliminary call with TOUT = T is not counted as C a first call here, as no initialization or checking of C input is done. (Such a call is sometimes useful for the C purpose of outputting the initial conditions.) Thus the C first call for which TOUT .NE. T requires ISTATE = 1 on C input. C C On output, ISTATE has the following values and meanings: C 1 Nothing was done, as TOUT was equal to T with C ISTATE = 1 on input. C 2 The integration was performed successfully. C -1 An excessive amount of work (more than MXSTEP steps) C was done on this call, before completing the C requested task, but the integration was otherwise C successful as far as T. (MXSTEP is an optional input C and is normally 500.) To continue, the user may C simply reset ISTATE to a value >1 and call again (the C excess work step counter will be reset to 0). In C addition, the user may increase MXSTEP to avoid this C error return; see "Optional Inputs" below. C -2 Too much accuracy was requested for the precision of C the machine being used. This was detected before C completing the requested task, but the integration C was successful as far as T. To continue, the C tolerance parameters must be reset, and ISTATE must C be set to 3. The optional output TOLSF may be used C for this purpose. (Note: If this condition is C detected before taking any steps, then an illegal C input return (ISTATE = -3) occurs instead.) C -3 Illegal input was detected, before taking any C integration steps. See written message for details. C (Note: If the solver detects an infinite loop of C calls to the solver with illegal input, it will cause C the run to stop.) C -4 There were repeated error-test failures on one C attempted step, before completing the requested task, C but the integration was successful as far as T. The C problem may have a singularity, or the input may be C inappropriate. C -5 There were repeated convergence-test failures on one C attempted step, before completing the requested task, C but the integration was successful as far as T. This C may be caused by an inaccurate Jacobian matrix, if C one is being used. C -6 EWT(i) became zero for some i during the integration. C Pure relative error control (ATOL(i)=0.0) was C requested on a variable which has now vanished. The C integration was successful as far as T. C C Note: Since the normal output value of ISTATE is 2, it C does not need to be reset for normal continuation. Also, C since a negative input value of ISTATE will be regarded C as illegal, a negative output value requires the user to C change it, and possibly other inputs, before calling the C solver again. C C IOPT An integer flag to specify whether any optional inputs C are being used on this call. Input only. The optional C inputs are listed under a separate heading below. C 0 No optional inputs are being used. Default values C will be used in all cases. C 1 One or more optional inputs are being used. C C RWORK A real working array (double precision). The length of C RWORK must be at least C C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM C C where C NYH = the initial value of NEQ, C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a C smaller value is given as an optional input), C LWM = 0 if MITER = 0, C LWM = NEQ**2 + 2 if MITER = 1 or 2, C LWM = NEQ + 2 if MITER = 3, and C LWM = (2*ML + MU + 1)*NEQ + 2 C if MITER = 4 or 5. C (See the MF description below for METH and MITER.) C C Thus if MAXORD has its default value and NEQ is constant, C this length is: C 20 + 16*NEQ for MF = 10, C 22 + 16*NEQ + NEQ**2 for MF = 11 or 12, C 22 + 17*NEQ for MF = 13, C 22 + 17*NEQ + (2*ML + MU)*NEQ for MF = 14 or 15, C 20 + 9*NEQ for MF = 20, C 22 + 9*NEQ + NEQ**2 for MF = 21 or 22, C 22 + 10*NEQ for MF = 23, C 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25. C C The first 20 words of RWORK are reserved for conditional C and optional inputs and optional outputs. C C The following word in RWORK is a conditional input: C RWORK(1) = TCRIT, the critical value of t which the C solver is not to overshoot. Required if ITASK C is 4 or 5, and ignored otherwise. See ITASK. C C LRW The length of the array RWORK, as declared by the user. C (This will be checked by the solver.) C C IWORK An integer work array. Its length must be at least C 20 if MITER = 0 or 3 (MF = 10, 13, 20, 23), or C 20 + NEQ otherwise (MF = 11, 12, 14, 15, 21, 22, 24, 25). C (See the MF description below for MITER.) The first few C words of IWORK are used for conditional and optional C inputs and optional outputs. C C The following two words in IWORK are conditional inputs: C IWORK(1) = ML These are the lower and upper half- C IWORK(2) = MU bandwidths, respectively, of the banded C Jacobian, excluding the main diagonal. C The band is defined by the matrix locations C (i,j) with i - ML <= j <= i + MU. ML and MU C must satisfy 0 <= ML,MU <= NEQ - 1. These are C required if MITER is 4 or 5, and ignored C otherwise. ML and MU may in fact be the band C parameters for a matrix to which df/dy is only C approximately equal. C C LIW The length of the array IWORK, as declared by the user. C (This will be checked by the solver.) C C Note: The work arrays must not be altered between calls to DLSODE C for the same problem, except possibly for the conditional and C optional inputs, and except for the last 3*NEQ words of RWORK. C The latter space is used for internal scratch space, and so is C available for use by the user outside DLSODE between calls, if C desired (but not for use by F or JAC). C C JAC The name of the user-supplied routine (MITER = 1 or 4) to C compute the Jacobian matrix, df/dy, as a function of the C scalar t and the vector y. (See the MF description below C for MITER.) It is to have the form C C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, rpar, ipar) C integer ipar(*) C DOUBLE PRECISION T, Y(*), PD(NROWPD,*), rpar(*) C C where NEQ, T, Y, ML, MU, and NROWPD are input and the C array PD is to be loaded with partial derivatives C (elements of the Jacobian matrix) on output. PD must be C given a first dimension of NROWPD. T and Y have the same C meaning as in subroutine F. C C In the full matrix case (MITER = 1), ML and MU are C ignored, and the Jacobian is to be loaded into PD in C columnwise manner, with df(i)/dy(j) loaded into PD(i,j). C C In the band matrix case (MITER = 4), the elements within C the band are to be loaded into PD in columnwise manner, C with diagonal lines of df/dy loaded into the rows of PD. C Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). ML C and MU are the half-bandwidth parameters (see IWORK). C The locations in PD in the two triangular areas which C correspond to nonexistent matrix elements can be ignored C or loaded arbitrarily, as they are overwritten by DLSODE. C C JAC need not provide df/dy exactly. A crude approximation C (possibly with a smaller bandwidth) will do. C C In either case, PD is preset to zero by the solver, so C that only the nonzero elements need be loaded by JAC. C Each call to JAC is preceded by a call to F with the same C arguments NEQ, T, and Y. Thus to gain some efficiency, C intermediate quantities shared by both calculations may C be saved in a user COMMON block by F and not recomputed C by JAC, if desired. Also, JAC may alter the Y array, if C desired. JAC must be declared EXTERNAL in the calling C program. C C Subroutine JAC may access user-defined quantities in C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array C (dimensioned in JAC) and/or Y has length exceeding C NEQ(1). See the descriptions of NEQ and Y above. C C MF The method flag. Used only for input. The legal values C of MF are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, C and 25. MF has decimal digits METH and MITER: C MF = 10*METH + MITER . C C METH indicates the basic linear multistep method: C 1 Implicit Adams method. C 2 Method based on backward differentiation formulas C (BDF's). C C MITER indicates the corrector iteration method: C 0 Functional iteration (no Jacobian matrix is C involved). C 1 Chord iteration with a user-supplied full (NEQ by C NEQ) Jacobian. C 2 Chord iteration with an internally generated C (difference quotient) full Jacobian (using NEQ C extra calls to F per df/dy value). C 3 Chord iteration with an internally generated C diagonal Jacobian approximation (using one extra call C to F per df/dy evaluation). C 4 Chord iteration with a user-supplied banded Jacobian. C 5 Chord iteration with an internally generated banded C Jacobian (using ML + MU + 1 extra calls to F per C df/dy evaluation). C C If MITER = 1 or 4, the user must supply a subroutine JAC C (the name is arbitrary) as described above under JAC. C For other values of MITER, a dummy argument can be used. C C Optional Inputs C --------------- C The following is a list of the optional inputs provided for in the C call sequence. (See also Part 2.) For each such input variable, C this table lists its name as used in this documentation, its C location in the call sequence, its meaning, and the default value. C The use of any of these inputs requires IOPT = 1, and in that case C all of these inputs are examined. A value of zero for any of C these optional inputs will cause the default value to be used. C Thus to use a subset of the optional inputs, simply preload C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, C and then set those of interest to nonzero values. C C Name Location Meaning and default value C ------ --------- ----------------------------------------------- C H0 RWORK(5) Step size to be attempted on the first step. C The default value is determined by the solver. C HMAX RWORK(6) Maximum absolute step size allowed. The C default value is infinite. C HMIN RWORK(7) Minimum absolute step size allowed. The C default value is 0. (This lower bound is not C enforced on the final step before reaching C TCRIT when ITASK = 4 or 5.) C MAXORD IWORK(5) Maximum order to be allowed. The default value C is 12 if METH = 1, and 5 if METH = 2. (See the C MF description above for METH.) If MAXORD C exceeds the default value, it will be reduced C to the default value. If MAXORD is changed C during the problem, it may cause the current C order to be reduced. C MXSTEP IWORK(6) Maximum number of (internally defined) steps C allowed during one call to the solver. The C default value is 500. C MXHNIL IWORK(7) Maximum number of messages printed (per C problem) warning that T + H = T on a step C (H = step size). This must be positive to C result in a nondefault value. The default C value is 10. C C Optional Outputs C ---------------- C As optional additional output from DLSODE, the variables listed C below are quantities related to the performance of DLSODE which C are available to the user. These are communicated by way of the C work arrays, but also have internal mnemonic names as shown. C Except where stated otherwise, all of these outputs are defined on C any successful return from DLSODE, and on any return with ISTATE = C -1, -2, -4, -5, or -6. On an illegal input return (ISTATE = -3), C they will be unchanged from their existing values (if any), except C possibly for TOLSF, LENRW, and LENIW. On any error return, C outputs relevant to the error will be defined, as noted below. C C Name Location Meaning C ----- --------- ------------------------------------------------ C HU RWORK(11) Step size in t last used (successfully). C HCUR RWORK(12) Step size to be attempted on the next step. C TCUR RWORK(13) Current value of the independent variable which C the solver has actually reached, i.e., the C current internal mesh point in t. On output, C TCUR will always be at least as far as the C argument T, but may be farther (if interpolation C was done). C TOLSF RWORK(14) Tolerance scale factor, greater than 1.0, C computed when a request for too much accuracy C was detected (ISTATE = -3 if detected at the C start of the problem, ISTATE = -2 otherwise). C If ITOL is left unaltered but RTOL and ATOL are C uniformly scaled up by a factor of TOLSF for the C next call, then the solver is deemed likely to C succeed. (The user may also ignore TOLSF and C alter the tolerance parameters in any other way C appropriate.) C NST IWORK(11) Number of steps taken for the problem so far. C NFE IWORK(12) Number of F evaluations for the problem so far. C NJE IWORK(13) Number of Jacobian evaluations (and of matrix LU C decompositions) for the problem so far. C NQU IWORK(14) Method order last used (successfully). C NQCUR IWORK(15) Order to be attempted on the next step. C IMXER IWORK(16) Index of the component of largest magnitude in C the weighted local error vector ( e(i)/EWT(i) ), C on an error return with ISTATE = -4 or -5. C LENRW IWORK(17) Length of RWORK actually required. This is C defined on normal returns and on an illegal C input return for insufficient storage. C LENIW IWORK(18) Length of IWORK actually required. This is C defined on normal returns and on an illegal C input return for insufficient storage. C C The following two arrays are segments of the RWORK array which may C also be of interest to the user as optional outputs. For each C array, the table below gives its internal name, its base address C in RWORK, and its description. C C Name Base address Description C ---- ------------ ---------------------------------------------- C YH 21 The Nordsieck history array, of size NYH by C (NQCUR + 1), where NYH is the initial value of C NEQ. For j = 0,1,...,NQCUR, column j + 1 of C YH contains HCUR**j/factorial(j) times the jth C derivative of the interpolating polynomial C currently representing the solution, evaluated C at t = TCUR. C ACOR LENRW-NEQ+1 Array of size NEQ used for the accumulated C corrections on each step, scaled on output to C represent the estimated local error in Y on C the last step. This is the vector e in the C description of the error control. It is C defined only on successful return from DLSODE. C C C Part 2. Other Callable Routines C -------------------------------- C C The following are optional calls which the user may make to gain C additional capabilities in conjunction with DLSODE. C C Form of call Function C ------------------------ ---------------------------------------- C CALL XSETUN(LUN) Set the logical unit number, LUN, for C output of messages from DLSODE, if the C default is not desired. The default C value of LUN is 6. This call may be made C at any time and will take effect C immediately. C CALL XSETF(MFLAG) Set a flag to control the printing of C messages by DLSODE. MFLAG = 0 means do C not print. (Danger: this risks losing C valuable information.) MFLAG = 1 means C print (the default). This call may be C made at any time and will take effect C immediately. C CALL DSRCOM(RSAV,ISAV,JOB) Saves and restores the contents of the C internal COMMON blocks used by DLSODE C (see Part 3 below). RSAV must be a C real array of length 218 or more, and C ISAV must be an integer array of length C 37 or more. JOB = 1 means save COMMON C into RSAV/ISAV. JOB = 2 means restore C COMMON from same. DSRCOM is useful if C one is interrupting a run and restarting C later, or alternating between two or C more problems solved with DLSODE. C CALL DINTDY(,,,,,) Provide derivatives of y, of various C (see below) orders, at a specified point t, if C desired. It may be called only after a C successful return from DLSODE. Detailed C instructions follow. C C Detailed instructions for using DINTDY C -------------------------------------- C The form of the CALL is: C C CALL DINTDY (T, K, RWORK(21), NYH, DKY, IFLAG) C C The input parameters are: C C T Value of independent variable where answers are C desired (normally the same as the T last returned by C DLSODE). For valid results, T must lie between C TCUR - HU and TCUR. (See "Optional Outputs" above C for TCUR and HU.) C K Integer order of the derivative desired. K must C satisfy 0 <= K <= NQCUR, where NQCUR is the current C order (see "Optional Outputs"). The capability C corresponding to K = 0, i.e., computing y(t), is C already provided by DLSODE directly. Since C NQCUR >= 1, the first derivative dy/dt is always C available with DINTDY. C RWORK(21) The base address of the history array YH. C NYH Column length of YH, equal to the initial value of NEQ. C C The output parameters are: C C DKY Real array of length NEQ containing the computed value C of the Kth derivative of y(t). C IFLAG Integer flag, returned as 0 if K and T were legal, C -1 if K was illegal, and -2 if T was illegal. C On an error return, a message is also written. C C C Part 3. Common Blocks C ---------------------- C C If DLSODE is to be used in an overlay situation, the user must C declare, in the primary overlay, the variables in: C (1) the call sequence to DLSODE, C (2) the internal COMMON block /DLS001/, of length 255 C (218 double precision words followed by 37 integer words). C C If DLSODE is used on a system in which the contents of internal C COMMON blocks are not preserved between calls, the user should C declare the above COMMON block in his main program to insure that C its contents are preserved. C C If the solution of a given problem by DLSODE is to be interrupted C and then later continued, as when restarting an interrupted run or C alternating between two or more problems, the user should save, C following the return from the last DLSODE call prior to the C interruption, the contents of the call sequence variables and the C internal COMMON block, and later restore these values before the C next DLSODE call for that problem. In addition, if XSETUN and/or C XSETF was called for non-default handling of error messages, then C these calls must be repeated. To save and restore the COMMON C block, use subroutine DSRCOM (see Part 2 above). C C C Part 4. Optionally Replaceable Solver Routines C ----------------------------------------------- C C Below are descriptions of two routines in the DLSODE package which C relate to the measurement of errors. Either routine can be C replaced by a user-supplied version, if desired. However, since C such a replacement may have a major impact on performance, it C should be done only when absolutely necessary, and only with great C caution. (Note: The means by which the package version of a C routine is superseded by the user's version may be system- C dependent.) C C DEWSET C ------ C The following subroutine is called just before each internal C integration step, and sets the array of error weights, EWT, as C described under ITOL/RTOL/ATOL above: C C SUBROUTINE DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) C C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODE call C sequence, YCUR contains the current dependent variable vector, C and EWT is the array of weights set by DEWSET. C C If the user supplies this subroutine, it must return in EWT(i) C (i = 1,...,NEQ) a positive quantity suitable for comparing errors C in Y(i) to. The EWT array returned by DEWSET is passed to the C DVNORM routine (see below), and also used by DLSODE in the C computation of the optional output IMXER, the diagonal Jacobian C approximation, and the increments for difference quotient C Jacobians. C C In the user-supplied version of DEWSET, it may be desirable to use C the current values of derivatives of y. Derivatives up to order NQ C are available from the history array YH, described above under C optional outputs. In DEWSET, YH is identical to the YCUR array, C extended to NQ + 1 columns with a column length of NYH and scale C factors of H**j/factorial(j). On the first call for the problem, C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. C NYH is the initial value of NEQ. The quantities NQ, H, and NST C can be obtained by including in SEWSET the statements: C DOUBLE PRECISION RLS C COMMON /DLS001/ RLS(218),ILS(37) C NQ = ILS(33) C NST = ILS(34) C H = RLS(212) C Thus, for example, the current value of dy/dt can be obtained as C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is unnecessary C when NST = 0). C C DVNORM C ------ C DVNORM is a real function routine which computes the weighted C root-mean-square norm of a vector v: C C d = DVNORM (n, v, w) C C where: C n = the length of the vector, C v = real array of length n containing the vector, C w = real array of length n containing weights, C d = SQRT( (1/n) * sum(v(i)*w(i))**2 ). C C DVNORM is called with n = NEQ and with w(i) = 1.0/EWT(i), where C EWT is as set by subroutine DEWSET. C C If the user supplies this function, it should return a nonnegative C value of DVNORM suitable for use in the error control in DLSODE. C None of the arguments should be altered by DVNORM. For example, a C user-supplied DVNORM routine might: C - Substitute a max-norm of (v(i)*w(i)) for the rms-norm, or C - Ignore some components of v in the norm, with the effect of C suppressing the error control on those components of Y. C --------------------------------------------------------------------- C***ROUTINES CALLED DEWSET, DINTDY, DUMACH, DSTODE, DVNORM, XERRWD C***COMMON BLOCKS DLS001 C***REVISION HISTORY (YYYYMMDD) C 19791129 DATE WRITTEN C 19791213 Minor changes to declarations; DELP init. in STODE. C 19800118 Treat NEQ as array; integer declarations added throughout; C minor changes to prologue. C 19800306 Corrected TESCO(1,NQP1) setting in CFODE. C 19800519 Corrected access of YH on forced order reduction; C numerous corrections to prologues and other comments. C 19800617 In main driver, added loading of SQRT(UROUND) in RWORK; C minor corrections to main prologue. C 19800923 Added zero initialization of HU and NQU. C 19801218 Revised XERRWD routine; minor corrections to main prologue. C 19810401 Minor changes to comments and an error message. C 19810814 Numerous revisions: replaced EWT by 1/EWT; used flags C JCUR, ICF, IERPJ, IERSL between STODE and subordinates; C added tuning parameters CCMAX, MAXCOR, MSBP, MXNCF; C reorganized returns from STODE; reorganized type decls.; C fixed message length in XERRWD; changed default LUNIT to 6; C changed Common lengths; changed comments throughout. C 19870330 Major update by ACH: corrected comments throughout; C removed TRET from Common; rewrote EWSET with 4 loops; C fixed t test in INTDY; added Cray directives in STODE; C in STODE, fixed DELP init. and logic around PJAC call; C combined routines to save/restore Common; C passed LEVEL = 0 in error message calls (except run abort). C 19890426 Modified prologue to SLATEC/LDOC format. (FNF) C 19890501 Many improvements to prologue. (FNF) C 19890503 A few final corrections to prologue. (FNF) C 19890504 Minor cosmetic changes. (FNF) C 19890510 Corrected description of Y in Arguments section. (FNF) C 19890517 Minor corrections to prologue. (FNF) C 19920514 Updated with prologue edited 891025 by G. Shaw for manual. C 19920515 Converted source lines to upper case. (FNF) C 19920603 Revised XERRWD calls using mixed upper-lower case. (ACH) C 19920616 Revised prologue comment regarding CFT. (ACH) C 19921116 Revised prologue comments regarding Common. (ACH). C 19930326 Added comment about non-reentrancy. (FNF) C 19930723 Changed D1MACH to DUMACH. (FNF) C 19930801 Removed ILLIN and NTREP from Common (affects driver logic); C minor changes to prologue and internal comments; C changed Hollerith strings to quoted strings; C changed internal comments to mixed case; C replaced XERRWD with new version using character type; C changed dummy dimensions from 1 to *. (ACH) C 19930809 Changed to generic intrinsic names; changed names of C subprograms and Common blocks to DLSODE etc. (ACH) C 19930929 Eliminated use of REAL intrinsic; other minor changes. (ACH) C 20010412 Removed all 'own' variables from Common block /DLS001/ C (affects declarations in 6 routines). (ACH) C 20010509 Minor corrections to prologue. (ACH) C 20031105 Restored 'own' variables to Common block /DLS001/, to C enable interrupt/restart feature. (ACH) C 20031112 Added SAVE statements for data-loaded constants. C C***END PROLOGUE DLSODE C C*Internal Notes: C C Other Routines in the DLSODE Package. C C In addition to Subroutine DLSODE, the DLSODE package includes the C following subroutines and function routines: C DINTDY computes an interpolated value of the y vector at t = TOUT. C DSTODE is the core integrator, which does one step of the C integration and the associated error control. C DCFODE sets all method coefficients and test constants. C DPREPJ computes and preprocesses the Jacobian matrix J = df/dy C and the Newton iteration matrix P = I - h*l0*J. C DSOLSY manages solution of linear system in chord iteration. C DEWSET sets the error weight vector EWT before each step. C DVNORM computes the weighted R.M.S. norm of a vector. C DSRCOM is a user-callable routine to save and restore C the contents of the internal Common block. C DGEFA and DGESL are routines from LINPACK for solving full C systems of linear algebraic equations. C DGBFA and DGBSL are routines from LINPACK for solving banded C linear systems. C DUMACH computes the unit roundoff in a machine-independent manner. C XERRWD, XSETUN, XSETF, IXSAV, IUMACH handle the printing of all C error messages and warnings. XERRWD is machine-dependent. C Note: DVNORM, DUMACH, IXSAV, and IUMACH are function routines. C All the others are subroutines. C C**End C C Declare externals. EXTERNAL DPREPJ, DSOLSY DOUBLE PRECISION DUMACH, DVNORM C C Declare all other variables. INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER I, I1, I2, IFLAG, IMXER, KGO, LF0, 1 LENIW, LENRW, LENWM, ML, MORD, MU, MXHNL0, MXSTP0 DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 DIMENSION MORD(2) LOGICAL IHIT CHARACTER(LEN=80) MSG SAVE MORD, MXSTP0, MXHNL0 C----------------------------------------------------------------------- C The following internal Common block contains C (a) variables which are local to any subroutine but whose values must C be preserved between calls to the routine ("own" variables), and C (b) variables which are communicated between subroutines. C The block DLS001 is declared in subroutines DLSODE, DINTDY, DSTODE, C DPREPJ, and DSOLSY. C Groups of variables are replaced by dummy arrays in the Common C declarations in routines where those variables are not used. C----------------------------------------------------------------------- COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ C----------------------------------------------------------------------- C Block A. C This code block is executed on every call. C It tests ISTATE and ITASK for legality and branches appropriately. C If ISTATE .GT. 1 but the flag INIT shows that initialization has C not yet been done, an error return occurs. C If ISTATE = 1 and TOUT = T, return immediately. C----------------------------------------------------------------------- C KARLINE: INITIALISED IHIT TO AVOID COMPILER WARNINGS - SHOULD HAVE NO EFFEXT IHIT = .TRUE. C***FIRST EXECUTABLE STATEMENT DLSODE IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 IF (ISTATE .EQ. 1) GO TO 10 IF (INIT .EQ. 0) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) RETURN C----------------------------------------------------------------------- C Block B. C The next code block is executed for the initial call (ISTATE = 1), C or for a continuation call with parameter changes (ISTATE = 3). C It contains checking of all inputs and various initializations. C C First check legality of the non-optional inputs NEQ, ITOL, IOPT, C MF, ML, and MU. C----------------------------------------------------------------------- 20 IF (NEQ(1) .LE. 0) GO TO 604 IF (ISTATE .EQ. 1) GO TO 25 IF (NEQ(1) .GT. N) GO TO 605 25 N = NEQ(1) IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 METH = MF/10 MITER = MF - 10*METH IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 IF (MITER .LE. 3) GO TO 30 ML = IWORK(1) MU = IWORK(2) IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 30 CONTINUE C Next process and check the optional inputs. -------------------------- IF (IOPT .EQ. 1) GO TO 40 MAXORD = MORD(METH) MXSTEP = MXSTP0 MXHNIL = MXHNL0 IF (ISTATE .EQ. 1) H0 = 0.0D0 HMXI = 0.0D0 HMIN = 0.0D0 GO TO 60 40 MAXORD = IWORK(5) IF (MAXORD .LT. 0) GO TO 611 IF (MAXORD .EQ. 0) MAXORD = 100 MAXORD = MIN(MAXORD,MORD(METH)) MXSTEP = IWORK(6) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .NE. 1) GO TO 50 H0 = RWORK(5) IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. 0.0D0) GO TO 615 HMXI = 0.0D0 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX HMIN = RWORK(7) IF (HMIN .LT. 0.0D0) GO TO 616 C----------------------------------------------------------------------- C Set work array pointers and check lengths LRW and LIW. C Pointers to segments of RWORK and IWORK are named by prefixing L to C the name of the segment. E.g., the segment YH starts at RWORK(LYH). C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR. C----------------------------------------------------------------------- 60 LYH = 21 IF (ISTATE .EQ. 1) NYH = N LWM = LYH + (MAXORD + 1)*NYH IF (MITER .EQ. 0) LENWM = 0 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENWM = N*N + 2 IF (MITER .EQ. 3) LENWM = N + 2 IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 LEWT = LWM + LENWM LSAVF = LEWT + N LACOR = LSAVF + N LENRW = LACOR + N - 1 IWORK(17) = LENRW LIWM = 1 LENIW = 20 + N IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 20 IWORK(18) = LENIW IF (LENRW .GT. LRW) GO TO 617 IF (LENIW .GT. LIW) GO TO 618 C Check RTOL and ATOL for legality. ------------------------------------ RTOLI = RTOL(1) ATOLI = ATOL(1) DO 70 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. 0.0D0) GO TO 619 IF (ATOLI .LT. 0.0D0) GO TO 620 70 CONTINUE IF (ISTATE .EQ. 1) GO TO 100 C If ISTATE = 3, set flag to signal parameter changes to DSTODE. ------- JSTART = -1 IF (NQ .LE. MAXORD) GO TO 90 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- DO 80 I = 1,N RWORK(I+LSAVF-1) = RWORK(I+LWM-1) 80 CONTINUE C Reload WM(1) = RWORK(LWM), since LWM may have changed. --------------- 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) IF (N .EQ. NYH) GO TO 200 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- I1 = LYH + L*NYH I2 = LYH + (MAXORD + 1)*NYH - 1 IF (I1 .GT. I2) GO TO 200 DO 95 I = I1,I2 RWORK(I) = 0.0D0 95 CONTINUE GO TO 200 C----------------------------------------------------------------------- C Block C. C The next block is for the initial call only (ISTATE = 1). C It contains all remaining initializations, the initial call to F, C and the calculation of the initial step size. C The error weights in EWT are inverted after being loaded. C----------------------------------------------------------------------- 100 UROUND = DUMACH() TN = T IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 1 H0 = TCRIT - T 110 JSTART = 0 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) NHNIL = 0 NST = 0 NJE = 0 NSLAST = 0 HU = 0.0D0 NQU = 0 CCMAX = 0.3D0 MAXCOR = 3 MSBP = 20 MXNCF = 10 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- LF0 = LYH + NYH CALL F (NEQ, T, Y, RWORK(LF0), rpar, ipar) NFE = 1 C Load the initial value vector in YH. --------------------------------- DO 115 I = 1,N RWORK(I+LYH-1) = Y(I) 115 CONTINUE C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- NQ = 1 H = 1.0D0 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 120 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 120 CONTINUE C----------------------------------------------------------------------- C The coding below computes the step size, H0, to be attempted on the C first step, unless the user has supplied a value for this. C First check that TOUT - T differs significantly from zero. C A scalar tolerance quantity TOL is computed, as MAX(RTOL(I)) C if this is positive, or MAX(ATOL(I)/ABS(Y(I))) otherwise, adjusted C so as to be between 100*UROUND and 1.0E-3. C Then the computed value H0 is given by.. C NEQ C H0**2 = TOL / ( w0**-2 + (1/NEQ) * SUM ( f(i)/ywt(i) )**2 ) C 1 C where w0 = MAX ( ABS(T), ABS(TOUT) ), C f(i) = i-th component of initial value of f, C ywt(i) = EWT(i)/TOL (a weight for y(i)). C The sign of H0 is inferred from the initial values of TOUT and T. C----------------------------------------------------------------------- IF (H0 .NE. 0.0D0) GO TO 180 TDIST = ABS(TOUT - T) W0 = MAX(ABS(T),ABS(TOUT)) IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 TOL = RTOL(1) IF (ITOL .LE. 2) GO TO 140 DO 130 I = 1,N TOL = MAX(TOL,RTOL(I)) 130 CONTINUE 140 IF (TOL .GT. 0.0D0) GO TO 160 ATOLI = ATOL(1) DO 150 I = 1,N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) AYI = ABS(Y(I)) IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 150 CONTINUE 160 TOL = MAX(TOL,100.0D0*UROUND) TOL = MIN(TOL,0.001D0) SUM = DVNORM (N, RWORK(LF0), RWORK(LEWT)) SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 H0 = 1.0D0/SQRT(SUM) H0 = MIN(H0,TDIST) H0 = SIGN(H0,TOUT-T) C Adjust H0 if necessary to meet HMAX bound. --------------------------- 180 RH = ABS(H0)*HMXI IF (RH .GT. 1.0D0) H0 = H0/RH C Load H with H0 and scale YH(*,2) by H0. ------------------------------ H = H0 DO 190 I = 1,N RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 190 CONTINUE GO TO 270 C----------------------------------------------------------------------- C Block D. C The next code block is for continuation calls only (ISTATE = 2 or 3) C and is to check stop conditions before taking a step. C----------------------------------------------------------------------- 200 NSLAST = NST IF (ITASK .EQ. 1) THEN GOTO 210 ELSE IF (ITASK .EQ. 2) THEN GOTO 250 ELSE IF (ITASK .EQ. 3) THEN GOTO 220 ELSE IF (ITASK .EQ. 4) THEN GOTO 230 ELSE IF (ITASK .EQ. 5) THEN GOTO 240 ENDIF C GO TO (210, 250, 220, 230, 240), ITASK 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 245 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (ISTATE .EQ. 2) JSTART = -2 C----------------------------------------------------------------------- C Block E. C The next block is normally executed for all calls and contains C the call to the one-step core integrator DSTODE. C C This is a looping point for the integration steps. C C First check for too many steps being taken, update EWT (if not at C start of problem), check for too much accuracy being requested, and C check for H below the roundoff level in T. C----------------------------------------------------------------------- 250 CONTINUE IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 260 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 260 CONTINUE 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) IF (TOLSF .LE. 1.0D0) GO TO 280 TOLSF = TOLSF*2.0D0 IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 MSG = 'DLSODE- Warning..internal T (=R1) and H (=R2) are' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' such that in the machine, T + H = T on the next step ' CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' (H = step size). Solver will continue anyway' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 MSG = 'DLSODE- Above warning has been issued I1 times. ' CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' It will not be issued again for this problem' CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 290 CONTINUE C----------------------------------------------------------------------- C CALL DSTODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,DPREPJ,DSOLSY) C----------------------------------------------------------------------- CALL DSTODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), 2 F, JAC, DPREPJ, DSOLSY, rpar,ipar) KGO = 1 - KFLAG IF (KGO .EQ. 1) THEN GOTO 300 ELSE IF (KGO .EQ. 2) THEN GOTO 530 ELSE IF (KGO .EQ. 3) THEN GOTO 540 ENDIF C GO TO (300, 530, 540), KGO C----------------------------------------------------------------------- C Block F. C The following block handles the case of a successful return from the C core integrator (KFLAG = 0). Test for stop conditions. C----------------------------------------------------------------------- 300 INIT = 1 IF (ITASK .EQ. 1) THEN GOTO 310 ELSE IF (ITASK .EQ. 2) THEN GOTO 400 ELSE IF (ITASK .EQ. 3) THEN GOTO 330 ELSE IF (ITASK .EQ. 4) THEN GOTO 340 ELSE IF (ITASK .EQ. 5) THEN GOTO 350 ENDIF C karline: change from C GO TO (310, 400, 330, 340, 350), ITASK C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 310 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 GO TO 250 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 345 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) JSTART = -2 GO TO 250 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 350 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX C----------------------------------------------------------------------- C Block G. C The following block handles all successful returns from DLSODE. C If ITASK .NE. 1, Y is loaded from YH and T is set accordingly. C ISTATE is set to 2, and the optional outputs are loaded into the C work arrays before returning. C----------------------------------------------------------------------- 400 DO 410 I = 1,N Y(I) = RWORK(I+LYH-1) 410 CONTINUE T = TN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 IF (IHIT) T = TCRIT 420 ISTATE = 2 RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ RETURN C----------------------------------------------------------------------- C Block H. C The following block handles all unsuccessful returns other than C those for illegal input. First the error message routine is called. C If there was an error test or convergence test failure, IMXER is set. C Then Y is loaded from YH and T is set to TN. The optional outputs C are loaded into the work arrays before returning. C----------------------------------------------------------------------- C The maximum number of steps was taken before reaching TOUT. ---------- 500 MSG = 'DLSODE- At current T (=R1), MXSTEP (=I1) steps ' CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' taken on this call before reaching TOUT ' CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) ISTATE = -1 GO TO 580 C EWT(I) .LE. 0.0 for some I (not at start of problem). ---------------- 510 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODE- At T (=R1), EWT(I1) has become R2 .LE. 0.' CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) ISTATE = -6 GO TO 580 C Too much accuracy requested for machine precision. ------------------- 520 MSG = 'DLSODE- At T (=R1), too much accuracy requested ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' for precision of machine.. see TOLSF (=R2) ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) RWORK(14) = TOLSF ISTATE = -2 GO TO 580 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 530 MSG = 'DLSODE- At T(=R1) and step size H(=R2), the error' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' test failed repeatedly or with ABS(H) = HMIN' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) ISTATE = -4 GO TO 560 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 540 MSG = 'DLSODE- At T (=R1) and step size H (=R2), the ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' corrector convergence failed repeatedly ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' or with ABS(H) = HMIN ' CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) ISTATE = -5 C Compute IMXER if relevant. ------------------------------------------- 560 BIG = 0.0D0 IMXER = 1 DO 570 I = 1,N SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) IF (BIG .GE. SIZE) GO TO 570 BIG = SIZE IMXER = I 570 CONTINUE IWORK(16) = IMXER C Set Y vector, T, and optional outputs. ------------------------------- 580 DO 590 I = 1,N Y(I) = RWORK(I+LYH-1) 590 CONTINUE T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ RETURN C----------------------------------------------------------------------- C Block I. C The following block handles all error returns due to illegal input C (ISTATE = -3), as detected before calling the core integrator. C First the error message routine is called. If the illegal input C is a negative ISTATE, the run is aborted (apparent infinite loop). C----------------------------------------------------------------------- 601 MSG = 'DLSODE- ISTATE (=I1) illegal ' CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) IF (ISTATE .LT. 0) GO TO 800 GO TO 700 602 MSG = 'DLSODE- ITASK (=I1) illegal ' CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) GO TO 700 603 MSG = 'DLSODE- ISTATE .GT. 1 but DLSODE not initialized ' CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) GO TO 700 604 MSG = 'DLSODE- NEQ (=I1) .LT. 1 ' CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) GO TO 700 605 MSG = 'DLSODE- ISTATE = 3 and NEQ increased (I1 to I2) ' CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 606 MSG = 'DLSODE- ITOL (=I1) illegal ' CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) GO TO 700 607 MSG = 'DLSODE- IOPT (=I1) illegal ' CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) GO TO 700 608 MSG = 'DLSODE- MF (=I1) illegal ' CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) GO TO 700 609 MSG = 'DLSODE- ML (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)' CALL XERRWD (MSG, 50, 9, 0, 2, ML, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 610 MSG = 'DLSODE- MU (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)' CALL XERRWD (MSG, 50, 10, 0, 2, MU, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 611 MSG = 'DLSODE- MAXORD (=I1) .LT. 0 ' CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) GO TO 700 612 MSG = 'DLSODE- MXSTEP (=I1) .LT. 0 ' CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) GO TO 700 613 MSG = 'DLSODE- MXHNIL (=I1) .LT. 0 ' CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) GO TO 700 614 MSG = 'DLSODE- TOUT (=R1) behind T (=R2) ' CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) MSG = ' Integration direction is given by H0 (=R1) ' CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) GO TO 700 615 MSG = 'DLSODE- HMAX (=R1) .LT. 0.0 ' CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) GO TO 700 616 MSG = 'DLSODE- HMIN (=R1) .LT. 0.0 ' CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) GO TO 700 617 CONTINUE MSG='DLSODE- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 618 CONTINUE MSG='DLSODE- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) GO TO 700 619 MSG = 'DLSODE- RTOL(I1) is R1 .LT. 0.0 ' CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) GO TO 700 620 MSG = 'DLSODE- ATOL(I1) is R1 .LT. 0.0 ' CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) GO TO 700 621 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODE- EWT(I1) is R1 .LE. 0.0 ' CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) GO TO 700 622 CONTINUE MSG='DLSODE- TOUT (=R1) too close to T(=R2) to start integration' CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) GO TO 700 623 CONTINUE MSG='DLSODE- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) GO TO 700 624 CONTINUE MSG='DLSODE- ITASK = 4 OR 5 and TCRIT (=R1) behind TCUR (=R2) ' CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) GO TO 700 625 CONTINUE MSG='DLSODE- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) GO TO 700 626 MSG = 'DLSODE- At start of problem, too much accuracy ' CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' requested for precision of machine.. See TOLSF (=R1) ' CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) RWORK(14) = TOLSF GO TO 700 627 MSG = 'DLSODE- Trouble in DINTDY. ITASK = I1, TOUT = R1' CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) C 700 ISTATE = -3 RETURN C 800 MSG = 'DLSODE- Run aborted.. apparent infinite loop ' CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) RETURN C----------------------- END OF SUBROUTINE DLSODE ---------------------- END *DECK DLSODES SUBROUTINE DLSODES (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW,IWK, JAC, MF, rpar, 2 ipar) EXTERNAL F, JAC CKS: added rpar, ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK INTEGER IWK(2*LRW) DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW) C----------------------------------------------------------------------- C This is the 12 November 2003 version of C DLSODES: Livermore Solver for Ordinary Differential Equations C with general Sparse Jacobian matrix. C C This version is in double precision. C C DLSODES solves the initial value problem for stiff or nonstiff C systems of first order ODEs, C dy/dt = f(t,y) , or, in component form, C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). C DLSODES is a variant of the DLSODE package, and is intended for C problems in which the Jacobian matrix df/dy has an arbitrary C sparse structure (when the problem is stiff). C C Authors: Alan C. Hindmarsh C Center for Applied Scientific Computing, L-561 C Lawrence Livermore National Laboratory C Livermore, CA 94551 C and C Andrew H. Sherman C J. S. Nolen and Associates C Houston, TX 77084 C----------------------------------------------------------------------- C References: C 1. Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), C North-Holland, Amsterdam, 1983, pp. 55-64. C C 2. S. C. Eisenstat, M. C. Gursky, M. H. Schultz, and A. H. Sherman, C Yale Sparse Matrix Package: I. The Symmetric Codes, C Int. J. Num. Meth. Eng., 18 (1982), pp. 1145-1151. C C 3. S. C. Eisenstat, M. C. Gursky, M. H. Schultz, and A. H. Sherman, C Yale Sparse Matrix Package: II. The Nonsymmetric Codes, C Research Report No. 114, Dept. of Computer Sciences, Yale C University, 1977. C----------------------------------------------------------------------- C Summary of Usage. C C Communication between the user and the DLSODES package, for normal C situations, is summarized here. This summary describes only a subset C of the full set of options available. See the full description for C details, including optional communication, nonstandard options, C and instructions for special situations. See also the example C problem (with program and output) following this summary. C C A. First provide a subroutine of the form: C SUBROUTINE F (NEQ, T, Y, YDOT,rpar,ipar) C INTEGER NEQ,ipar(*) C DOUBLE PRECISION T, Y(*), YDOT(*),rpar(*) C which supplies the vector function f by loading YDOT(i) with f(i). C C B. Next determine (or guess) whether or not the problem is stiff. C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue C whose real part is negative and large in magnitude, compared to the C reciprocal of the t span of interest. If the problem is nonstiff, C use a method flag MF = 10. If it is stiff, there are two standard C choices for the method flag, MF = 121 and MF = 222. In both cases, C DLSODES requires the Jacobian matrix in some form, and it treats this C matrix in general sparse form, with sparsity structure determined C internally. (For options where the user supplies the sparsity C structure, see the full description of MF below.) C C C. If the problem is stiff, you are encouraged to supply the Jacobian C directly (MF = 121), but if this is not feasible, DLSODES will C compute it internally by difference quotients (MF = 222). C If you are supplying the Jacobian, provide a subroutine of the form: C SUBROUTINE JAC (NEQ, T, Y, J, IAN, JAN, PDJ, rpar,ipar) C DOUBLE PRECISION T, Y(*), IAN(*), JAN(*), PDJ(*),rpar(*) C Here NEQ, T, Y, and J are input arguments, and the JAC routine is to C load the array PDJ (of length NEQ) with the J-th column of df/dy. C I.e., load PDJ(i) with df(i)/dy(J) for all relevant values of i. C The arguments IAN and JAN should be ignored for normal situations. C DLSODES will call the JAC routine with J = 1,2,...,NEQ. C Only nonzero elements need be loaded. Usually, a crude approximation C to df/dy, possibly with fewer nonzero elements, will suffice. C C D. Write a main program which calls Subroutine DLSODES once for C each point at which answers are desired. This should also provide C for possible use of logical unit 6 for output of error messages by C DLSODES. On the first call to DLSODES, supply arguments as follows: C F = name of subroutine for right-hand side vector f. C This name must be declared External in calling program. C NEQ = number of first order ODEs. C Y = array of initial values, of length NEQ. C T = the initial value of the independent variable t. C TOUT = first point where output is desired (.ne. T). C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. C RTOL = relative tolerance parameter (scalar). C ATOL = absolute tolerance parameter (scalar or array). C The estimated local error in Y(i) will be controlled so as C to be roughly less (in magnitude) than C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. C Thus the local error test passes if, in each component, C either the absolute error is less than ATOL (or ATOL(i)), C or the relative error is less than RTOL. C Use RTOL = 0.0 for pure absolute error control, and C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error C control. Caution: actual (global) errors may exceed these C local tolerances, so choose them conservatively. C ITASK = 1 for normal computation of output values of Y at t = TOUT. C ISTATE = integer flag (input and output). Set ISTATE = 1. C IOPT = 0 to indicate no optional inputs used. C RWORK = real work array of length at least: C 20 + 16*NEQ for MF = 10, C 20 + (2 + 1./LENRAT)*NNZ + (11 + 9./LENRAT)*NEQ C for MF = 121 or 222, C where: C NNZ = the number of nonzero elements in the sparse C Jacobian (if this is unknown, use an estimate), and C LENRAT = the real to integer wordlength ratio (usually 1 in C single precision and 2 in double precision). C In any case, the required size of RWORK cannot generally C be predicted in advance if MF = 121 or 222, and the value C above is a rough estimate of a crude lower bound. Some C experimentation with this size may be necessary. C (When known, the correct required length is an optional C output, available in IWORK(17).) C LRW = declared length of RWORK (in user dimension). C IWORK = integer work array of length at least 30. C LIW = declared length of IWORK (in user dimension). C JAC = name of subroutine for Jacobian matrix (MF = 121). C If used, this name must be declared External in calling C program. If not used, pass a dummy name. C MF = method flag. Standard values are: C 10 for nonstiff (Adams) method, no Jacobian used C 121 for stiff (BDF) method, user-supplied sparse Jacobian C 222 for stiff method, internally generated sparse Jacobian C Note that the main program must declare arrays Y, RWORK, IWORK, C and possibly ATOL. C C E. The output from the first call (or any call) is: C Y = array of computed values of y(t) vector. C T = corresponding value of independent variable (normally TOUT). C ISTATE = 2 if DLSODES was successful, negative otherwise. C -1 means excess work done on this call (perhaps wrong MF). C -2 means excess accuracy requested (tolerances too small). C -3 means illegal input detected (see printed message). C -4 means repeated error test failures (check all inputs). C -5 means repeated convergence failures (perhaps bad Jacobian C supplied or wrong choice of MF or tolerances). C -6 means error weight became zero during problem. (Solution C component i vanished, and ATOL or ATOL(i) = 0.) C -7 means a fatal error return flag came from sparse solver C CDRV by way of DPRJS or DSOLSS. Should never happen. C A return with ISTATE = -1, -4, or -5 may result from using C an inappropriate sparsity structure, one that is quite C different from the initial structure. Consider calling C DLSODES again with ISTATE = 3 to force the structure to be C reevaluated. See the full description of ISTATE below. C C F. To continue the integration after a successful return, simply C reset TOUT and call DLSODES again. No other parameters need be reset. C C----------------------------------------------------------------------- C Example Problem. C C The following is a simple example problem, with the coding C needed for its solution by DLSODES. The problem is from chemical C kinetics, and consists of the following 12 rate equations: C dy1/dt = -rk1*y1 C dy2/dt = rk1*y1 + rk11*rk14*y4 + rk19*rk14*y5 C - rk3*y2*y3 - rk15*y2*y12 - rk2*y2 C dy3/dt = rk2*y2 - rk5*y3 - rk3*y2*y3 - rk7*y10*y3 C + rk11*rk14*y4 + rk12*rk14*y6 C dy4/dt = rk3*y2*y3 - rk11*rk14*y4 - rk4*y4 C dy5/dt = rk15*y2*y12 - rk19*rk14*y5 - rk16*y5 C dy6/dt = rk7*y10*y3 - rk12*rk14*y6 - rk8*y6 C dy7/dt = rk17*y10*y12 - rk20*rk14*y7 - rk18*y7 C dy8/dt = rk9*y10 - rk13*rk14*y8 - rk10*y8 C dy9/dt = rk4*y4 + rk16*y5 + rk8*y6 + rk18*y7 C dy10/dt = rk5*y3 + rk12*rk14*y6 + rk20*rk14*y7 C + rk13*rk14*y8 - rk7*y10*y3 - rk17*y10*y12 C - rk6*y10 - rk9*y10 C dy11/dt = rk10*y8 C dy12/dt = rk6*y10 + rk19*rk14*y5 + rk20*rk14*y7 C - rk15*y2*y12 - rk17*y10*y12 C C with rk1 = rk5 = 0.1, rk4 = rk8 = rk16 = rk18 = 2.5, C rk10 = 5.0, rk2 = rk6 = 10.0, rk14 = 30.0, C rk3 = rk7 = rk9 = rk11 = rk12 = rk13 = rk19 = rk20 = 50.0, C rk15 = rk17 = 100.0. C C The t interval is from 0 to 1000, and the initial conditions C are y1 = 1, y2 = y3 = ... = y12 = 0. The problem is stiff. C C The following coding solves this problem with DLSODES, using MF = 121 C and printing results at t = .1, 1., 10., 100., 1000. It uses C ITOL = 1 and mixed relative/absolute tolerance controls. C During the run and at the end, statistical quantities of interest C are printed (see optional outputs in the full description below). C C EXTERNAL FEX, JEX C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y C DIMENSION Y(12), RWORK(500), IWORK(30) C DATA LRW/500/, LIW/30/ C NEQ = 12 C DO 10 I = 1,NEQ C 10 Y(I) = 0.0D0 C Y(1) = 1.0D0 C T = 0.0D0 C TOUT = 0.1D0 C ITOL = 1 C RTOL = 1.0D-4 C ATOL = 1.0D-6 C ITASK = 1 C ISTATE = 1 C IOPT = 0 C MF = 121 C DO 40 IOUT = 1,5 C CALL DLSODES (FEX, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, C 1 ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JEX, MF) C WRITE(6,30)T,IWORK(11),RWORK(11),(Y(I),I=1,NEQ) C 30 FORMAT(//' At t =',D11.3,4X, C 1 ' No. steps =',I5,4X,' Last step =',D11.3/ C 2 ' Y array = ',4D14.5/13X,4D14.5/13X,4D14.5) C IF (ISTATE .LT. 0) GO TO 80 C TOUT = TOUT*10.0D0 C 40 CONTINUE C LENRW = IWORK(17) C LENIW = IWORK(18) C NST = IWORK(11) C NFE = IWORK(12) C NJE = IWORK(13) C NLU = IWORK(21) C NNZ = IWORK(19) C NNZLU = IWORK(25) + IWORK(26) + NEQ C WRITE (6,70) LENRW,LENIW,NST,NFE,NJE,NLU,NNZ,NNZLU C 70 FORMAT(//' Required RWORK size =',I4,' IWORK size =',I4/ C 1 ' No. steps =',I4,' No. f-s =',I4,' No. J-s =',I4, C 2 ' No. LU-s =',I4/' No. of nonzeros in J =',I5, C 3 ' No. of nonzeros in LU =',I5) C STOP C 80 WRITE(6,90)ISTATE C 90 FORMAT(///' Error halt.. ISTATE =',I3) C STOP C END C C SUBROUTINE FEX (NEQ, T, Y, YDOT,rpar,ipar) C DOUBLE PRECISION T, Y, YDOT,rpar(*) C DOUBLE PRECISION RK1, RK2, RK3, RK4, RK5, RK6, RK7, RK8, RK9, C 1 RK10, RK11, RK12, RK13, RK14, RK15, RK16, RK17 C DIMENSION Y(12), YDOT(12) C DATA RK1/0.1D0/, RK2/10.0D0/, RK3/50.0D0/, RK4/2.5D0/, RK5/0.1D0/, C 1 RK6/10.0D0/, RK7/50.0D0/, RK8/2.5D0/, RK9/50.0D0/, RK10/5.0D0/, C 2 RK11/50.0D0/, RK12/50.0D0/, RK13/50.0D0/, RK14/30.0D0/, C 3 RK15/100.0D0/, RK16/2.5D0/, RK17/100.0D0/, RK18/2.5D0/, C 4 RK19/50.0D0/, RK20/50.0D0/ C YDOT(1) = -RK1*Y(1) C YDOT(2) = RK1*Y(1) + RK11*RK14*Y(4) + RK19*RK14*Y(5) C 1 - RK3*Y(2)*Y(3) - RK15*Y(2)*Y(12) - RK2*Y(2) C YDOT(3) = RK2*Y(2) - RK5*Y(3) - RK3*Y(2)*Y(3) - RK7*Y(10)*Y(3) C 1 + RK11*RK14*Y(4) + RK12*RK14*Y(6) C YDOT(4) = RK3*Y(2)*Y(3) - RK11*RK14*Y(4) - RK4*Y(4) C YDOT(5) = RK15*Y(2)*Y(12) - RK19*RK14*Y(5) - RK16*Y(5) C YDOT(6) = RK7*Y(10)*Y(3) - RK12*RK14*Y(6) - RK8*Y(6) C YDOT(7) = RK17*Y(10)*Y(12) - RK20*RK14*Y(7) - RK18*Y(7) C YDOT(8) = RK9*Y(10) - RK13*RK14*Y(8) - RK10*Y(8) C YDOT(9) = RK4*Y(4) + RK16*Y(5) + RK8*Y(6) + RK18*Y(7) C YDOT(10) = RK5*Y(3) + RK12*RK14*Y(6) + RK20*RK14*Y(7) C 1 + RK13*RK14*Y(8) - RK7*Y(10)*Y(3) - RK17*Y(10)*Y(12) C 2 - RK6*Y(10) - RK9*Y(10) C YDOT(11) = RK10*Y(8) C YDOT(12) = RK6*Y(10) + RK19*RK14*Y(5) + RK20*RK14*Y(7) C 1 - RK15*Y(2)*Y(12) - RK17*Y(10)*Y(12) C RETURN C END C C SUBROUTINE JEX (NEQ, T, Y, J, IA, JA, PDJ,rpar,ipar) C DOUBLE PRECISION T, Y, PDJ,rpar(*) C DOUBLE PRECISION RK1, RK2, RK3, RK4, RK5, RK6, RK7, RK8, RK9, C 1 RK10, RK11, RK12, RK13, RK14, RK15, RK16, RK17 C DIMENSION Y(12), IA(*), JA(*), PDJ(12) C DATA RK1/0.1D0/, RK2/10.0D0/, RK3/50.0D0/, RK4/2.5D0/, RK5/0.1D0/, C 1 RK6/10.0D0/, RK7/50.0D0/, RK8/2.5D0/, RK9/50.0D0/, RK10/5.0D0/, C 2 RK11/50.0D0/, RK12/50.0D0/, RK13/50.0D0/, RK14/30.0D0/, C 3 RK15/100.0D0/, RK16/2.5D0/, RK17/100.0D0/, RK18/2.5D0/, C 4 RK19/50.0D0/, RK20/50.0D0/ C GO TO (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12), J C 1 PDJ(1) = -RK1 C PDJ(2) = RK1 C RETURN C 2 PDJ(2) = -RK3*Y(3) - RK15*Y(12) - RK2 C PDJ(3) = RK2 - RK3*Y(3) C PDJ(4) = RK3*Y(3) C PDJ(5) = RK15*Y(12) C PDJ(12) = -RK15*Y(12) C RETURN C 3 PDJ(2) = -RK3*Y(2) C PDJ(3) = -RK5 - RK3*Y(2) - RK7*Y(10) C PDJ(4) = RK3*Y(2) C PDJ(6) = RK7*Y(10) C PDJ(10) = RK5 - RK7*Y(10) C RETURN C 4 PDJ(2) = RK11*RK14 C PDJ(3) = RK11*RK14 C PDJ(4) = -RK11*RK14 - RK4 C PDJ(9) = RK4 C RETURN C 5 PDJ(2) = RK19*RK14 C PDJ(5) = -RK19*RK14 - RK16 C PDJ(9) = RK16 C PDJ(12) = RK19*RK14 C RETURN C 6 PDJ(3) = RK12*RK14 C PDJ(6) = -RK12*RK14 - RK8 C PDJ(9) = RK8 C PDJ(10) = RK12*RK14 C RETURN C 7 PDJ(7) = -RK20*RK14 - RK18 C PDJ(9) = RK18 C PDJ(10) = RK20*RK14 C PDJ(12) = RK20*RK14 C RETURN C 8 PDJ(8) = -RK13*RK14 - RK10 C PDJ(10) = RK13*RK14 C PDJ(11) = RK10 C 9 RETURN C 10 PDJ(3) = -RK7*Y(3) C PDJ(6) = RK7*Y(3) C PDJ(7) = RK17*Y(12) C PDJ(8) = RK9 C PDJ(10) = -RK7*Y(3) - RK17*Y(12) - RK6 - RK9 C PDJ(12) = RK6 - RK17*Y(12) C 11 RETURN C 12 PDJ(2) = -RK15*Y(2) C PDJ(5) = RK15*Y(2) C PDJ(7) = RK17*Y(10) C PDJ(10) = -RK17*Y(10) C PDJ(12) = -RK15*Y(2) - RK17*Y(10) C RETURN C END C C The output of this program (on a Cray-1 in single precision) C is as follows: C C C At t = 1.000e-01 No. steps = 12 Last step = 1.515e-02 C Y array = 9.90050e-01 6.28228e-03 3.65313e-03 7.51934e-07 C 1.12167e-09 1.18458e-09 1.77291e-12 3.26476e-07 C 5.46720e-08 9.99500e-06 4.48483e-08 2.76398e-06 C C C At t = 1.000e+00 No. steps = 33 Last step = 7.880e-02 C Y array = 9.04837e-01 9.13105e-03 8.20622e-02 2.49177e-05 C 1.85055e-06 1.96797e-06 1.46157e-07 2.39557e-05 C 3.26306e-05 7.21621e-04 5.06433e-05 3.05010e-03 C C C At t = 1.000e+01 No. steps = 48 Last step = 1.239e+00 C Y array = 3.67876e-01 3.68958e-03 3.65133e-01 4.48325e-05 C 6.10798e-05 4.33148e-05 5.90211e-05 1.18449e-04 C 3.15235e-03 3.56531e-03 4.15520e-03 2.48741e-01 C C C At t = 1.000e+02 No. steps = 91 Last step = 3.764e+00 C Y array = 4.44981e-05 4.42666e-07 4.47273e-04 -3.53257e-11 C 2.81577e-08 -9.67741e-11 2.77615e-07 1.45322e-07 C 1.56230e-02 4.37394e-06 1.60104e-02 9.52246e-01 C C C At t = 1.000e+03 No. steps = 111 Last step = 4.156e+02 C Y array = -2.65492e-13 2.60539e-14 -8.59563e-12 6.29355e-14 C -1.78066e-13 5.71471e-13 -1.47561e-12 4.58078e-15 C 1.56314e-02 1.37878e-13 1.60184e-02 9.52719e-01 C C C Required RWORK size = 442 IWORK size = 30 C No. steps = 111 No. f-s = 142 No. J-s = 2 No. LU-s = 20 C No. of nonzeros in J = 44 No. of nonzeros in LU = 50 C C----------------------------------------------------------------------- C Full Description of User Interface to DLSODES. C C The user interface to DLSODES consists of the following parts. C C 1. The call sequence to Subroutine DLSODES, which is a driver C routine for the solver. This includes descriptions of both C the call sequence arguments and of user-supplied routines. C Following these descriptions is a description of C optional inputs available through the call sequence, and then C a description of optional outputs (in the work arrays). C C 2. Descriptions of other routines in the DLSODES package that may be C (optionally) called by the user. These provide the ability to C alter error message handling, save and restore the internal C Common, and obtain specified derivatives of the solution y(t). C C 3. Descriptions of Common blocks to be declared in overlay C or similar environments, or to be saved when doing an interrupt C of the problem and continued solution later. C C 4. Description of two routines in the DLSODES package, either of C which the user may replace with his/her own version, if desired. C These relate to the measurement of errors. C C----------------------------------------------------------------------- C Part 1. Call Sequence. C C The call sequence parameters used for input only are C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF, C and those used for both input and output are C Y, T, ISTATE. C The work arrays RWORK and IWORK are also used for conditional and C optional inputs and optional outputs. (The term output here refers C to the return from Subroutine DLSODES to the user's calling program.) C C The legality of input parameters will be thoroughly checked on the C initial call for the problem, but not checked thereafter unless a C change in input parameters is flagged by ISTATE = 3 on input. C C The descriptions of the call arguments are as follows. C C F = the name of the user-supplied subroutine defining the C ODE system. The system must be put in the first-order C form dy/dt = f(t,y), where f is a vector-valued function C of the scalar t and the vector y. Subroutine F is to C compute the function f. It is to have the form C SUBROUTINE F (NEQ, T, Y, YDOT,rpar,ipar) C INTEGER NEQ,ipar(*) C DOUBLE PRECISION T, Y(*), YDOT(*),rpar(*) C where NEQ, T, and Y are input, and the array YDOT = f(t,y) C is output. Y and YDOT are arrays of length NEQ. C Subroutine F should not alter y(1),...,y(NEQ). C F must be declared External in the calling program. C C Subroutine F may access user-defined quantities in C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array C (dimensioned in F) and/or Y has length exceeding NEQ(1). C See the descriptions of NEQ and Y below. C C If quantities computed in the F routine are needed C externally to DLSODES, an extra call to F should be made C for this purpose, for consistent and accurate results. C If only the derivative dy/dt is needed, use DINTDY instead. C C NEQ = the size of the ODE system (number of first order C ordinary differential equations). Used only for input. C NEQ may be decreased, but not increased, during the problem. C If NEQ is decreased (with ISTATE = 3 on input), the C remaining components of Y should be left undisturbed, if C these are to be accessed in F and/or JAC. C C Normally, NEQ is a scalar, and it is generally referred to C as a scalar in this user interface description. However, C NEQ may be an array, with NEQ(1) set to the system size. C (The DLSODES package accesses only NEQ(1).) In either case, C this parameter is passed as the NEQ argument in all calls C to F and JAC. Hence, if it is an array, locations C NEQ(2),... may be used to store other integer data and pass C it to F and/or JAC. Subroutines F and/or JAC must include C NEQ in a Dimension statement in that case. C C Y = a real array for the vector of dependent variables, of C length NEQ or more. Used for both input and output on the C first call (ISTATE = 1), and only for output on other calls. C on the first call, Y must contain the vector of initial C values. On output, Y contains the computed solution vector, C evaluated at T. If desired, the Y array may be used C for other purposes between calls to the solver. C C This array is passed as the Y argument in all calls to C F and JAC. Hence its length may exceed NEQ, and locations C Y(NEQ+1),... may be used to store other real data and C pass it to F and/or JAC. (The DLSODES package accesses only C Y(1),...,Y(NEQ).) C C T = the independent variable. On input, T is used only on the C first call, as the initial point of the integration. C on output, after each call, T is the value at which a C computed solution Y is evaluated (usually the same as TOUT). C On an error return, T is the farthest point reached. C C TOUT = the next value of t at which a computed solution is desired. C Used only for input. C C When starting the problem (ISTATE = 1), TOUT may be equal C to T for one call, then should .ne. T for the next call. C For the initial T, an input value of TOUT .ne. T is used C in order to determine the direction of the integration C (i.e. the algebraic sign of the step sizes) and the rough C scale of the problem. Integration in either direction C (forward or backward in t) is permitted. C C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after C the first call (i.e. the first call with TOUT .ne. T). C Otherwise, TOUT is required on every call. C C If ITASK = 1, 3, or 4, the values of TOUT need not be C monotone, but a value of TOUT which backs up is limited C to the current internal T interval, whose endpoints are C TCUR - HU and TCUR (see optional outputs, below, for C TCUR and HU). C C ITOL = an indicator for the type of error control. See C description below under ATOL. Used only for input. C C RTOL = a relative error tolerance parameter, either a scalar or C an array of length NEQ. See description below under ATOL. C Input only. C C ATOL = an absolute error tolerance parameter, either a scalar or C an array of length NEQ. Input only. C C The input parameters ITOL, RTOL, and ATOL determine C the error control performed by the solver. The solver will C control the vector E = (E(i)) of estimated local errors C in y, according to an inequality of the form C RMS-norm of ( E(i)/EWT(i) ) .le. 1, C where EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i), C and the RMS-norm (root-mean-square norm) here is C RMS-norm(v) = SQRT(sum v(i)**2 / NEQ). Here EWT = (EWT(i)) C is a vector of weights which must always be positive, and C the values of RTOL and ATOL should all be non-negative. C The following table gives the types (scalar/array) of C RTOL and ATOL, and the corresponding form of EWT(i). C C ITOL RTOL ATOL EWT(i) C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) C C When either of these parameters is a scalar, it need not C be dimensioned in the user's calling program. C C If none of the above choices (with ITOL, RTOL, and ATOL C fixed throughout the problem) is suitable, more general C error controls can be obtained by substituting C user-supplied routines for the setting of EWT and/or for C the norm calculation. See Part 4 below. C C If global errors are to be estimated by making a repeated C run on the same problem with smaller tolerances, then all C components of RTOL and ATOL (i.e. of EWT) should be scaled C down uniformly. C C ITASK = an index specifying the task to be performed. C Input only. ITASK has the following values and meanings. C 1 means normal computation of output values of y(t) at C t = TOUT (by overshooting and interpolating). C 2 means take one step only and return. C 3 means stop at the first internal mesh point at or C beyond t = TOUT and return. C 4 means normal computation of output values of y(t) at C t = TOUT but without overshooting t = TCRIT. C TCRIT must be input as RWORK(1). TCRIT may be equal to C or beyond TOUT, but not behind it in the direction of C integration. This option is useful if the problem C has a singularity at or beyond t = TCRIT. C 5 means take one step, without passing TCRIT, and return. C TCRIT must be input as RWORK(1). C C Note: If ITASK = 4 or 5 and the solver reaches TCRIT C (within roundoff), it will return T = TCRIT (exactly) to C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, C in which case answers at t = TOUT are returned first). C C ISTATE = an index used for input and output to specify the C the state of the calculation. C C On input, the values of ISTATE are as follows. C 1 means this is the first call for the problem C (initializations will be done). See note below. C 2 means this is not the first call, and the calculation C is to continue normally, with no change in any input C parameters except possibly TOUT and ITASK. C (If ITOL, RTOL, and/or ATOL are changed between calls C with ISTATE = 2, the new values will be used but not C tested for legality.) C 3 means this is not the first call, and the C calculation is to continue normally, but with C a change in input parameters other than C TOUT and ITASK. Changes are allowed in C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, C the conditional inputs IA and JA, C and any of the optional inputs except H0. C In particular, if MITER = 1 or 2, a call with ISTATE = 3 C will cause the sparsity structure of the problem to be C recomputed (or reread from IA and JA if MOSS = 0). C Note: a preliminary call with TOUT = T is not counted C as a first call here, as no initialization or checking of C input is done. (Such a call is sometimes useful for the C purpose of outputting the initial conditions.) C Thus the first call for which TOUT .ne. T requires C ISTATE = 1 on input. C C On output, ISTATE has the following values and meanings. C 1 means nothing was done; TOUT = T and ISTATE = 1 on input. C 2 means the integration was performed successfully. C -1 means an excessive amount of work (more than MXSTEP C steps) was done on this call, before completing the C requested task, but the integration was otherwise C successful as far as T. (MXSTEP is an optional input C and is normally 500.) To continue, the user may C simply reset ISTATE to a value .gt. 1 and call again C (the excess work step counter will be reset to 0). C In addition, the user may increase MXSTEP to avoid C this error return (see below on optional inputs). C -2 means too much accuracy was requested for the precision C of the machine being used. This was detected before C completing the requested task, but the integration C was successful as far as T. To continue, the tolerance C parameters must be reset, and ISTATE must be set C to 3. The optional output TOLSF may be used for this C purpose. (Note: If this condition is detected before C taking any steps, then an illegal input return C (ISTATE = -3) occurs instead.) C -3 means illegal input was detected, before taking any C integration steps. See written message for details. C Note: If the solver detects an infinite loop of calls C to the solver with illegal input, it will cause C the run to stop. C -4 means there were repeated error test failures on C one attempted step, before completing the requested C task, but the integration was successful as far as T. C The problem may have a singularity, or the input C may be inappropriate. C -5 means there were repeated convergence test failures on C one attempted step, before completing the requested C task, but the integration was successful as far as T. C This may be caused by an inaccurate Jacobian matrix, C if one is being used. C -6 means EWT(i) became zero for some i during the C integration. Pure relative error control (ATOL(i)=0.0) C was requested on a variable which has now vanished. C The integration was successful as far as T. C -7 means a fatal error return flag came from the sparse C solver CDRV by way of DPRJS or DSOLSS (numerical C factorization or backsolve). This should never happen. C The integration was successful as far as T. C C Note: an error return with ISTATE = -1, -4, or -5 and with C MITER = 1 or 2 may mean that the sparsity structure of the C problem has changed significantly since it was last C determined (or input). In that case, one can attempt to C complete the integration by setting ISTATE = 3 on the next C call, so that a new structure determination is done. C C Note: since the normal output value of ISTATE is 2, C it does not need to be reset for normal continuation. C Also, since a negative input value of ISTATE will be C regarded as illegal, a negative output value requires the C user to change it, and possibly other inputs, before C calling the solver again. C C IOPT = an integer flag to specify whether or not any optional C inputs are being used on this call. Input only. C The optional inputs are listed separately below. C IOPT = 0 means no optional inputs are being used. C Default values will be used in all cases. C IOPT = 1 means one or more optional inputs are being used. C C RWORK = a work array used for a mixture of real (double precision) C and integer work space. C The length of RWORK (in real words) must be at least C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM where C NYH = the initial value of NEQ, C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a C smaller value is given as an optional input), C LWM = 0 if MITER = 0, C LWM = 2*NNZ + 2*NEQ + (NNZ+9*NEQ)/LENRAT if MITER = 1, C LWM = 2*NNZ + 2*NEQ + (NNZ+10*NEQ)/LENRAT if MITER = 2, C LWM = NEQ + 2 if MITER = 3. C In the above formulas, C NNZ = number of nonzero elements in the Jacobian matrix. C LENRAT = the real to integer wordlength ratio (usually 1 in C single precision and 2 in double precision). C (See the MF description for METH and MITER.) C Thus if MAXORD has its default value and NEQ is constant, C the minimum length of RWORK is: C 20 + 16*NEQ for MF = 10, C 20 + 16*NEQ + LWM for MF = 11, 111, 211, 12, 112, 212, C 22 + 17*NEQ for MF = 13, C 20 + 9*NEQ for MF = 20, C 20 + 9*NEQ + LWM for MF = 21, 121, 221, 22, 122, 222, C 22 + 10*NEQ for MF = 23. C If MITER = 1 or 2, the above formula for LWM is only a C crude lower bound. The required length of RWORK cannot C be readily predicted in general, as it depends on the C sparsity structure of the problem. Some experimentation C may be necessary. C C The first 20 words of RWORK are reserved for conditional C and optional inputs and optional outputs. C C The following word in RWORK is a conditional input: C RWORK(1) = TCRIT = critical value of t which the solver C is not to overshoot. Required if ITASK is C 4 or 5, and ignored otherwise. (See ITASK.) C C LRW = the length of the array RWORK, as declared by the user. C (This will be checked by the solver.) C C IWORK = an integer work array. The length of IWORK must be at least C 31 + NEQ + NNZ if MOSS = 0 and MITER = 1 or 2, or C 30 otherwise. C (NNZ is the number of nonzero elements in df/dy.) C C In DLSODES, IWORK is used only for conditional and C optional inputs and optional outputs. C C The following two blocks of words in IWORK are conditional C inputs, required if MOSS = 0 and MITER = 1 or 2, but not C otherwise (see the description of MF for MOSS). C IWORK(30+j) = IA(j) (j=1,...,NEQ+1) C IWORK(31+NEQ+k) = JA(k) (k=1,...,NNZ) C The two arrays IA and JA describe the sparsity structure C to be assumed for the Jacobian matrix. JA contains the row C indices where nonzero elements occur, reading in columnwise C order, and IA contains the starting locations in JA of the C descriptions of columns 1,...,NEQ, in that order, with C IA(1) = 1. Thus, for each column index j = 1,...,NEQ, the C values of the row index i in column j where a nonzero C element may occur are given by C i = JA(k), where IA(j) .le. k .lt. IA(j+1). C If NNZ is the total number of nonzero locations assumed, C then the length of the JA array is NNZ, and IA(NEQ+1) must C be NNZ + 1. Duplicate entries are not allowed. C C LIW = the length of the array IWORK, as declared by the user. C (This will be checked by the solver.) C C Note: The work arrays must not be altered between calls to DLSODES C for the same problem, except possibly for the conditional and C optional inputs, and except for the last 3*NEQ words of RWORK. C The latter space is used for internal scratch space, and so is C available for use by the user outside DLSODES between calls, if C desired (but not for use by F or JAC). C C JAC = name of user-supplied routine (MITER = 1 or MOSS = 1) to C compute the Jacobian matrix, df/dy, as a function of C the scalar t and the vector y. It is to have the form C SUBROUTINE JAC (NEQ, T, Y, J, IAN, JAN, PDJ,rpar,ipar) C DOUBLE PRECISION T, Y(*), IAN(*), JAN(*), PDJ(*),rpar(*) C where NEQ, T, Y, J, IAN, and JAN are input, and the array C PDJ, of length NEQ, is to be loaded with column J C of the Jacobian on output. Thus df(i)/dy(J) is to be C loaded into PDJ(i) for all relevant values of i. C Here T and Y have the same meaning as in Subroutine F, C and J is a column index (1 to NEQ). IAN and JAN are C undefined in calls to JAC for structure determination C (MOSS = 1). otherwise, IAN and JAN are structure C descriptors, as defined under optional outputs below, and C so can be used to determine the relevant row indices i, if C desired. C JAC need not provide df/dy exactly. A crude C approximation (possibly with greater sparsity) will do. C In any case, PDJ is preset to zero by the solver, C so that only the nonzero elements need be loaded by JAC. C Calls to JAC are made with J = 1,...,NEQ, in that order, and C each such set of calls is preceded by a call to F with the C same arguments NEQ, T, and Y. Thus to gain some efficiency, C intermediate quantities shared by both calculations may be C saved in a user Common block by F and not recomputed by JAC, C if desired. JAC must not alter its input arguments. C JAC must be declared External in the calling program. C Subroutine JAC may access user-defined quantities in C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array C (dimensioned in JAC) and/or Y has length exceeding NEQ(1). C See the descriptions of NEQ and Y above. C C MF = the method flag. Used only for input. C MF has three decimal digits-- MOSS, METH, MITER-- C MF = 100*MOSS + 10*METH + MITER. C MOSS indicates the method to be used to obtain the sparsity C structure of the Jacobian matrix if MITER = 1 or 2: C MOSS = 0 means the user has supplied IA and JA C (see descriptions under IWORK above). C MOSS = 1 means the user has supplied JAC (see below) C and the structure will be obtained from NEQ C initial calls to JAC. C MOSS = 2 means the structure will be obtained from NEQ+1 C initial calls to F. C METH indicates the basic linear multistep method: C METH = 1 means the implicit Adams method. C METH = 2 means the method based on Backward C Differentiation Formulas (BDFs). C MITER indicates the corrector iteration method: C MITER = 0 means functional iteration (no Jacobian matrix C is involved). C MITER = 1 means chord iteration with a user-supplied C sparse Jacobian, given by Subroutine JAC. C MITER = 2 means chord iteration with an internally C generated (difference quotient) sparse Jacobian C (using NGP extra calls to F per df/dy value, C where NGP is an optional output described below.) C MITER = 3 means chord iteration with an internally C generated diagonal Jacobian approximation C (using 1 extra call to F per df/dy evaluation). C If MITER = 1 or MOSS = 1, the user must supply a Subroutine C JAC (the name is arbitrary) as described above under JAC. C Otherwise, a dummy argument can be used. C C The standard choices for MF are: C MF = 10 for a nonstiff problem, C MF = 21 or 22 for a stiff problem with IA/JA supplied C (21 if JAC is supplied, 22 if not), C MF = 121 for a stiff problem with JAC supplied, C but not IA/JA, C MF = 222 for a stiff problem with neither IA/JA nor C JAC supplied. C The sparseness structure can be changed during the C problem by making a call to DLSODES with ISTATE = 3. C----------------------------------------------------------------------- C Optional Inputs. C C The following is a list of the optional inputs provided for in the C call sequence. (See also Part 2.) For each such input variable, C this table lists its name as used in this documentation, its C location in the call sequence, its meaning, and the default value. C The use of any of these inputs requires IOPT = 1, and in that C case all of these inputs are examined. A value of zero for any C of these optional inputs will cause the default value to be used. C Thus to use a subset of the optional inputs, simply preload C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and C then set those of interest to nonzero values. C C Name Location Meaning and Default Value C C H0 RWORK(5) the step size to be attempted on the first step. C The default value is determined by the solver. C C HMAX RWORK(6) the maximum absolute step size allowed. C The default value is infinite. C C HMIN RWORK(7) the minimum absolute step size allowed. C The default value is 0. (This lower bound is not C enforced on the final step before reaching TCRIT C when ITASK = 4 or 5.) C C SETH RWORK(8) the element threshhold for sparsity determination C when MOSS = 1 or 2. If the absolute value of C an estimated Jacobian element is .le. SETH, it C will be assumed to be absent in the structure. C The default value of SETH is 0. C C MAXORD IWORK(5) the maximum order to be allowed. The default C value is 12 if METH = 1, and 5 if METH = 2. C If MAXORD exceeds the default value, it will C be reduced to the default value. C If MAXORD is changed during the problem, it may C cause the current order to be reduced. C C MXSTEP IWORK(6) maximum number of (internally defined) steps C allowed during one call to the solver. C The default value is 500. C C MXHNIL IWORK(7) maximum number of messages printed (per problem) C warning that T + H = T on a step (H = step size). C This must be positive to result in a non-default C value. The default value is 10. C----------------------------------------------------------------------- C Optional Outputs. C C As optional additional output from DLSODES, the variables listed C below are quantities related to the performance of DLSODES C which are available to the user. These are communicated by way of C the work arrays, but also have internal mnemonic names as shown. C Except where stated otherwise, all of these outputs are defined C on any successful return from DLSODES, and on any return with C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return C (ISTATE = -3), they will be unchanged from their existing values C (if any), except possibly for TOLSF, LENRW, and LENIW. C On any error return, outputs relevant to the error will be defined, C as noted below. C C Name Location Meaning C C HU RWORK(11) the step size in t last used (successfully). C C HCUR RWORK(12) the step size to be attempted on the next step. C C TCUR RWORK(13) the current value of the independent variable C which the solver has actually reached, i.e. the C current internal mesh point in t. On output, TCUR C will always be at least as far as the argument C T, but may be farther (if interpolation was done). C C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0, C computed when a request for too much accuracy was C detected (ISTATE = -3 if detected at the start of C the problem, ISTATE = -2 otherwise). If ITOL is C left unaltered but RTOL and ATOL are uniformly C scaled up by a factor of TOLSF for the next call, C then the solver is deemed likely to succeed. C (The user may also ignore TOLSF and alter the C tolerance parameters in any other way appropriate.) C C NST IWORK(11) the number of steps taken for the problem so far. C C NFE IWORK(12) the number of f evaluations for the problem so far, C excluding those for structure determination C (MOSS = 2). C C NJE IWORK(13) the number of Jacobian evaluations for the problem C so far, excluding those for structure determination C (MOSS = 1). C C NQU IWORK(14) the method order last used (successfully). C C NQCUR IWORK(15) the order to be attempted on the next step. C C IMXER IWORK(16) the index of the component of largest magnitude in C the weighted local error vector ( E(i)/EWT(i) ), C on an error return with ISTATE = -4 or -5. C C LENRW IWORK(17) the length of RWORK actually required. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C LENIW IWORK(18) the length of IWORK actually required. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C NNZ IWORK(19) the number of nonzero elements in the Jacobian C matrix, including the diagonal (MITER = 1 or 2). C (This may differ from that given by IA(NEQ+1)-1 C if MOSS = 0, because of added diagonal entries.) C C NGP IWORK(20) the number of groups of column indices, used in C difference quotient Jacobian aproximations if C MITER = 2. This is also the number of extra f C evaluations needed for each Jacobian evaluation. C C NLU IWORK(21) the number of sparse LU decompositions for the C problem so far. C C LYH IWORK(22) the base address in RWORK of the history array YH, C described below in this list. C C IPIAN IWORK(23) the base address of the structure descriptor array C IAN, described below in this list. C C IPJAN IWORK(24) the base address of the structure descriptor array C JAN, described below in this list. C C NZL IWORK(25) the number of nonzero elements in the strict lower C triangle of the LU factorization used in the chord C iteration (MITER = 1 or 2). C C NZU IWORK(26) the number of nonzero elements in the strict upper C triangle of the LU factorization used in the chord C iteration (MITER = 1 or 2). C The total number of nonzeros in the factorization C is therefore NZL + NZU + NEQ. C C The following four arrays are segments of the RWORK array which C may also be of interest to the user as optional outputs. C For each array, the table below gives its internal name, C its base address, and its description. C For YH and ACOR, the base addresses are in RWORK (a real array). C The integer arrays IAN and JAN are to be obtained by declaring an C integer array IWK and identifying IWK(1) with RWORK(21), using either C an equivalence statement or a subroutine call. Then the base C addresses IPIAN (of IAN) and IPJAN (of JAN) in IWK are to be obtained C as optional outputs IWORK(23) and IWORK(24), respectively. C Thus IAN(1) is IWK(IPIAN), etc. C C Name Base Address Description C C IAN IPIAN (in IWK) structure descriptor array of size NEQ + 1. C JAN IPJAN (in IWK) structure descriptor array of size NNZ. C (see above) IAN and JAN together describe the sparsity C structure of the Jacobian matrix, as used by C DLSODES when MITER = 1 or 2. C JAN contains the row indices of the nonzero C locations, reading in columnwise order, and C IAN contains the starting locations in JAN of C the descriptions of columns 1,...,NEQ, in C that order, with IAN(1) = 1. Thus for each C j = 1,...,NEQ, the row indices i of the C nonzero locations in column j are C i = JAN(k), IAN(j) .le. k .lt. IAN(j+1). C Note that IAN(NEQ+1) = NNZ + 1. C (If MOSS = 0, IAN/JAN may differ from the C input IA/JA because of a different ordering C in each column, and added diagonal entries.) C C YH LYH the Nordsieck history array, of size NYH by C (optional (NQCUR + 1), where NYH is the initial value C output) of NEQ. For j = 0,1,...,NQCUR, column j+1 C of YH contains HCUR**j/factorial(j) times C the j-th derivative of the interpolating C polynomial currently representing the solution, C evaluated at t = TCUR. The base address LYH C is another optional output, listed above. C C ACOR LENRW-NEQ+1 array of size NEQ used for the accumulated C corrections on each step, scaled on output C to represent the estimated local error in y C on the last step. This is the vector E in C the description of the error control. It is C defined only on a successful return from C DLSODES. C C----------------------------------------------------------------------- C Part 2. Other Routines Callable. C C The following are optional calls which the user may make to C gain additional capabilities in conjunction with DLSODES. C (The routines XSETUN and XSETF are designed to conform to the C SLATEC error handling package.) C C Form of Call Function C CALL XSETUN(LUN) Set the logical unit number, LUN, for C output of messages from DLSODES, if C the default is not desired. C The default value of LUN is 6. C C CALL XSETF(MFLAG) Set a flag to control the printing of C messages by DLSODES. C MFLAG = 0 means do not print. (Danger: C This risks losing valuable information.) C MFLAG = 1 means print (the default). C C Either of the above calls may be made at C any time and will take effect immediately. C C CALL DSRCMS(RSAV,ISAV,JOB) saves and restores the contents of C the internal Common blocks used by C DLSODES (see Part 3 below). C RSAV must be a real array of length 224 C or more, and ISAV must be an integer C array of length 71 or more. C JOB=1 means save Common into RSAV/ISAV. C JOB=2 means restore Common from RSAV/ISAV. C DSRCMS is useful if one is C interrupting a run and restarting C later, or alternating between two or C more problems solved with DLSODES. C C CALL DINTDY(,,,,,) Provide derivatives of y, of various C (see below) orders, at a specified point t, if C desired. It may be called only after C a successful return from DLSODES. C C The detailed instructions for using DINTDY are as follows. C The form of the call is: C C LYH = IWORK(22) C CALL DINTDY (T, K, RWORK(LYH), NYH, DKY, IFLAG) C C The input parameters are: C C T = value of independent variable where answers are desired C (normally the same as the T last returned by DLSODES). C For valid results, T must lie between TCUR - HU and TCUR. C (See optional outputs for TCUR and HU.) C K = integer order of the derivative desired. K must satisfy C 0 .le. K .le. NQCUR, where NQCUR is the current order C (See optional outputs). The capability corresponding C to K = 0, i.e. computing y(T), is already provided C by DLSODES directly. Since NQCUR .ge. 1, the first C derivative dy/dt is always available with DINTDY. C LYH = the base address of the history array YH, obtained C as an optional output as shown above. C NYH = column length of YH, equal to the initial value of NEQ. C C The output parameters are: C C DKY = a real array of length NEQ containing the computed value C of the K-th derivative of y(t). C IFLAG = integer flag, returned as 0 if K and T were legal, C -1 if K was illegal, and -2 if T was illegal. C On an error return, a message is also written. C----------------------------------------------------------------------- C Part 3. Common Blocks. C C If DLSODES is to be used in an overlay situation, the user C must declare, in the primary overlay, the variables in: C (1) the call sequence to DLSODES, and C (2) the two internal Common blocks C /DLS001/ of length 255 (218 double precision words C followed by 37 integer words), C /DLSS01/ of length 40 (6 double precision words C followed by 34 integer words), C C If DLSODES is used on a system in which the contents of internal C Common blocks are not preserved between calls, the user should C declare the above Common blocks in the calling program to insure C that their contents are preserved. C C If the solution of a given problem by DLSODES is to be interrupted C and then later continued, such as when restarting an interrupted run C or alternating between two or more problems, the user should save, C following the return from the last DLSODES call prior to the C interruption, the contents of the call sequence variables and the C internal Common blocks, and later restore these values before the C next DLSODES call for that problem. To save and restore the Common C blocks, use Subroutine DSRCMS (see Part 2 above). C C----------------------------------------------------------------------- C Part 4. Optionally Replaceable Solver Routines. C C Below are descriptions of two routines in the DLSODES package which C relate to the measurement of errors. Either routine can be C replaced by a user-supplied version, if desired. However, since such C a replacement may have a major impact on performance, it should be C done only when absolutely necessary, and only with great caution. C (Note: The means by which the package version of a routine is C superseded by the user's version may be system-dependent.) C C (a) DEWSET. C The following subroutine is called just before each internal C integration step, and sets the array of error weights, EWT, as C described under ITOL/RTOL/ATOL above: C Subroutine DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODES call sequence, C YCUR contains the current dependent variable vector, and C EWT is the array of weights set by DEWSET. C C If the user supplies this subroutine, it must return in EWT(i) C (i = 1,...,NEQ) a positive quantity suitable for comparing errors C in y(i) to. The EWT array returned by DEWSET is passed to the DVNORM C routine (see below), and also used by DLSODES in the computation C of the optional output IMXER, the diagonal Jacobian approximation, C and the increments for difference quotient Jacobians. C C In the user-supplied version of DEWSET, it may be desirable to use C the current values of derivatives of y. Derivatives up to order NQ C are available from the history array YH, described above under C optional outputs. In DEWSET, YH is identical to the YCUR array, C extended to NQ + 1 columns with a column length of NYH and scale C factors of H**j/factorial(j). On the first call for the problem, C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. C NYH is the initial value of NEQ. The quantities NQ, H, and NST C can be obtained by including in DEWSET the statements: C DOUBLE PRECISION RLS C COMMON /DLS001/ RLS(218),ILS(37) C NQ = ILS(33) C NST = ILS(34) C H = RLS(212) C Thus, for example, the current value of dy/dt can be obtained as C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is C unnecessary when NST = 0). C C (b) DVNORM. C The following is a real function routine which computes the weighted C root-mean-square norm of a vector v: C D = DVNORM (N, V, W) C where C N = the length of the vector, C V = real array of length N containing the vector, C W = real array of length N containing weights, C D = SQRT( (1/N) * sum(V(i)*W(i))**2 ). C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where C EWT is as set by Subroutine DEWSET. C C If the user supplies this function, it should return a non-negative C value of DVNORM suitable for use in the error control in DLSODES. C None of the arguments should be altered by DVNORM. C For example, a user-supplied DVNORM routine might: C -substitute a max-norm of (V(i)*W(i)) for the RMS-norm, or C -ignore some components of V in the norm, with the effect of C suppressing the error control on those components of y. C----------------------------------------------------------------------- C C***REVISION HISTORY (YYYYMMDD) C 19810120 DATE WRITTEN C 19820315 Upgraded MDI in ODRV package: operates on M + M-transpose. C 19820426 Numerous revisions in use of work arrays; C use wordlength ratio LENRAT; added IPISP & LRAT to Common; C added optional outputs IPIAN/IPJAN; C numerous corrections to comments. C 19830503 Added routine CNTNZU; added NZL and NZU to /LSS001/; C changed ADJLR call logic; added optional outputs NZL & NZU; C revised counter initializations; revised PREP stmt. numbers; C corrections to comments throughout. C 19870320 Corrected jump on test of umax in CDRV routine; C added ISTATE = -7 return. C 19870330 Major update: corrected comments throughout; C removed TRET from Common; rewrote EWSET with 4 loops; C fixed t test in INTDY; added Cray directives in STODE; C in STODE, fixed DELP init. and logic around PJAC call; C combined routines to save/restore Common; C passed LEVEL = 0 in error message calls (except run abort). C 20010425 Major update: convert source lines to upper case; C added *DECK lines; changed from 1 to * in dummy dimensions; C changed names R1MACH/D1MACH to RUMACH/DUMACH; C renamed routines for uniqueness across single/double prec.; C converted intrinsic names to generic form; C removed ILLIN and NTREP (data loaded) from Common; C removed all 'own' variables from Common; C changed error messages to quoted strings; C replaced XERRWV/XERRWD with 1993 revised version; C converted prologues, comments, error messages to mixed case; C converted arithmetic IF statements to logical IF statements; C numerous corrections to prologues and internal comments. C 20010507 Converted single precision source to double precision. C 20020502 Corrected declarations in descriptions of user routines. C 20031105 Restored 'own' variables to Common blocks, to enable C interrupt/restart feature. C 20031112 Added SAVE statements for data-loaded constants. C C----------------------------------------------------------------------- C Other routines in the DLSODES package. C C In addition to Subroutine DLSODES, the DLSODES package includes the C following subroutines and function routines: C DIPREP acts as an iterface between DLSODES and DPREP, and also does C adjusting of work space pointers and work arrays. C DPREP is called by DIPREP to compute sparsity and do sparse matrix C preprocessing if MITER = 1 or 2. C JGROUP is called by DPREP to compute groups of Jacobian column C indices for use when MITER = 2. C ADJLR adjusts the length of required sparse matrix work space. C It is called by DPREP. C CNTNZU is called by DPREP and counts the nonzero elements in the C strict upper triangle of J + J-transpose, where J = df/dy. C DINTDY computes an interpolated value of the y vector at t = TOUT. C DSTODE is the core integrator, which does one step of the C integration and the associated error control. C DCFODE sets all method coefficients and test constants. C DPRJS computes and preprocesses the Jacobian matrix J = df/dy C and the Newton iteration matrix P = I - h*l0*J. C DSOLSS manages solution of linear system in chord iteration. C DEWSET sets the error weight vector EWT before each step. C DVNORM computes the weighted RMS-norm of a vector. C DSRCMS is a user-callable routine to save and restore C the contents of the internal Common blocks. C ODRV constructs a reordering of the rows and columns of C a matrix by the minimum degree algorithm. ODRV is a C driver routine which calls Subroutines MD, MDI, MDM, C MDP, MDU, and SRO. See Ref. 2 for details. (The ODRV C module has been modified since Ref. 2, however.) C CDRV performs reordering, symbolic factorization, numerical C factorization, or linear system solution operations, C depending on a path argument ipath. CDRV is a C driver routine which calls Subroutines NROC, NSFC, C NNFC, NNSC, and NNTC. See Ref. 3 for details. C DLSODES uses CDRV to solve linear systems in which the C coefficient matrix is P = I - con*J, where I is the C identity, con is a scalar, and J is an approximation to C the Jacobian df/dy. Because CDRV deals with rowwise C sparsity descriptions, CDRV works with P-transpose, not P. C DUMACH computes the unit roundoff in a machine-independent manner. C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all C error messages and warnings. XERRWD is machine-dependent. C Note: DVNORM, DUMACH, IXSAV, and IUMACH are function routines. C All the others are subroutines. C C----------------------------------------------------------------------- EXTERNAL DPRJS, DSOLSS DOUBLE PRECISION DUMACH, DVNORM INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU INTEGER I, I1, I2, IFLAG, IMAX, IMUL, IMXER, IPFLAG, IPGO, IREM, 1 J, KGO, LENRAT, LENYHT, LENIW, LENRW, LF0, LIA, LJA, 2 LRTEM, LWTEM, LYHD, LYHN, MF1, MORD, MXHNL0, MXSTP0, NCOLM DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 DIMENSION MORD(2) LOGICAL IHIT CHARACTER(LEN=80) MSG SAVE LENRAT, MORD, MXSTP0, MXHNL0 C----------------------------------------------------------------------- C The following two internal Common blocks contain C (a) variables which are local to any subroutine but whose values must C be preserved between calls to the routine ("own" variables), and C (b) variables which are communicated between subroutines. C The block DLS001 is declared in subroutines DLSODES, DIPREP, DPREP, C DINTDY, DSTODE, DPRJS, and DSOLSS. C The block DLSS01 is declared in subroutines DLSODES, DIPREP, DPREP, C DPRJS, and DSOLSS. C Groups of variables are replaced by dummy arrays in the Common C declarations in routines where those variables are not used. C----------------------------------------------------------------------- COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C COMMON /DLSS01/ CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH, 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU C DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ C----------------------------------------------------------------------- C In the Data statement below, set LENRAT equal to the ratio of C the wordlength for a real number to that for an integer. Usually, C LENRAT = 1 for single precision and 2 for double precision. If the C true ratio is not an integer, use the next smaller integer (.ge. 1). C----------------------------------------------------------------------- DATA LENRAT/2/ C----------------------------------------------------------------------- C Block A. C This code block is executed on every call. C It tests ISTATE and ITASK for legality and branches appropriately. C If ISTATE .gt. 1 but the flag INIT shows that initialization has C not yet been done, an error return occurs. C If ISTATE = 1 and TOUT = T, return immediately. C----------------------------------------------------------------------- C KARLINE: INITIALISED IHIT TO AVOID COMPILER WARNINGS - SHOULD HAVE NO EFFEXT IHIT = .TRUE. IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 IF (ISTATE .EQ. 1) GO TO 10 IF (INIT .EQ. 0) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) RETURN C----------------------------------------------------------------------- C Block B. C The next code block is executed for the initial call (ISTATE = 1), C or for a continuation call with parameter changes (ISTATE = 3). C It contains checking of all inputs and various initializations. C If ISTATE = 1, the final setting of work space pointers, the matrix C preprocessing, and other initializations are done in Block C. C C First check legality of the non-optional inputs NEQ, ITOL, IOPT, C MF, ML, and MU. C----------------------------------------------------------------------- 20 IF (NEQ(1) .LE. 0) GO TO 604 IF (ISTATE .EQ. 1) GO TO 25 IF (NEQ(1) .GT. N) GO TO 605 25 N = NEQ(1) IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 MOSS = MF/100 MF1 = MF - 100*MOSS METH = MF1/10 MITER = MF1 - 10*METH IF (MOSS .LT. 0 .OR. MOSS .GT. 2) GO TO 608 IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 IF (MITER .LT. 0 .OR. MITER .GT. 3) GO TO 608 IF (MITER .EQ. 0 .OR. MITER .EQ. 3) MOSS = 0 C Next process and check the optional inputs. -------------------------- IF (IOPT .EQ. 1) GO TO 40 MAXORD = MORD(METH) MXSTEP = MXSTP0 MXHNIL = MXHNL0 IF (ISTATE .EQ. 1) H0 = 0.0D0 HMXI = 0.0D0 HMIN = 0.0D0 SETH = 0.0D0 GO TO 60 40 MAXORD = IWORK(5) IF (MAXORD .LT. 0) GO TO 611 IF (MAXORD .EQ. 0) MAXORD = 100 MAXORD = MIN(MAXORD,MORD(METH)) MXSTEP = IWORK(6) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .NE. 1) GO TO 50 H0 = RWORK(5) IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. 0.0D0) GO TO 615 HMXI = 0.0D0 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX HMIN = RWORK(7) IF (HMIN .LT. 0.0D0) GO TO 616 SETH = RWORK(8) IF (SETH .LT. 0.0D0) GO TO 609 C Check RTOL and ATOL for legality. ------------------------------------ 60 RTOLI = RTOL(1) ATOLI = ATOL(1) DO 65 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. 0.0D0) GO TO 619 IF (ATOLI .LT. 0.0D0) GO TO 620 65 CONTINUE C----------------------------------------------------------------------- C Compute required work array lengths, as far as possible, and test C these against LRW and LIW. Then set tentative pointers for work C arrays. Pointers to RWORK/IWORK segments are named by prefixing L to C the name of the segment. E.g., the segment YH starts at RWORK(LYH). C Segments of RWORK (in order) are denoted WM, YH, SAVF, EWT, ACOR. C If MITER = 1 or 2, the required length of the matrix work space WM C is not yet known, and so a crude minimum value is used for the C initial tests of LRW and LIW, and YH is temporarily stored as far C to the right in RWORK as possible, to leave the maximum amount C of space for WM for matrix preprocessing. Thus if MITER = 1 or 2 C and MOSS .ne. 2, some of the segments of RWORK are temporarily C omitted, as they are not needed in the preprocessing. These C omitted segments are: ACOR if ISTATE = 1, EWT and ACOR if ISTATE = 3 C and MOSS = 1, and SAVF, EWT, and ACOR if ISTATE = 3 and MOSS = 0. C----------------------------------------------------------------------- LRAT = LENRAT IF (ISTATE .EQ. 1) NYH = N LWMIN = 0 IF (MITER .EQ. 1) LWMIN = 4*N + 10*N/LRAT IF (MITER .EQ. 2) LWMIN = 4*N + 11*N/LRAT IF (MITER .EQ. 3) LWMIN = N + 2 LENYH = (MAXORD+1)*NYH LREST = LENYH + 3*N LENRW = 20 + LWMIN + LREST IWORK(17) = LENRW LENIW = 30 IF (MOSS .EQ. 0 .AND. MITER .NE. 0 .AND. MITER .NE. 3) 1 LENIW = LENIW + N + 1 IWORK(18) = LENIW IF (LENRW .GT. LRW) GO TO 617 IF (LENIW .GT. LIW) GO TO 618 LIA = 31 IF (MOSS .EQ. 0 .AND. MITER .NE. 0 .AND. MITER .NE. 3) 1 LENIW = LENIW + IWORK(LIA+N) - 1 IWORK(18) = LENIW IF (LENIW .GT. LIW) GO TO 618 LJA = LIA + N + 1 LIA = MIN(LIA,LIW) LJA = MIN(LJA,LIW) LWM = 21 IF (ISTATE .EQ. 1) NQ = 1 NCOLM = MIN(NQ+1,MAXORD+2) LENYHM = NCOLM*NYH LENYHT = LENYH IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENYHT = LENYHM IMUL = 2 IF (ISTATE .EQ. 3) IMUL = MOSS IF (MOSS .EQ. 2) IMUL = 3 LRTEM = LENYHT + IMUL*N LWTEM = LWMIN IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LWTEM = LRW - 20 - LRTEM LENWK = LWTEM LYHN = LWM + LWTEM LSAVF = LYHN + LENYHT LEWT = LSAVF + N LACOR = LEWT + N ISTATC = ISTATE IF (ISTATE .EQ. 1) GO TO 100 C----------------------------------------------------------------------- C ISTATE = 3. Move YH to its new location. C Note that only the part of YH needed for the next step, namely C MIN(NQ+1,MAXORD+2) columns, is actually moved. C A temporary error weight array EWT is loaded if MOSS = 2. C Sparse matrix processing is done in DIPREP/DPREP if MITER = 1 or 2. C If MAXORD was reduced below NQ, then the pointers are finally set C so that SAVF is identical to YH(*,MAXORD+2). C----------------------------------------------------------------------- LYHD = LYH - LYHN IMAX = LYHN - 1 + LENYHM C Move YH. Move right if LYHD < 0; move left if LYHD > 0. ------------- IF (LYHD .LT. 0) THEN DO 72 I = LYHN,IMAX J = IMAX + LYHN - I RWORK(J) = RWORK(J+LYHD) 72 CONTINUE ENDIF IF (LYHD .GT. 0) THEN DO 76 I = LYHN,IMAX RWORK(I) = RWORK(I+LYHD) 76 CONTINUE ENDIF LYH = LYHN IWORK(22) = LYH IF (MITER .EQ. 0 .OR. MITER .EQ. 3) GO TO 92 IF (MOSS .NE. 2) GO TO 85 C Temporarily load EWT if MITER = 1 or 2 and MOSS = 2. ----------------- CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 82 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 82 CONTINUE 85 CONTINUE C DIPREP and DPREP do sparse matrix preprocessing if MITER = 1 or 2. --- LSAVF = MIN(LSAVF,LRW) LEWT = MIN(LEWT,LRW) LACOR = MIN(LACOR,LRW) CKS CALL DIPREP (NEQ,Y,RWORK,IWK,IWORK(LIA),IWORK(LJA),IPFLAG,F,JAC, & rpar, ipar ) LENRW = LWM - 1 + LENWK + LREST IWORK(17) = LENRW IF (IPFLAG .NE. -1) IWORK(23) = IPIAN IF (IPFLAG .NE. -1) IWORK(24) = IPJAN IPGO = -IPFLAG + 1 IF (IPGO .EQ. 1) THEN GOTO 90 ELSE IF (IPGO .EQ. 2) THEN GOTO 628 ELSE IF (IPGO .EQ. 3) THEN GOTO 629 ELSE IF (IPGO .EQ. 4) THEN GOTO 630 ELSE IF (IPGO .EQ. 5) THEN GOTO 631 ELSE IF (IPGO .EQ. 6) THEN GOTO 632 ELSE IF (IPGO .EQ. 7) THEN GOTO 633 ENDIF C GO TO (90, 628, 629, 630, 631, 632, 633), IPGO 90 IWORK(22) = LYH IF (LENRW .GT. LRW) GO TO 617 C Set flag to signal parameter changes to DSTODE. ---------------------- 92 JSTART = -1 IF (N .EQ. NYH) GO TO 200 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- I1 = LYH + L*NYH I2 = LYH + (MAXORD + 1)*NYH - 1 IF (I1 .GT. I2) GO TO 200 DO 95 I = I1,I2 RWORK(I) = 0.0D0 95 CONTINUE GO TO 200 C----------------------------------------------------------------------- C Block C. C The next block is for the initial call only (ISTATE = 1). C It contains all remaining initializations, the initial call to F, C the sparse matrix preprocessing (MITER = 1 or 2), and the C calculation of the initial step size. C The error weights in EWT are inverted after being loaded. C----------------------------------------------------------------------- 100 CONTINUE LYH = LYHN IWORK(22) = LYH TN = T NST = 0 H = 1.0D0 NNZ = 0 NGP = 0 NZL = 0 NZU = 0 C Load the initial value vector in YH. --------------------------------- DO 105 I = 1,N RWORK(I+LYH-1) = Y(I) 105 CONTINUE C Initial call to F. (LF0 points to YH(*,2).) ------------------------- LF0 = LYH + NYH CALL F (NEQ, T, Y, RWORK(LF0), rpar, ipar) NFE = 1 C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 110 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 110 CONTINUE IF (MITER .EQ. 0 .OR. MITER .EQ. 3) GO TO 120 C DIPREP and DPREP do sparse matrix preprocessing if MITER = 1 or 2. --- LACOR = MIN(LACOR,LRW) CALL DIPREP (NEQ,Y,RWORK,IWK,IWORK(LIA),IWORK(LJA),IPFLAG,F,JAC, & rpar, ipar) LENRW = LWM - 1 + LENWK + LREST IWORK(17) = LENRW IF (IPFLAG .NE. -1) IWORK(23) = IPIAN IF (IPFLAG .NE. -1) IWORK(24) = IPJAN IPGO = -IPFLAG + 1 IF (IPGO .EQ. 1) THEN GOTO 115 ELSE IF (IPGO .EQ. 2) THEN GOTO 628 ELSE IF (IPGO .EQ. 3) THEN GOTO 629 ELSE IF (IPGO .EQ. 4) THEN GOTO 630 ELSE IF (IPGO .EQ. 5) THEN GOTO 631 ELSE IF (IPGO .EQ. 6) THEN GOTO 632 ELSE IF (IPGO .EQ. 7) THEN GOTO 633 ENDIF C karline: change from C GO TO (115, 628, 629, 630, 631, 632, 633), IPGO 115 IWORK(22) = LYH IF (LENRW .GT. LRW) GO TO 617 C Check TCRIT for legality (ITASK = 4 or 5). --------------------------- 120 CONTINUE IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 125 TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 1 H0 = TCRIT - T C Initialize all remaining parameters. --------------------------------- 125 UROUND = DUMACH() JSTART = 0 IF (MITER .NE. 0) RWORK(LWM) = SQRT(UROUND) MSBJ = 50 NSLJ = 0 CCMXJ = 0.2D0 PSMALL = 1000.0D0*UROUND RBIG = 0.01D0/PSMALL NHNIL = 0 NJE = 0 NLU = 0 NSLAST = 0 HU = 0.0D0 NQU = 0 CCMAX = 0.3D0 MAXCOR = 3 MSBP = 20 MXNCF = 10 C----------------------------------------------------------------------- C The coding below computes the step size, H0, to be attempted on the C first step, unless the user has supplied a value for this. C First check that TOUT - T differs significantly from zero. C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i)) C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted C so as to be between 100*UROUND and 1.0E-3. C Then the computed value H0 is given by.. C NEQ C H0**2 = TOL / ( w0**-2 + (1/NEQ) * Sum ( f(i)/ywt(i) )**2 ) C 1 C where w0 = MAX ( ABS(T), ABS(TOUT) ), C f(i) = i-th component of initial value of f, C ywt(i) = EWT(i)/TOL (a weight for y(i)). C The sign of H0 is inferred from the initial values of TOUT and T. C ABS(H0) is made .le. ABS(TOUT-T) in any case. C----------------------------------------------------------------------- LF0 = LYH + NYH IF (H0 .NE. 0.0D0) GO TO 180 TDIST = ABS(TOUT - T) W0 = MAX(ABS(T),ABS(TOUT)) IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 TOL = RTOL(1) IF (ITOL .LE. 2) GO TO 140 DO 130 I = 1,N TOL = MAX(TOL,RTOL(I)) 130 CONTINUE 140 IF (TOL .GT. 0.0D0) GO TO 160 ATOLI = ATOL(1) DO 150 I = 1,N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) AYI = ABS(Y(I)) IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 150 CONTINUE 160 TOL = MAX(TOL,100.0D0*UROUND) TOL = MIN(TOL,0.001D0) SUM = DVNORM (N, RWORK(LF0), RWORK(LEWT)) SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 H0 = 1.0D0/SQRT(SUM) H0 = MIN(H0,TDIST) H0 = SIGN(H0,TOUT-T) C Adjust H0 if necessary to meet HMAX bound. --------------------------- 180 RH = ABS(H0)*HMXI IF (RH .GT. 1.0D0) H0 = H0/RH C Load H with H0 and scale YH(*,2) by H0. ------------------------------ H = H0 DO 190 I = 1,N RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 190 CONTINUE GO TO 270 C----------------------------------------------------------------------- C Block D. C The next code block is for continuation calls only (ISTATE = 2 or 3) C and is to check stop conditions before taking a step. C----------------------------------------------------------------------- 200 NSLAST = NST IF (ITASK .EQ. 1) THEN GOTO 210 ELSE IF (ITASK .EQ. 2) THEN GOTO 250 ELSE IF (ITASK .EQ. 3) THEN GOTO 220 ELSE IF (ITASK .EQ. 4) THEN GOTO 230 ELSE IF (ITASK .EQ. 5) THEN GOTO 240 ENDIF C GO TO (210, 250, 220, 230, 240), ITASK 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 245 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (ISTATE .EQ. 2) JSTART = -2 C----------------------------------------------------------------------- C Block E. C The next block is normally executed for all calls and contains C the call to the one-step core integrator DSTODE. C C This is a looping point for the integration steps. C C First check for too many steps being taken, update EWT (if not at C start of problem), check for too much accuracy being requested, and C check for H below the roundoff level in T. C----------------------------------------------------------------------- 250 CONTINUE IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 260 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 260 CONTINUE 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) IF (TOLSF .LE. 1.0D0) GO TO 280 TOLSF = TOLSF*2.0D0 IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 MSG = 'DLSODES- Warning..Internal T (=R1) and H (=R2) are' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' such that in the machine, T + H = T on the next step ' CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' (H = step size). Solver will continue anyway.' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 MSG = 'DLSODES- Above warning has been issued I1 times. ' CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' It will not be issued again for this problem.' CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 290 CONTINUE C----------------------------------------------------------------------- C CALL DSTODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,WM,F,JAC,DPRJS,DSOLSS) C----------------------------------------------------------------------- CALL DSTODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWK(2*LWM-1), 2 F, JAC, DPRJS, DSOLSS, rpar,ipar) KGO = 1 - KFLAG IF (KGO .EQ. 1) THEN GOTO 300 ELSE IF (KGO .EQ. 2) THEN GOTO 530 ELSE IF (KGO .EQ. 3) THEN GOTO 540 ELSE IF (KGO .EQ. 4) THEN GOTO 550 ENDIF C GO TO (300, 530, 540, 550), KGO C----------------------------------------------------------------------- C Block F. C The following block handles the case of a successful return from the C core integrator (KFLAG = 0). Test for stop conditions. C----------------------------------------------------------------------- 300 INIT = 1 IF (ITASK .EQ. 1) THEN GOTO 310 ELSE IF (ITASK .EQ. 2) THEN GOTO 400 ELSE IF (ITASK .EQ. 3) THEN GOTO 330 ELSE IF (ITASK .EQ. 4) THEN GOTO 340 ELSE IF (ITASK .EQ. 5) THEN GOTO 350 ENDIF C karline: changed from C GO TO (310, 400, 330, 340, 350), ITASK C ITASK = 1. if TOUT has been reached, interpolate. ------------------- 310 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 GO TO 250 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 345 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) JSTART = -2 GO TO 250 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 350 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX C----------------------------------------------------------------------- C Block G. C The following block handles all successful returns from DLSODES. C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. C ISTATE is set to 2, and the optional outputs are loaded into the C work arrays before returning. C----------------------------------------------------------------------- 400 DO 410 I = 1,N Y(I) = RWORK(I+LYH-1) 410 CONTINUE T = TN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 IF (IHIT) T = TCRIT 420 ISTATE = 2 RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = NNZ IWORK(20) = NGP IWORK(21) = NLU IWORK(25) = NZL IWORK(26) = NZU RETURN C----------------------------------------------------------------------- C Block H. C The following block handles all unsuccessful returns other than C those for illegal input. First the error message routine is called. C If there was an error test or convergence test failure, IMXER is set. C Then Y is loaded from YH and T is set to TN. C The optional outputs are loaded into the work arrays before returning. C----------------------------------------------------------------------- C The maximum number of steps was taken before reaching TOUT. ---------- 500 MSG = 'DLSODES- At current T (=R1), MXSTEP (=I1) steps ' CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' taken on this call before reaching TOUT ' CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) ISTATE = -1 GO TO 580 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 510 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODES- At T (=R1), EWT(I1) has become R2 .le. 0.' CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) ISTATE = -6 GO TO 580 C Too much accuracy requested for machine precision. ------------------- 520 MSG = 'DLSODES- At T (=R1), too much accuracy requested ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' for precision of machine.. See TOLSF (=R2) ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) RWORK(14) = TOLSF ISTATE = -2 GO TO 580 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 530 MSG = 'DLSODES- At T(=R1) and step size H(=R2), the error' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' test failed repeatedly or with ABS(H) = HMIN' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) ISTATE = -4 GO TO 560 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 540 MSG = 'DLSODES- At T (=R1) and step size H (=R2), the ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' corrector convergence failed repeatedly ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' or with ABS(H) = HMIN ' CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) ISTATE = -5 GO TO 560 C KFLAG = -3. Fatal error flag returned by DPRJS or DSOLSS (CDRV). ---- 550 MSG = 'DLSODES- At T (=R1) and step size H (=R2), a fatal' CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' error flag was returned by CDRV (by way of ' CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' Subroutine DPRJS or DSOLSS) ' CALL XERRWD (MSG, 40, 207, 0, 0, 0, 0, 2, TN, H) ISTATE = -7 GO TO 580 C Compute IMXER if relevant. ------------------------------------------- 560 BIG = 0.0D0 IMXER = 1 DO 570 I = 1,N SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) IF (BIG .GE. SIZE) GO TO 570 BIG = SIZE IMXER = I 570 CONTINUE IWORK(16) = IMXER C Set Y vector, T, and optional outputs. ------------------------------- 580 DO 590 I = 1,N Y(I) = RWORK(I+LYH-1) 590 CONTINUE T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = NNZ IWORK(20) = NGP IWORK(21) = NLU IWORK(25) = NZL IWORK(26) = NZU RETURN C----------------------------------------------------------------------- C Block I. C The following block handles all error returns due to illegal input C (ISTATE = -3), as detected before calling the core integrator. C First the error message routine is called. If the illegal input C is a negative ISTATE, the run is aborted (apparent infinite loop). C----------------------------------------------------------------------- 601 MSG = 'DLSODES- ISTATE (=I1) illegal.' CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) IF (ISTATE .LT. 0) GO TO 800 GO TO 700 602 MSG = 'DLSODES- ITASK (=I1) illegal. ' CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) GO TO 700 603 MSG = 'DLSODES- ISTATE.gt.1 but DLSODES not initialized. ' CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) GO TO 700 604 MSG = 'DLSODES- NEQ (=I1) .lt. 1 ' CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) GO TO 700 605 MSG = 'DLSODES- ISTATE = 3 and NEQ increased (I1 to I2). ' CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 606 MSG = 'DLSODES- ITOL (=I1) illegal. ' CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) GO TO 700 607 MSG = 'DLSODES- IOPT (=I1) illegal. ' CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) GO TO 700 608 MSG = 'DLSODES- MF (=I1) illegal. ' CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) GO TO 700 609 MSG = 'DLSODES- SETH (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 9, 0, 0, 0, 0, 1, SETH, 0.0D0) GO TO 700 611 MSG = 'DLSODES- MAXORD (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) GO TO 700 612 MSG = 'DLSODES- MXSTEP (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) GO TO 700 613 MSG = 'DLSODES- MXHNIL (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) GO TO 700 614 MSG = 'DLSODES- TOUT (=R1) behind T (=R2) ' CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) MSG = ' Integration direction is given by H0 (=R1) ' CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) GO TO 700 615 MSG = 'DLSODES- HMAX (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) GO TO 700 616 MSG = 'DLSODES- HMIN (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) GO TO 700 617 MSG = 'DLSODES- RWORK length is insufficient to proceed. ' CALL XERRWD (MSG, 50, 17, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' set argument lrw larger than LENRW (=I1), is now: LRW (=I2)' CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 618 MSG = 'DLSODES- IWORK length is insufficient to proceed. ' CALL XERRWD (MSG, 50, 18, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENIW (=I1), exceeds LIW (=I2)' CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) GO TO 700 619 MSG = 'DLSODES- RTOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) GO TO 700 620 MSG = 'DLSODES- ATOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) GO TO 700 621 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODES- EWT(I1) is R1 .le. 0.0 ' CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) GO TO 700 622 MSG='DLSODES- TOUT(=R1) too close to T(=R2) to start integration.' CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) GO TO 700 623 MSG='DLSODES- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) GO TO 700 624 MSG='DLSODES- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) GO TO 700 625 MSG='DLSODES- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) GO TO 700 626 MSG = 'DLSODES- At start of problem, too much accuracy ' CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' requested for precision of machine.. See TOLSF (=R1) ' CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) RWORK(14) = TOLSF GO TO 700 627 MSG = 'DLSODES- Trouble in DINTDY. ITASK = I1, TOUT = R1' CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) GO TO 700 628 MSG='DLSODES- RWORK length insufficient (for Subroutine DPREP). ' CALL XERRWD (MSG, 60, 28, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 28, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 629 MSG='DLSODES- RWORK length insufficient (for Subroutine JGROUP). ' CALL XERRWD (MSG, 60, 29, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 29, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 630 MSG='DLSODES- RWORK length insufficient (for Subroutine ODRV). ' CALL XERRWD (MSG, 60, 30, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 30, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 631 MSG='DLSODES- Error from ODRV in Yale Sparse Matrix Package. ' CALL XERRWD (MSG, 60, 31, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) IMUL = (IYS - 1)/N IREM = IYS - IMUL*N MSG=' At T (=R1), ODRV returned error flag = I1*NEQ + I2. ' CALL XERRWD (MSG, 60, 31, 0, 2, IMUL, IREM, 1, TN, 0.0D0) GO TO 700 632 MSG='DLSODES- RWORK length insufficient (for Subroutine CDRV). ' CALL XERRWD (MSG, 60, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 32, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 633 MSG='DLSODES- Error from CDRV in Yale Sparse Matrix Package. ' CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) IMUL = (IYS - 1)/N IREM = IYS - IMUL*N MSG=' At T (=R1), CDRV returned error flag = I1*NEQ + I2. ' CALL XERRWD (MSG, 60, 33, 0, 2, IMUL, IREM, 1, TN, 0.0D0) IF (IMUL .EQ. 2) THEN MSG=' Duplicate entry in sparsity structure descriptors. ' CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) ENDIF IF (IMUL .EQ. 3 .OR. IMUL .EQ. 6) THEN MSG=' Insufficient storage for NSFC (called by CDRV). ' CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) ENDIF C 700 ISTATE = -3 RETURN C 800 MSG = 'DLSODES- Run aborted.. apparent infinite loop. ' CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) RETURN C----------------------- End of Subroutine DLSODES --------------------- END *DECK DLSODA SUBROUTINE DLSODA (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, JT, 2 rpar, ipar) EXTERNAL F, JAC CKS: added rpar, ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, JT DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW) C----------------------------------------------------------------------- C This is the 12 November 2003 version of C DLSODA: Livermore Solver for Ordinary Differential Equations, with C Automatic method switching for stiff and nonstiff problems. C C This version is in double precision. C C DLSODA solves the initial value problem for stiff or nonstiff C systems of first order ODEs, C dy/dt = f(t,y) , or, in component form, C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). C C This a variant version of the DLSODE package. C It switches automatically between stiff and nonstiff methods. C This means that the user does not have to determine whether the C problem is stiff or not, and the solver will automatically choose the C appropriate method. It always starts with the nonstiff method. C C Authors: Alan C. Hindmarsh C Center for Applied Scientific Computing, L-561 C Lawrence Livermore National Laboratory C Livermore, CA 94551 C and C Linda R. Petzold C Univ. of California at Santa Barbara C Dept. of Computer Science C Santa Barbara, CA 93106 C C References: C 1. Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), C North-Holland, Amsterdam, 1983, pp. 55-64. C 2. Linda R. Petzold, Automatic Selection of Methods for Solving C Stiff and Nonstiff Systems of Ordinary Differential Equations, C Siam J. Sci. Stat. Comput. 4 (1983), pp. 136-148. C----------------------------------------------------------------------- C Summary of Usage. C C Communication between the user and the DLSODA package, for normal C situations, is summarized here. This summary describes only a subset C of the full set of options available. See the full description for C details, including alternative treatment of the Jacobian matrix, C optional inputs and outputs, nonstandard options, and C instructions for special situations. See also the example C problem (with program and output) following this summary. C C A. First provide a subroutine of the form: C SUBROUTINE F (NEQ, T, Y, YDOT,rpar,ipar) C INTEGER NEQ,ipar(*) C DOUBLE PRECISION T, Y(*), YDOT(*),rpar(*) C which supplies the vector function f by loading YDOT(i) with f(i). C C B. Write a main program which calls Subroutine DLSODA once for C each point at which answers are desired. This should also provide C for possible use of logical unit 6 for output of error messages C by DLSODA. On the first call to DLSODA, supply arguments as follows: C F = name of subroutine for right-hand side vector f. C This name must be declared External in calling program. C NEQ = number of first order ODEs. C Y = array of initial values, of length NEQ. C T = the initial value of the independent variable. C TOUT = first point where output is desired (.ne. T). C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. C RTOL = relative tolerance parameter (scalar). C ATOL = absolute tolerance parameter (scalar or array). C the estimated local error in y(i) will be controlled so as C to be less than C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. C Thus the local error test passes if, in each component, C either the absolute error is less than ATOL (or ATOL(i)), C or the relative error is less than RTOL. C Use RTOL = 0.0 for pure absolute error control, and C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error C control. Caution: actual (global) errors may exceed these C local tolerances, so choose them conservatively. C ITASK = 1 for normal computation of output values of y at t = TOUT. C ISTATE = integer flag (input and output). Set ISTATE = 1. C IOPT = 0 to indicate no optional inputs used. C RWORK = real work array of length at least: C 22 + NEQ * MAX(16, NEQ + 9). C See also Paragraph E below. C LRW = declared length of RWORK (in user's dimension). C IWORK = integer work array of length at least 20 + NEQ. C LIW = declared length of IWORK (in user's dimension). C JAC = name of subroutine for Jacobian matrix. C Use a dummy name. See also Paragraph E below. C JT = Jacobian type indicator. Set JT = 2. C See also Paragraph E below. C Note that the main program must declare arrays Y, RWORK, IWORK, C and possibly ATOL. C C C. The output from the first call (or any call) is: C Y = array of computed values of y(t) vector. C T = corresponding value of independent variable (normally TOUT). C ISTATE = 2 if DLSODA was successful, negative otherwise. C -1 means excess work done on this call (perhaps wrong JT). C -2 means excess accuracy requested (tolerances too small). C -3 means illegal input detected (see printed message). C -4 means repeated error test failures (check all inputs). C -5 means repeated convergence failures (perhaps bad Jacobian C supplied or wrong choice of JT or tolerances). C -6 means error weight became zero during problem. (Solution C component i vanished, and ATOL or ATOL(i) = 0.) C -7 means work space insufficient to finish (see messages). C C D. To continue the integration after a successful return, simply C reset TOUT and call DLSODA again. No other parameters need be reset. C C E. Note: If and when DLSODA regards the problem as stiff, and C switches methods accordingly, it must make use of the NEQ by NEQ C Jacobian matrix, J = df/dy. For the sake of simplicity, the C inputs to DLSODA recommended in Paragraph B above cause DLSODA to C treat J as a full matrix, and to approximate it internally by C difference quotients. Alternatively, J can be treated as a band C matrix (with great potential reduction in the size of the RWORK C array). Also, in either the full or banded case, the user can supply C J in closed form, with a routine whose name is passed as the JAC C argument. These alternatives are described in the paragraphs on C RWORK, JAC, and JT in the full description of the call sequence below. C C----------------------------------------------------------------------- C Example Problem. C C The following is a simple example problem, with the coding C needed for its solution by DLSODA. The problem is from chemical C kinetics, and consists of the following three rate equations: C dy1/dt = -.04*y1 + 1.e4*y2*y3 C dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2 C dy3/dt = 3.e7*y2**2 C on the interval from t = 0.0 to t = 4.e10, with initial conditions C y1 = 1.0, y2 = y3 = 0. The problem is stiff. C C The following coding solves this problem with DLSODA, C printing results at t = .4, 4., ..., 4.e10. It uses C ITOL = 2 and ATOL much smaller for y2 than y1 or y3 because C y2 has much smaller values. C At the end of the run, statistical quantities of interest are C printed (see optional outputs in the full description below). C C EXTERNAL FEX C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y C DIMENSION Y(3), ATOL(3), RWORK(70), IWORK(23) C NEQ = 3 C Y(1) = 1. C Y(2) = 0. C Y(3) = 0. C T = 0. C TOUT = .4 C ITOL = 2 C RTOL = 1.D-4 C ATOL(1) = 1.D-6 C ATOL(2) = 1.D-10 C ATOL(3) = 1.D-6 C ITASK = 1 C ISTATE = 1 C IOPT = 0 C LRW = 70 C LIW = 23 C JT = 2 C DO 40 IOUT = 1,12 C CALL DLSODA(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE, C 1 IOPT,RWORK,LRW,IWORK,LIW,JDUM,JT) C WRITE(6,20)T,Y(1),Y(2),Y(3) C 20 FORMAT(' At t =',D12.4,' Y =',3D14.6) C IF (ISTATE .LT. 0) GO TO 80 C 40 TOUT = TOUT*10. C WRITE(6,60)IWORK(11),IWORK(12),IWORK(13),IWORK(19),RWORK(15) C 60 FORMAT(/' No. steps =',I4,' No. f-s =',I4,' No. J-s =',I4/ C 1 ' Method last used =',I2,' Last switch was at t =',D12.4) C STOP C 80 WRITE(6,90)ISTATE C 90 FORMAT(///' Error halt.. ISTATE =',I3) C STOP C END C C SUBROUTINE FEX (NEQ, T, Y, YDOT,rpar,ipar) C DOUBLE PRECISION T, Y, YDOT,rpar(*) C DIMENSION Y(3), YDOT(3) C YDOT(1) = -.04*Y(1) + 1.D4*Y(2)*Y(3) C YDOT(3) = 3.D7*Y(2)*Y(2) C YDOT(2) = -YDOT(1) - YDOT(3) C RETURN C END C C The output of this program (on a CDC-7600 in single precision) C is as follows: C C At t = 4.0000e-01 y = 9.851712e-01 3.386380e-05 1.479493e-02 C At t = 4.0000e+00 Y = 9.055333e-01 2.240655e-05 9.444430e-02 C At t = 4.0000e+01 Y = 7.158403e-01 9.186334e-06 2.841505e-01 C At t = 4.0000e+02 Y = 4.505250e-01 3.222964e-06 5.494717e-01 C At t = 4.0000e+03 Y = 1.831975e-01 8.941774e-07 8.168016e-01 C At t = 4.0000e+04 Y = 3.898730e-02 1.621940e-07 9.610125e-01 C At t = 4.0000e+05 Y = 4.936363e-03 1.984221e-08 9.950636e-01 C At t = 4.0000e+06 Y = 5.161831e-04 2.065786e-09 9.994838e-01 C At t = 4.0000e+07 Y = 5.179817e-05 2.072032e-10 9.999482e-01 C At t = 4.0000e+08 Y = 5.283401e-06 2.113371e-11 9.999947e-01 C At t = 4.0000e+09 Y = 4.659031e-07 1.863613e-12 9.999995e-01 C At t = 4.0000e+10 Y = 1.404280e-08 5.617126e-14 1.000000e+00 C C No. steps = 361 No. f-s = 693 No. J-s = 64 C Method last used = 2 Last switch was at t = 6.0092e-03 C----------------------------------------------------------------------- C Full description of user interface to DLSODA. C C The user interface to DLSODA consists of the following parts. C C 1. The call sequence to Subroutine DLSODA, which is a driver C routine for the solver. This includes descriptions of both C the call sequence arguments and of user-supplied routines. C following these descriptions is a description of C optional inputs available through the call sequence, and then C a description of optional outputs (in the work arrays). C C 2. Descriptions of other routines in the DLSODA package that may be C (optionally) called by the user. These provide the ability to C alter error message handling, save and restore the internal C Common, and obtain specified derivatives of the solution y(t). C C 3. Descriptions of Common blocks to be declared in overlay C or similar environments, or to be saved when doing an interrupt C of the problem and continued solution later. C C 4. Description of a subroutine in the DLSODA package, C which the user may replace with his/her own version, if desired. C this relates to the measurement of errors. C C----------------------------------------------------------------------- C Part 1. Call Sequence. C C The call sequence parameters used for input only are C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, JT, C and those used for both input and output are C Y, T, ISTATE. C The work arrays RWORK and IWORK are also used for conditional and C optional inputs and optional outputs. (The term output here refers C to the return from Subroutine DLSODA to the user's calling program.) C C The legality of input parameters will be thoroughly checked on the C initial call for the problem, but not checked thereafter unless a C change in input parameters is flagged by ISTATE = 3 on input. C C The descriptions of the call arguments are as follows. C C F = the name of the user-supplied subroutine defining the C ODE system. The system must be put in the first-order C form dy/dt = f(t,y), where f is a vector-valued function C of the scalar t and the vector y. Subroutine F is to C compute the function f. It is to have the form C SUBROUTINE F (NEQ, T, Y, YDOT,rpar,ipar) C INTEGER NEQ,ipar(*) C DOUBLE PRECISION T, Y(*), YDOT(*),rpar(*) C where NEQ, T, and Y are input, and the array YDOT = f(t,y) C is output. Y and YDOT are arrays of length NEQ. C Subroutine F should not alter Y(1),...,Y(NEQ). C F must be declared External in the calling program. C C Subroutine F may access user-defined quantities in C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array C (dimensioned in F) and/or Y has length exceeding NEQ(1). C See the descriptions of NEQ and Y below. C C If quantities computed in the F routine are needed C externally to DLSODA, an extra call to F should be made C for this purpose, for consistent and accurate results. C If only the derivative dy/dt is needed, use DINTDY instead. C C NEQ = the size of the ODE system (number of first order C ordinary differential equations). Used only for input. C NEQ may be decreased, but not increased, during the problem. C If NEQ is decreased (with ISTATE = 3 on input), the C remaining components of Y should be left undisturbed, if C these are to be accessed in F and/or JAC. C C Normally, NEQ is a scalar, and it is generally referred to C as a scalar in this user interface description. However, C NEQ may be an array, with NEQ(1) set to the system size. C (The DLSODA package accesses only NEQ(1).) In either case, C this parameter is passed as the NEQ argument in all calls C to F and JAC. Hence, if it is an array, locations C NEQ(2),... may be used to store other integer data and pass C it to F and/or JAC. Subroutines F and/or JAC must include C NEQ in a Dimension statement in that case. C C Y = a real array for the vector of dependent variables, of C length NEQ or more. Used for both input and output on the C first call (ISTATE = 1), and only for output on other calls. C On the first call, Y must contain the vector of initial C values. On output, Y contains the computed solution vector, C evaluated at T. If desired, the Y array may be used C for other purposes between calls to the solver. C C This array is passed as the Y argument in all calls to C F and JAC. Hence its length may exceed NEQ, and locations C Y(NEQ+1),... may be used to store other real data and C pass it to F and/or JAC. (The DLSODA package accesses only C Y(1),...,Y(NEQ).) C C T = the independent variable. On input, T is used only on the C first call, as the initial point of the integration. C on output, after each call, T is the value at which a C computed solution Y is evaluated (usually the same as TOUT). C on an error return, T is the farthest point reached. C C TOUT = the next value of t at which a computed solution is desired. C Used only for input. C C When starting the problem (ISTATE = 1), TOUT may be equal C to T for one call, then should .ne. T for the next call. C For the initial t, an input value of TOUT .ne. T is used C in order to determine the direction of the integration C (i.e. the algebraic sign of the step sizes) and the rough C scale of the problem. Integration in either direction C (forward or backward in t) is permitted. C C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after C the first call (i.e. the first call with TOUT .ne. T). C Otherwise, TOUT is required on every call. C C If ITASK = 1, 3, or 4, the values of TOUT need not be C monotone, but a value of TOUT which backs up is limited C to the current internal T interval, whose endpoints are C TCUR - HU and TCUR (see optional outputs, below, for C TCUR and HU). C C ITOL = an indicator for the type of error control. See C description below under ATOL. Used only for input. C C RTOL = a relative error tolerance parameter, either a scalar or C an array of length NEQ. See description below under ATOL. C Input only. C C ATOL = an absolute error tolerance parameter, either a scalar or C an array of length NEQ. Input only. C C The input parameters ITOL, RTOL, and ATOL determine C the error control performed by the solver. The solver will C control the vector E = (E(i)) of estimated local errors C in y, according to an inequality of the form C max-norm of ( E(i)/EWT(i) ) .le. 1, C where EWT = (EWT(i)) is a vector of positive error weights. C The values of RTOL and ATOL should all be non-negative. C The following table gives the types (scalar/array) of C RTOL and ATOL, and the corresponding form of EWT(i). C C ITOL RTOL ATOL EWT(i) C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) C C When either of these parameters is a scalar, it need not C be dimensioned in the user's calling program. C C If none of the above choices (with ITOL, RTOL, and ATOL C fixed throughout the problem) is suitable, more general C error controls can be obtained by substituting a C user-supplied routine for the setting of EWT. C See Part 4 below. C C If global errors are to be estimated by making a repeated C run on the same problem with smaller tolerances, then all C components of RTOL and ATOL (i.e. of EWT) should be scaled C down uniformly. C C ITASK = an index specifying the task to be performed. C Input only. ITASK has the following values and meanings. C 1 means normal computation of output values of y(t) at C t = TOUT (by overshooting and interpolating). C 2 means take one step only and return. C 3 means stop at the first internal mesh point at or C beyond t = TOUT and return. C 4 means normal computation of output values of y(t) at C t = TOUT but without overshooting t = TCRIT. C TCRIT must be input as RWORK(1). TCRIT may be equal to C or beyond TOUT, but not behind it in the direction of C integration. This option is useful if the problem C has a singularity at or beyond t = TCRIT. C 5 means take one step, without passing TCRIT, and return. C TCRIT must be input as RWORK(1). C C Note: If ITASK = 4 or 5 and the solver reaches TCRIT C (within roundoff), it will return T = TCRIT (exactly) to C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, C in which case answers at t = TOUT are returned first). C C ISTATE = an index used for input and output to specify the C the state of the calculation. C C On input, the values of ISTATE are as follows. C 1 means this is the first call for the problem C (initializations will be done). See note below. C 2 means this is not the first call, and the calculation C is to continue normally, with no change in any input C parameters except possibly TOUT and ITASK. C (If ITOL, RTOL, and/or ATOL are changed between calls C with ISTATE = 2, the new values will be used but not C tested for legality.) C 3 means this is not the first call, and the C calculation is to continue normally, but with C a change in input parameters other than C TOUT and ITASK. Changes are allowed in C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, JT, ML, MU, C and any optional inputs except H0, MXORDN, and MXORDS. C (See IWORK description for ML and MU.) C Note: A preliminary call with TOUT = T is not counted C as a first call here, as no initialization or checking of C input is done. (Such a call is sometimes useful for the C purpose of outputting the initial conditions.) C Thus the first call for which TOUT .ne. T requires C ISTATE = 1 on input. C C On output, ISTATE has the following values and meanings. C 1 means nothing was done; TOUT = T and ISTATE = 1 on input. C 2 means the integration was performed successfully. C -1 means an excessive amount of work (more than MXSTEP C steps) was done on this call, before completing the C requested task, but the integration was otherwise C successful as far as T. (MXSTEP is an optional input C and is normally 500.) To continue, the user may C simply reset ISTATE to a value .gt. 1 and call again C (the excess work step counter will be reset to 0). C In addition, the user may increase MXSTEP to avoid C this error return (see below on optional inputs). C -2 means too much accuracy was requested for the precision C of the machine being used. This was detected before C completing the requested task, but the integration C was successful as far as T. To continue, the tolerance C parameters must be reset, and ISTATE must be set C to 3. The optional output TOLSF may be used for this C purpose. (Note: If this condition is detected before C taking any steps, then an illegal input return C (ISTATE = -3) occurs instead.) C -3 means illegal input was detected, before taking any C integration steps. See written message for details. C Note: If the solver detects an infinite loop of calls C to the solver with illegal input, it will cause C the run to stop. C -4 means there were repeated error test failures on C one attempted step, before completing the requested C task, but the integration was successful as far as T. C The problem may have a singularity, or the input C may be inappropriate. C -5 means there were repeated convergence test failures on C one attempted step, before completing the requested C task, but the integration was successful as far as T. C This may be caused by an inaccurate Jacobian matrix, C if one is being used. C -6 means EWT(i) became zero for some i during the C integration. Pure relative error control (ATOL(i)=0.0) C was requested on a variable which has now vanished. C The integration was successful as far as T. C -7 means the length of RWORK and/or IWORK was too small to C proceed, but the integration was successful as far as T. C This happens when DLSODA chooses to switch methods C but LRW and/or LIW is too small for the new method. C C Note: Since the normal output value of ISTATE is 2, C it does not need to be reset for normal continuation. C Also, since a negative input value of ISTATE will be C regarded as illegal, a negative output value requires the C user to change it, and possibly other inputs, before C calling the solver again. C C IOPT = an integer flag to specify whether or not any optional C inputs are being used on this call. Input only. C The optional inputs are listed separately below. C IOPT = 0 means no optional inputs are being used. C default values will be used in all cases. C IOPT = 1 means one or more optional inputs are being used. C C RWORK = a real array (double precision) for work space, and (in the C first 20 words) for conditional and optional inputs and C optional outputs. C As DLSODA switches automatically between stiff and nonstiff C methods, the required length of RWORK can change during the C problem. Thus the RWORK array passed to DLSODA can either C have a static (fixed) length large enough for both methods, C or have a dynamic (changing) length altered by the calling C program in response to output from DLSODA. C C --- Fixed Length Case --- C If the RWORK length is to be fixed, it should be at least C MAX (LRN, LRS), C where LRN and LRS are the RWORK lengths required when the C current method is nonstiff or stiff, respectively. C C The separate RWORK length requirements LRN and LRS are C as follows: C IF NEQ is constant and the maximum method orders have C their default values, then C LRN = 20 + 16*NEQ, C LRS = 22 + 9*NEQ + NEQ**2 if JT = 1 or 2, C LRS = 22 + 10*NEQ + (2*ML+MU)*NEQ if JT = 4 or 5. C Under any other conditions, LRN and LRS are given by: C LRN = 20 + NYH*(MXORDN+1) + 3*NEQ, C LRS = 20 + NYH*(MXORDS+1) + 3*NEQ + LMAT, C where C NYH = the initial value of NEQ, C MXORDN = 12, unless a smaller value is given as an C optional input, C MXORDS = 5, unless a smaller value is given as an C optional input, C LMAT = length of matrix work space: C LMAT = NEQ**2 + 2 if JT = 1 or 2, C LMAT = (2*ML + MU + 1)*NEQ + 2 if JT = 4 or 5. C C --- Dynamic Length Case --- C If the length of RWORK is to be dynamic, then it should C be at least LRN or LRS, as defined above, depending on the C current method. Initially, it must be at least LRN (since C DLSODA starts with the nonstiff method). On any return C from DLSODA, the optional output MCUR indicates the current C method. If MCUR differs from the value it had on the C previous return, or if there has only been one call to C DLSODA and MCUR is now 2, then DLSODA has switched C methods during the last call, and the length of RWORK C should be reset (to LRN if MCUR = 1, or to LRS if C MCUR = 2). (An increase in the RWORK length is required C if DLSODA returned ISTATE = -7, but not otherwise.) C After resetting the length, call DLSODA with ISTATE = 3 C to signal that change. C C LRW = the length of the array RWORK, as declared by the user. C (This will be checked by the solver.) C C IWORK = an integer array for work space. C As DLSODA switches automatically between stiff and nonstiff C methods, the required length of IWORK can change during C problem, between C LIS = 20 + NEQ and LIN = 20, C respectively. Thus the IWORK array passed to DLSODA can C either have a fixed length of at least 20 + NEQ, or have a C dynamic length of at least LIN or LIS, depending on the C current method. The comments on dynamic length under C RWORK above apply here. Initially, this length need C only be at least LIN = 20. C C The first few words of IWORK are used for conditional and C optional inputs and optional outputs. C C The following 2 words in IWORK are conditional inputs: C IWORK(1) = ML these are the lower and upper C IWORK(2) = MU half-bandwidths, respectively, of the C banded Jacobian, excluding the main diagonal. C The band is defined by the matrix locations C (i,j) with i-ML .le. j .le. i+MU. ML and MU C must satisfy 0 .le. ML,MU .le. NEQ-1. C These are required if JT is 4 or 5, and C ignored otherwise. ML and MU may in fact be C the band parameters for a matrix to which C df/dy is only approximately equal. C C LIW = the length of the array IWORK, as declared by the user. C (This will be checked by the solver.) C C Note: The base addresses of the work arrays must not be C altered between calls to DLSODA for the same problem. C The contents of the work arrays must not be altered C between calls, except possibly for the conditional and C optional inputs, and except for the last 3*NEQ words of RWORK. C The latter space is used for internal scratch space, and so is C available for use by the user outside DLSODA between calls, if C desired (but not for use by F or JAC). C C JAC = the name of the user-supplied routine to compute the C Jacobian matrix, df/dy, if JT = 1 or 4. The JAC routine C is optional, but if the problem is expected to be stiff much C of the time, you are encouraged to supply JAC, for the sake C of efficiency. (Alternatively, set JT = 2 or 5 to have C DLSODA compute df/dy internally by difference quotients.) C If and when DLSODA uses df/dy, it treats this NEQ by NEQ C matrix either as full (JT = 1 or 2), or as banded (JT = C 4 or 5) with half-bandwidths ML and MU (discussed under C IWORK above). In either case, if JT = 1 or 4, the JAC C routine must compute df/dy as a function of the scalar t C and the vector y. It is to have the form C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD,rpar,ipar) C DOUBLE PRECISION T, Y(*), PD(NROWPD,*),rpar(*) C where NEQ, T, Y, ML, MU, and NROWPD are input and the array C PD is to be loaded with partial derivatives (elements of C the Jacobian matrix) on output. PD must be given a first C dimension of NROWPD. T and Y have the same meaning as in C Subroutine F. C In the full matrix case (JT = 1), ML and MU are C ignored, and the Jacobian is to be loaded into PD in C columnwise manner, with df(i)/dy(j) loaded into PD(i,j). C In the band matrix case (JT = 4), the elements C within the band are to be loaded into PD in columnwise C manner, with diagonal lines of df/dy loaded into the rows C of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). C ML and MU are the half-bandwidth parameters (see IWORK). C The locations in PD in the two triangular areas which C correspond to nonexistent matrix elements can be ignored C or loaded arbitrarily, as they are overwritten by DLSODA. C JAC need not provide df/dy exactly. A crude C approximation (possibly with a smaller bandwidth) will do. C In either case, PD is preset to zero by the solver, C so that only the nonzero elements need be loaded by JAC. C Each call to JAC is preceded by a call to F with the same C arguments NEQ, T, and Y. Thus to gain some efficiency, C intermediate quantities shared by both calculations may be C saved in a user Common block by F and not recomputed by JAC, C if desired. Also, JAC may alter the Y array, if desired. C JAC must be declared External in the calling program. C Subroutine JAC may access user-defined quantities in C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array C (dimensioned in JAC) and/or Y has length exceeding NEQ(1). C See the descriptions of NEQ and Y above. C C JT = Jacobian type indicator. Used only for input. C JT specifies how the Jacobian matrix df/dy will be C treated, if and when DLSODA requires this matrix. C JT has the following values and meanings: C 1 means a user-supplied full (NEQ by NEQ) Jacobian. C 2 means an internally generated (difference quotient) full C Jacobian (using NEQ extra calls to F per df/dy value). C 4 means a user-supplied banded Jacobian. C 5 means an internally generated banded Jacobian (using C ML+MU+1 extra calls to F per df/dy evaluation). C If JT = 1 or 4, the user must supply a Subroutine JAC C (the name is arbitrary) as described above under JAC. C If JT = 2 or 5, a dummy argument can be used. C----------------------------------------------------------------------- C Optional Inputs. C C The following is a list of the optional inputs provided for in the C call sequence. (See also Part 2.) For each such input variable, C this table lists its name as used in this documentation, its C location in the call sequence, its meaning, and the default value. C The use of any of these inputs requires IOPT = 1, and in that C case all of these inputs are examined. A value of zero for any C of these optional inputs will cause the default value to be used. C Thus to use a subset of the optional inputs, simply preload C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and C then set those of interest to nonzero values. C C Name Location Meaning and Default Value C C H0 RWORK(5) the step size to be attempted on the first step. C The default value is determined by the solver. C C HMAX RWORK(6) the maximum absolute step size allowed. C The default value is infinite. C C HMIN RWORK(7) the minimum absolute step size allowed. C The default value is 0. (This lower bound is not C enforced on the final step before reaching TCRIT C when ITASK = 4 or 5.) C C IXPR IWORK(5) flag to generate extra printing at method switches. C IXPR = 0 means no extra printing (the default). C IXPR = 1 means print data on each switch. C T, H, and NST will be printed on the same logical C unit as used for error messages. C C MXSTEP IWORK(6) maximum number of (internally defined) steps C allowed during one call to the solver. C The default value is 500. C C MXHNIL IWORK(7) maximum number of messages printed (per problem) C warning that T + H = T on a step (H = step size). C This must be positive to result in a non-default C value. The default value is 10. C C MXORDN IWORK(8) the maximum order to be allowed for the nonstiff C (Adams) method. the default value is 12. C if MXORDN exceeds the default value, it will C be reduced to the default value. C MXORDN is held constant during the problem. C C MXORDS IWORK(9) the maximum order to be allowed for the stiff C (BDF) method. The default value is 5. C If MXORDS exceeds the default value, it will C be reduced to the default value. C MXORDS is held constant during the problem. C----------------------------------------------------------------------- C Optional Outputs. C C As optional additional output from DLSODA, the variables listed C below are quantities related to the performance of DLSODA C which are available to the user. These are communicated by way of C the work arrays, but also have internal mnemonic names as shown. C except where stated otherwise, all of these outputs are defined C on any successful return from DLSODA, and on any return with C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return C (ISTATE = -3), they will be unchanged from their existing values C (if any), except possibly for TOLSF, LENRW, and LENIW. C On any error return, outputs relevant to the error will be defined, C as noted below. C C Name Location Meaning C C HU RWORK(11) the step size in t last used (successfully). C C HCUR RWORK(12) the step size to be attempted on the next step. C C TCUR RWORK(13) the current value of the independent variable C which the solver has actually reached, i.e. the C current internal mesh point in t. On output, TCUR C will always be at least as far as the argument C T, but may be farther (if interpolation was done). C C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0, C computed when a request for too much accuracy was C detected (ISTATE = -3 if detected at the start of C the problem, ISTATE = -2 otherwise). If ITOL is C left unaltered but RTOL and ATOL are uniformly C scaled up by a factor of TOLSF for the next call, C then the solver is deemed likely to succeed. C (The user may also ignore TOLSF and alter the C tolerance parameters in any other way appropriate.) C C TSW RWORK(15) the value of t at the time of the last method C switch, if any. C C NST IWORK(11) the number of steps taken for the problem so far. C C NFE IWORK(12) the number of f evaluations for the problem so far. C C NJE IWORK(13) the number of Jacobian evaluations (and of matrix C LU decompositions) for the problem so far. C C NQU IWORK(14) the method order last used (successfully). C C NQCUR IWORK(15) the order to be attempted on the next step. C C IMXER IWORK(16) the index of the component of largest magnitude in C the weighted local error vector ( E(i)/EWT(i) ), C on an error return with ISTATE = -4 or -5. C C LENRW IWORK(17) the length of RWORK actually required, assuming C that the length of RWORK is to be fixed for the C rest of the problem, and that switching may occur. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C LENIW IWORK(18) the length of IWORK actually required, assuming C that the length of IWORK is to be fixed for the C rest of the problem, and that switching may occur. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C MUSED IWORK(19) the method indicator for the last successful step: C 1 means Adams (nonstiff), 2 means BDF (stiff). C C MCUR IWORK(20) the current method indicator: C 1 means Adams (nonstiff), 2 means BDF (stiff). C This is the method to be attempted C on the next step. Thus it differs from MUSED C only if a method switch has just been made. C C The following two arrays are segments of the RWORK array which C may also be of interest to the user as optional outputs. C For each array, the table below gives its internal name, C its base address in RWORK, and its description. C C Name Base Address Description C C YH 21 the Nordsieck history array, of size NYH by C (NQCUR + 1), where NYH is the initial value C of NEQ. For j = 0,1,...,NQCUR, column j+1 C of YH contains HCUR**j/factorial(j) times C the j-th derivative of the interpolating C polynomial currently representing the solution, C evaluated at T = TCUR. C C ACOR LACOR array of size NEQ used for the accumulated C (from Common corrections on each step, scaled on output C as noted) to represent the estimated local error in y C on the last step. This is the vector E in C the description of the error control. It is C defined only on a successful return from C DLSODA. The base address LACOR is obtained by C including in the user's program the C following 2 lines: C COMMON /DLS001/ RLS(218), ILS(37) C LACOR = ILS(22) C C----------------------------------------------------------------------- C Part 2. Other Routines Callable. C C The following are optional calls which the user may make to C gain additional capabilities in conjunction with DLSODA. C (The routines XSETUN and XSETF are designed to conform to the C SLATEC error handling package.) C C Form of Call Function C CALL XSETUN(LUN) set the logical unit number, LUN, for C output of messages from DLSODA, if C the default is not desired. C The default value of LUN is 6. C C CALL XSETF(MFLAG) set a flag to control the printing of C messages by DLSODA. C MFLAG = 0 means do not print. (Danger: C This risks losing valuable information.) C MFLAG = 1 means print (the default). C C Either of the above calls may be made at C any time and will take effect immediately. C C CALL DSRCMA(RSAV,ISAV,JOB) saves and restores the contents of C the internal Common blocks used by C DLSODA (see Part 3 below). C RSAV must be a real array of length 240 C or more, and ISAV must be an integer C array of length 46 or more. C JOB=1 means save Common into RSAV/ISAV. C JOB=2 means restore Common from RSAV/ISAV. C DSRCMA is useful if one is C interrupting a run and restarting C later, or alternating between two or C more problems solved with DLSODA. C C CALL DINTDY(,,,,,) provide derivatives of y, of various C (see below) orders, at a specified point t, if C desired. It may be called only after C a successful return from DLSODA. C C The detailed instructions for using DINTDY are as follows. C The form of the call is: C C CALL DINTDY (T, K, RWORK(21), NYH, DKY, IFLAG) C C The input parameters are: C C T = value of independent variable where answers are desired C (normally the same as the T last returned by DLSODA). C For valid results, T must lie between TCUR - HU and TCUR. C (See optional outputs for TCUR and HU.) C K = integer order of the derivative desired. K must satisfy C 0 .le. K .le. NQCUR, where NQCUR is the current order C (see optional outputs). The capability corresponding C to K = 0, i.e. computing y(T), is already provided C by DLSODA directly. Since NQCUR .ge. 1, the first C derivative dy/dt is always available with DINTDY. C RWORK(21) = the base address of the history array YH. C NYH = column length of YH, equal to the initial value of NEQ. C C The output parameters are: C C DKY = a real array of length NEQ containing the computed value C of the K-th derivative of y(t). C IFLAG = integer flag, returned as 0 if K and T were legal, C -1 if K was illegal, and -2 if T was illegal. C On an error return, a message is also written. C----------------------------------------------------------------------- C Part 3. Common Blocks. C C If DLSODA is to be used in an overlay situation, the user C must declare, in the primary overlay, the variables in: C (1) the call sequence to DLSODA, and C (2) the two internal Common blocks C /DLS001/ of length 255 (218 double precision words C followed by 37 integer words), C /DLSA01/ of length 31 (22 double precision words C followed by 9 integer words). C C If DLSODA is used on a system in which the contents of internal C Common blocks are not preserved between calls, the user should C declare the above Common blocks in the calling program to insure C that their contents are preserved. C C If the solution of a given problem by DLSODA is to be interrupted C and then later continued, such as when restarting an interrupted run C or alternating between two or more problems, the user should save, C following the return from the last DLSODA call prior to the C interruption, the contents of the call sequence variables and the C internal Common blocks, and later restore these values before the C next DLSODA call for that problem. To save and restore the Common C blocks, use Subroutine DSRCMA (see Part 2 above). C C----------------------------------------------------------------------- C Part 4. Optionally Replaceable Solver Routines. C C Below is a description of a routine in the DLSODA package which C relates to the measurement of errors, and can be C replaced by a user-supplied version, if desired. However, since such C a replacement may have a major impact on performance, it should be C done only when absolutely necessary, and only with great caution. C (Note: The means by which the package version of a routine is C superseded by the user's version may be system-dependent.) C C (a) DEWSET. C The following subroutine is called just before each internal C integration step, and sets the array of error weights, EWT, as C described under ITOL/RTOL/ATOL above: C Subroutine DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODA call sequence, C YCUR contains the current dependent variable vector, and C EWT is the array of weights set by DEWSET. C C If the user supplies this subroutine, it must return in EWT(i) C (i = 1,...,NEQ) a positive quantity suitable for comparing errors C in y(i) to. The EWT array returned by DEWSET is passed to the C DMNORM routine, and also used by DLSODA in the computation C of the optional output IMXER, and the increments for difference C quotient Jacobians. C C In the user-supplied version of DEWSET, it may be desirable to use C the current values of derivatives of y. Derivatives up to order NQ C are available from the history array YH, described above under C optional outputs. In DEWSET, YH is identical to the YCUR array, C extended to NQ + 1 columns with a column length of NYH and scale C factors of H**j/factorial(j). On the first call for the problem, C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. C NYH is the initial value of NEQ. The quantities NQ, H, and NST C can be obtained by including in DEWSET the statements: C DOUBLE PRECISION RLS C COMMON /DLS001/ RLS(218),ILS(37) C NQ = ILS(33) C NST = ILS(34) C H = RLS(212) C Thus, for example, the current value of dy/dt can be obtained as C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is C unnecessary when NST = 0). C----------------------------------------------------------------------- C C***REVISION HISTORY (YYYYMMDD) C 19811102 DATE WRITTEN C 19820126 Fixed bug in tests of work space lengths; C minor corrections in main prologue and comments. C 19870330 Major update: corrected comments throughout; C removed TRET from Common; rewrote EWSET with 4 loops; C fixed t test in INTDY; added Cray directives in STODA; C in STODA, fixed DELP init. and logic around PJAC call; C combined routines to save/restore Common; C passed LEVEL = 0 in error message calls (except run abort). C 19970225 Fixed lines setting JSTART = -2 in Subroutine LSODA. C 20010425 Major update: convert source lines to upper case; C added *DECK lines; changed from 1 to * in dummy dimensions; C changed names R1MACH/D1MACH to RUMACH/DUMACH; C renamed routines for uniqueness across single/double prec.; C converted intrinsic names to generic form; C removed ILLIN and NTREP (data loaded) from Common; C removed all 'own' variables from Common; C changed error messages to quoted strings; C replaced XERRWV/XERRWD with 1993 revised version; C converted prologues, comments, error messages to mixed case; C numerous corrections to prologues and internal comments. C 20010507 Converted single precision source to double precision. C 20010613 Revised excess accuracy test (to match rest of ODEPACK). C 20010808 Fixed bug in DPRJA (matrix in DBNORM call). C 20020502 Corrected declarations in descriptions of user routines. C 20031105 Restored 'own' variables to Common blocks, to enable C interrupt/restart feature. C 20031112 Added SAVE statements for data-loaded constants. C C----------------------------------------------------------------------- C Other routines in the DLSODA package. C C In addition to Subroutine DLSODA, the DLSODA package includes the C following subroutines and function routines: C DINTDY computes an interpolated value of the y vector at t = TOUT. C DSTODA is the core integrator, which does one step of the C integration and the associated error control. C DCFODE sets all method coefficients and test constants. C DPRJA computes and preprocesses the Jacobian matrix J = df/dy C and the Newton iteration matrix P = I - h*l0*J. C DSOLSY manages solution of linear system in chord iteration. C DEWSET sets the error weight vector EWT before each step. C DMNORM computes the weighted max-norm of a vector. C DFNORM computes the norm of a full matrix consistent with the C weighted max-norm on vectors. C DBNORM computes the norm of a band matrix consistent with the C weighted max-norm on vectors. C DSRCMA is a user-callable routine to save and restore C the contents of the internal Common blocks. C DGEFA and DGESL are routines from LINPACK for solving full C systems of linear algebraic equations. C DGBFA and DGBSL are routines from LINPACK for solving banded C linear systems. C DUMACH computes the unit roundoff in a machine-independent manner. C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all C error messages and warnings. XERRWD is machine-dependent. C Note: DMNORM, DFNORM, DBNORM, DUMACH, IXSAV, and IUMACH are C function routines. All the others are subroutines. C C----------------------------------------------------------------------- EXTERNAL DPRJA, DSOLSY DOUBLE PRECISION DUMACH, DMNORM INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER INSUFR, INSUFI, IXPR, IOWNS21, IOWNS22, JTYP, 1 MUSED, MXORDN, MXORDS INTEGER I, I1, I2, IFLAG, IMXER, KGO, LF0, 1 LENIW, LENRW, LENWM, ML, MORD, MU, MXHNL0, MXSTP0 INTEGER LEN1, LEN1C, LEN1N, LEN1S, LEN2, LENIWC, LENRWC DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION TSW, RCM1, RCM2, ROWNS21, ROWNS22, ROWNS23, 1 PDNORM DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 DIMENSION MORD(2) LOGICAL IHIT CHARACTER(LEN=80) MSG SAVE MORD, MXSTP0, MXHNL0 C----------------------------------------------------------------------- C The following two internal Common blocks contain C (a) variables which are local to any subroutine but whose values must C be preserved between calls to the routine ("own" variables), and C (b) variables which are communicated between subroutines. C The block DLS001 is declared in subroutines DLSODA, DINTDY, DSTODA, C DPRJA, and DSOLSY. C The block DLSA01 is declared in subroutines DLSODA, DSTODA, and DPRJA. C Groups of variables are replaced by dummy arrays in the Common C declarations in routines where those variables are not used. C----------------------------------------------------------------------- COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C COMMON /DLSA01/ TSW, RCM1(12), RCM2(5), ROWNS21, ROWNS22, ROWNS23, 1 PDNORM, INSUFR, INSUFI, IXPR, IOWNS21, IOWNS22, JTYP, MUSED, 2 MXORDN, MXORDS C DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ C----------------------------------------------------------------------- C Block A. C This code block is executed on every call. C It tests ISTATE and ITASK for legality and branches appropriately. C If ISTATE .gt. 1 but the flag INIT shows that initialization has C not yet been done, an error return occurs. C If ISTATE = 1 and TOUT = T, return immediately. C----------------------------------------------------------------------- C KARLINE: INITIALISED IHIT, LENWM TO AVOID COMPILER WARNINGS - SHOULD HAVE NO EFFEXT IHIT = .TRUE. LENWM = 0 IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 IF (ISTATE .EQ. 1) GO TO 10 IF (INIT .EQ. 0) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) RETURN C----------------------------------------------------------------------- C Block B. C The next code block is executed for the initial call (ISTATE = 1), C or for a continuation call with parameter changes (ISTATE = 3). C It contains checking of all inputs and various initializations. C C First check legality of the non-optional inputs NEQ, ITOL, IOPT, C JT, ML, and MU. C----------------------------------------------------------------------- 20 IF (NEQ(1) .LE. 0) GO TO 604 IF (ISTATE .EQ. 1) GO TO 25 IF (NEQ(1) .GT. N) GO TO 605 25 N = NEQ(1) IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 IF (JT .EQ. 3 .OR. JT .LT. 1 .OR. JT .GT. 5) GO TO 608 JTYP = JT IF (JT .LE. 2) GO TO 30 ML = IWORK(1) MU = IWORK(2) IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 30 CONTINUE C Next process and check the optional inputs. -------------------------- IF (IOPT .EQ. 1) GO TO 40 IXPR = 0 MXSTEP = MXSTP0 MXHNIL = MXHNL0 HMXI = 0.0D0 HMIN = 0.0D0 IF (ISTATE .NE. 1) GO TO 60 H0 = 0.0D0 MXORDN = MORD(1) MXORDS = MORD(2) GO TO 60 40 IXPR = IWORK(5) IF (IXPR .LT. 0 .OR. IXPR .GT. 1) GO TO 611 MXSTEP = IWORK(6) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .NE. 1) GO TO 50 H0 = RWORK(5) MXORDN = IWORK(8) IF (MXORDN .LT. 0) GO TO 628 IF (MXORDN .EQ. 0) MXORDN = 100 MXORDN = MIN(MXORDN,MORD(1)) MXORDS = IWORK(9) IF (MXORDS .LT. 0) GO TO 629 IF (MXORDS .EQ. 0) MXORDS = 100 MXORDS = MIN(MXORDS,MORD(2)) IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. 0.0D0) GO TO 615 HMXI = 0.0D0 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX HMIN = RWORK(7) IF (HMIN .LT. 0.0D0) GO TO 616 C----------------------------------------------------------------------- C Set work array pointers and check lengths LRW and LIW. C If ISTATE = 1, METH is initialized to 1 here to facilitate the C checking of work space lengths. C Pointers to segments of RWORK and IWORK are named by prefixing L to C the name of the segment. E.g., the segment YH starts at RWORK(LYH). C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR. C If the lengths provided are insufficient for the current method, C an error return occurs. This is treated as illegal input on the C first call, but as a problem interruption with ISTATE = -7 on a C continuation call. If the lengths are sufficient for the current C method but not for both methods, a warning message is sent. C----------------------------------------------------------------------- 60 IF (ISTATE .EQ. 1) METH = 1 IF (ISTATE .EQ. 1) NYH = N LYH = 21 LEN1N = 20 + (MXORDN + 1)*NYH LEN1S = 20 + (MXORDS + 1)*NYH LWM = LEN1S + 1 IF (JT .LE. 2) LENWM = N*N + 2 IF (JT .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 LEN1S = LEN1S + LENWM LEN1C = LEN1N IF (METH .EQ. 2) LEN1C = LEN1S LEN1 = MAX(LEN1N,LEN1S) LEN2 = 3*N LENRW = LEN1 + LEN2 LENRWC = LEN1C + LEN2 IWORK(17) = LENRW LIWM = 1 LENIW = 20 + N LENIWC = 20 IF (METH .EQ. 2) LENIWC = LENIW IWORK(18) = LENIW IF (ISTATE .EQ. 1 .AND. LRW .LT. LENRWC) GO TO 617 IF (ISTATE .EQ. 1 .AND. LIW .LT. LENIWC) GO TO 618 IF (ISTATE .EQ. 3 .AND. LRW .LT. LENRWC) GO TO 550 IF (ISTATE .EQ. 3 .AND. LIW .LT. LENIWC) GO TO 555 LEWT = LEN1 + 1 INSUFR = 0 IF (LRW .GE. LENRW) GO TO 65 INSUFR = 2 LEWT = LEN1C + 1 MSG='DLSODA- Warning.. RWORK length is sufficient for now, but ' CALL XERRWD (MSG, 60, 103, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' may not be later. Integration will proceed anyway. ' CALL XERRWD (MSG, 60, 103, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' Length needed is LENRW = I1, while LRW = I2.' CALL XERRWD (MSG, 50, 103, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 65 LSAVF = LEWT + N LACOR = LSAVF + N INSUFI = 0 IF (LIW .GE. LENIW) GO TO 70 INSUFI = 2 MSG='DLSODA- Warning.. IWORK length is sufficient for now, but ' CALL XERRWD (MSG, 60, 104, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' may not be later. Integration will proceed anyway. ' CALL XERRWD (MSG, 60, 104, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' Length needed is LENIW = I1, while LIW = I2.' CALL XERRWD (MSG, 50, 104, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) 70 CONTINUE C Check RTOL and ATOL for legality. ------------------------------------ RTOLI = RTOL(1) ATOLI = ATOL(1) DO 75 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. 0.0D0) GO TO 619 IF (ATOLI .LT. 0.0D0) GO TO 620 75 CONTINUE IF (ISTATE .EQ. 1) GO TO 100 C If ISTATE = 3, set flag to signal parameter changes to DSTODA. ------- JSTART = -1 IF (N .EQ. NYH) GO TO 200 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- I1 = LYH + L*NYH I2 = LYH + (MAXORD + 1)*NYH - 1 IF (I1 .GT. I2) GO TO 200 DO 95 I = I1,I2 RWORK(I) = 0.0D0 95 CONTINUE GO TO 200 C----------------------------------------------------------------------- C Block C. C The next block is for the initial call only (ISTATE = 1). C It contains all remaining initializations, the initial call to F, C and the calculation of the initial step size. C The error weights in EWT are inverted after being loaded. C----------------------------------------------------------------------- 100 UROUND = DUMACH() TN = T TSW = T MAXORD = MXORDN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 1 H0 = TCRIT - T 110 JSTART = 0 NHNIL = 0 NST = 0 NJE = 0 NSLAST = 0 HU = 0.0D0 NQU = 0 MUSED = 0 MITER = 0 CCMAX = 0.3D0 MAXCOR = 3 MSBP = 20 MXNCF = 10 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- LF0 = LYH + NYH CALL F (NEQ, T, Y, RWORK(LF0), rpar, ipar) NFE = 1 C Load the initial value vector in YH. --------------------------------- DO 115 I = 1,N RWORK(I+LYH-1) = Y(I) 115 CONTINUE C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- NQ = 1 H = 1.0D0 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 120 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 120 CONTINUE C----------------------------------------------------------------------- C The coding below computes the step size, H0, to be attempted on the C first step, unless the user has supplied a value for this. C First check that TOUT - T differs significantly from zero. C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i)) C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted C so as to be between 100*UROUND and 1.0E-3. C Then the computed value H0 is given by: C C H0**(-2) = 1./(TOL * w0**2) + TOL * (norm(F))**2 C C where w0 = MAX ( ABS(T), ABS(TOUT) ), C F = the initial value of the vector f(t,y), and C norm() = the weighted vector norm used throughout, given by C the DMNORM function routine, and weighted by the C tolerances initially loaded into the EWT array. C The sign of H0 is inferred from the initial values of TOUT and T. C ABS(H0) is made .le. ABS(TOUT-T) in any case. C----------------------------------------------------------------------- IF (H0 .NE. 0.0D0) GO TO 180 TDIST = ABS(TOUT - T) W0 = MAX(ABS(T),ABS(TOUT)) IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 TOL = RTOL(1) IF (ITOL .LE. 2) GO TO 140 DO 130 I = 1,N TOL = MAX(TOL,RTOL(I)) 130 CONTINUE 140 IF (TOL .GT. 0.0D0) GO TO 160 ATOLI = ATOL(1) DO 150 I = 1,N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) AYI = ABS(Y(I)) IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 150 CONTINUE 160 TOL = MAX(TOL,100.0D0*UROUND) TOL = MIN(TOL,0.001D0) SUM = DMNORM (N, RWORK(LF0), RWORK(LEWT)) SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 H0 = 1.0D0/SQRT(SUM) H0 = MIN(H0,TDIST) H0 = SIGN(H0,TOUT-T) C Adjust H0 if necessary to meet HMAX bound. --------------------------- 180 RH = ABS(H0)*HMXI IF (RH .GT. 1.0D0) H0 = H0/RH C Load H with H0 and scale YH(*,2) by H0. ------------------------------ H = H0 DO 190 I = 1,N RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 190 CONTINUE GO TO 270 C----------------------------------------------------------------------- C Block D. C The next code block is for continuation calls only (ISTATE = 2 or 3) C and is to check stop conditions before taking a step. C----------------------------------------------------------------------- 200 NSLAST = NST IF (ITASK .EQ. 1) THEN GOTO 210 ELSE IF (ITASK .EQ. 2) THEN GOTO 250 ELSE IF (ITASK .EQ. 3) THEN GOTO 220 ELSE IF (ITASK .EQ. 4) THEN GOTO 230 ELSE IF (ITASK .EQ. 5) THEN GOTO 240 ENDIF C karline: changed from C GO TO (210, 250, 220, 230, 240), ITASK 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 T = TN GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 245 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) T = TCRIT IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (ISTATE .EQ. 2 .AND. JSTART .GE. 0) JSTART = -2 C----------------------------------------------------------------------- C Block E. C The next block is normally executed for all calls and contains C the call to the one-step core integrator DSTODA. C C This is a looping point for the integration steps. C C First check for too many steps being taken, update EWT (if not at C start of problem), check for too much accuracy being requested, and C check for H below the roundoff level in T. C----------------------------------------------------------------------- 250 CONTINUE IF (METH .EQ. MUSED) GO TO 255 IF (INSUFR .EQ. 1) GO TO 550 IF (INSUFI .EQ. 1) GO TO 555 255 IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 260 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 260 CONTINUE 270 TOLSF = UROUND*DMNORM (N, RWORK(LYH), RWORK(LEWT)) IF (TOLSF .LE. 1.0D0) GO TO 280 TOLSF = TOLSF*2.0D0 IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 MSG = 'DLSODA- Warning..Internal T (=R1) and H (=R2) are' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' such that in the machine, T + H = T on the next step ' CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' (H = step size). Solver will continue anyway.' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 MSG = 'DLSODA- Above warning has been issued I1 times. ' CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' It will not be issued again for this problem.' CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 290 CONTINUE C----------------------------------------------------------------------- C CALL DSTODA(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,DPRJA,DSOLSY) C----------------------------------------------------------------------- CALL DSTODA (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), 2 F, JAC, DPRJA, DSOLSY, rpar,ipar) KGO = 1 - KFLAG IF (KGO .EQ. 1) THEN GOTO 300 ELSE IF (KGO .EQ. 2) THEN GOTO 530 ELSE IF (KGO .EQ. 3) THEN GOTO 540 ENDIF C karline: changed from C GO TO (300, 530, 540), KGO C----------------------------------------------------------------------- C Block F. C The following block handles the case of a successful return from the C core integrator (KFLAG = 0). C If a method switch was just made, record TSW, reset MAXORD, C set JSTART to -1 to signal DSTODA to complete the switch, C and do extra printing of data if IXPR = 1. C Then, in any case, check for stop conditions. C----------------------------------------------------------------------- 300 INIT = 1 IF (METH .EQ. MUSED) GO TO 310 TSW = TN MAXORD = MXORDN IF (METH .EQ. 2) MAXORD = MXORDS IF (METH .EQ. 2) RWORK(LWM) = SQRT(UROUND) INSUFR = MIN(INSUFR,1) INSUFI = MIN(INSUFI,1) JSTART = -1 IF (IXPR .EQ. 0) GO TO 310 IF (METH .EQ. 2) THEN MSG = 'Switch to BDF at T (=R1), new step (=R2): %g, %g' CALL rprintfd2(MSG // char(0), TN, H) ENDIF IF (METH .EQ. 1) THEN C MSG='DLSODA- A switch to the Adams (nonstiff) method has occurred' C KS CALL XERRWD (MSG, 60, 106, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) C CALL DBLEPR(MSG, 60, 0, 0) MSG = 'Switch to Adams at T (=R1), new step (=R2): %g, %g' CALL rprintfd2(MSG // char(0), TN, H) ENDIF c write(msg,'(A4,D18.10,A9,D18.10)') c & 'at T',TN,' new step', H C KS CALL XERRWD (MSG, 60, 107, 0, 1, NST, 0, 2, TN, H) c CALL DBLEPR(MSG, 60, 0, 0) 310 CONTINUE IF (ITASK .EQ. 1) THEN GOTO 320 ELSE IF (ITASK .EQ. 2) THEN GOTO 400 ELSE IF (ITASK .EQ. 3) THEN GOTO 330 ELSE IF (ITASK .EQ. 4) THEN GOTO 340 ELSE IF (ITASK .EQ. 5) THEN GOTO 350 ENDIF C Karline: changed from C GO TO (320, 400, 330, 340, 350), ITASK C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 320 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 GO TO 250 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 345 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (JSTART .GE. 0) JSTART = -2 GO TO 250 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 350 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX C----------------------------------------------------------------------- C Block G. C The following block handles all successful returns from DLSODA. C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. C ISTATE is set to 2, and the optional outputs are loaded into the C work arrays before returning. C----------------------------------------------------------------------- 400 DO 410 I = 1,N Y(I) = RWORK(I+LYH-1) 410 CONTINUE T = TN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 IF (IHIT) T = TCRIT 420 ISTATE = 2 RWORK(11) = HU RWORK(12) = H RWORK(13) = TN RWORK(15) = TSW IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = MUSED IWORK(20) = METH RETURN C----------------------------------------------------------------------- C Block H. C The following block handles all unsuccessful returns other than C those for illegal input. First the error message routine is called. C If there was an error test or convergence test failure, IMXER is set. C Then Y is loaded from YH and T is set to TN. C The optional outputs are loaded into the work arrays before returning. C----------------------------------------------------------------------- C The maximum number of steps was taken before reaching TOUT. ---------- 500 MSG = 'DLSODA- At current T (=R1), MXSTEP (=I1) steps ' CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' taken on this call before reaching TOUT ' CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) ISTATE = -1 GO TO 580 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 510 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODA- At T (=R1), EWT(I1) has become R2 .le. 0.' CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) ISTATE = -6 GO TO 580 C Too much accuracy requested for machine precision. ------------------- 520 MSG = 'DLSODA- At T (=R1), too much accuracy requested ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' for precision of machine.. See TOLSF (=R2) ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) RWORK(14) = TOLSF ISTATE = -2 GO TO 580 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 530 MSG = 'DLSODA- At T(=R1) and step size H(=R2), the error' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' test failed repeatedly or with ABS(H) = HMIN' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) ISTATE = -4 GO TO 560 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 540 MSG = 'DLSODA- At T (=R1) and step size H (=R2), the ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' corrector convergence failed repeatedly ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' or with ABS(H) = HMIN ' CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) ISTATE = -5 GO TO 560 C RWORK length too small to proceed. ----------------------------------- 550 MSG = 'DLSODA- At current T(=R1), RWORK length too small' CALL XERRWD (MSG, 50, 206, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' to proceed. The integration was otherwise successful.' CALL XERRWD (MSG, 60, 206, 0, 0, 0, 0, 1, TN, 0.0D0) ISTATE = -7 GO TO 580 C IWORK length too small to proceed. ----------------------------------- 555 MSG = 'DLSODA- At current T(=R1), IWORK length too small' CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' to proceed. The integration was otherwise successful.' CALL XERRWD (MSG, 60, 207, 0, 0, 0, 0, 1, TN, 0.0D0) ISTATE = -7 GO TO 580 C Compute IMXER if relevant. ------------------------------------------- 560 BIG = 0.0D0 IMXER = 1 DO 570 I = 1,N SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) IF (BIG .GE. SIZE) GO TO 570 BIG = SIZE IMXER = I 570 CONTINUE IWORK(16) = IMXER C Set Y vector, T, and optional outputs. ------------------------------- 580 DO 590 I = 1,N Y(I) = RWORK(I+LYH-1) 590 CONTINUE T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN RWORK(15) = TSW IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = MUSED IWORK(20) = METH RETURN C----------------------------------------------------------------------- C Block I. C The following block handles all error returns due to illegal input C (ISTATE = -3), as detected before calling the core integrator. C First the error message routine is called. If the illegal input C is a negative ISTATE, the run is aborted (apparent infinite loop). C----------------------------------------------------------------------- 601 MSG = 'DLSODA- ISTATE (=I1) illegal.' CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) IF (ISTATE .LT. 0) GO TO 800 GO TO 700 602 MSG = 'DLSODA- ITASK (=I1) illegal. ' CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) GO TO 700 603 MSG = 'DLSODA- ISTATE .gt. 1 but DLSODA not initialized.' CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) GO TO 700 604 MSG = 'DLSODA- NEQ (=I1) .lt. 1 ' CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) GO TO 700 605 MSG = 'DLSODA- ISTATE = 3 and NEQ increased (I1 to I2). ' CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 606 MSG = 'DLSODA- ITOL (=I1) illegal. ' CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) GO TO 700 607 MSG = 'DLSODA- IOPT (=I1) illegal. ' CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) GO TO 700 608 MSG = 'DLSODA- JT (=I1) illegal. ' CALL XERRWD (MSG, 30, 8, 0, 1, JT, 0, 0, 0.0D0, 0.0D0) GO TO 700 609 MSG = 'DLSODA- ML (=I1) illegal: .lt.0 or .ge.NEQ (=I2) ' CALL XERRWD (MSG, 50, 9, 0, 2, ML, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 610 MSG = 'DLSODA- MU (=I1) illegal: .lt.0 or .ge.NEQ (=I2) ' CALL XERRWD (MSG, 50, 10, 0, 2, MU, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 611 MSG = 'DLSODA- IXPR (=I1) illegal. ' CALL XERRWD (MSG, 30, 11, 0, 1, IXPR, 0, 0, 0.0D0, 0.0D0) GO TO 700 612 MSG = 'DLSODA- MXSTEP (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) GO TO 700 613 MSG = 'DLSODA- MXHNIL (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) GO TO 700 614 MSG = 'DLSODA- TOUT (=R1) behind T (=R2) ' CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) MSG = ' Integration direction is given by H0 (=R1) ' CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) GO TO 700 615 MSG = 'DLSODA- HMAX (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) GO TO 700 616 MSG = 'DLSODA- HMIN (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) GO TO 700 617 MSG='DLSODA- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 618 MSG='DLSODA- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) GO TO 700 619 MSG = 'DLSODA- RTOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) GO TO 700 620 MSG = 'DLSODA- ATOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) GO TO 700 621 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODA- EWT(I1) is R1 .le. 0.0 ' CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) GO TO 700 622 MSG='DLSODA- TOUT(=R1) too close to T(=R2) to start integration.' CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) GO TO 700 623 MSG='DLSODA- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) GO TO 700 624 MSG='DLSODA- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) GO TO 700 625 MSG='DLSODA- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) GO TO 700 626 MSG = 'DLSODA- At start of problem, too much accuracy ' CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' requested for precision of machine.. See TOLSF (=R1) ' CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) RWORK(14) = TOLSF GO TO 700 627 MSG = 'DLSODA- Trouble in DINTDY. ITASK = I1, TOUT = R1' CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) GO TO 700 628 MSG = 'DLSODA- MXORDN (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 28, 0, 1, MXORDN, 0, 0, 0.0D0, 0.0D0) GO TO 700 629 MSG = 'DLSODA- MXORDS (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 29, 0, 1, MXORDS, 0, 0, 0.0D0, 0.0D0) C 700 ISTATE = -3 RETURN C 800 MSG = 'DLSODA- Run aborted.. apparent infinite loop. ' CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) RETURN C----------------------- End of Subroutine DLSODA ---------------------- END *DECK DLSODAR SUBROUTINE DLSODAR (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, JT, 2 G, NG, JROOT, rpar, ipar) EXTERNAL F, JAC, G CKS: added rpar, ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, JT, 1 NG, JROOT DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW), 1 JROOT(NG) C----------------------------------------------------------------------- C This is the 12 November 2003 version of C DLSODAR: Livermore Solver for Ordinary Differential Equations, with C Automatic method switching for stiff and nonstiff problems, C and with Root-finding. C C This version is in double precision. C C DLSODAR solves the initial value problem for stiff or nonstiff C systems of first order ODEs, C dy/dt = f(t,y) , or, in component form, C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). C At the same time, it locates the roots of any of a set of functions C g(i) = g(i,t,y(1),...,y(NEQ)) (i = 1,...,ng). C C This a variant version of the DLSODE package. It differs from it C in two ways: C (a) It switches automatically between stiff and nonstiff methods. C This means that the user does not have to determine whether the C problem is stiff or not, and the solver will automatically choose the C appropriate method. It always starts with the nonstiff method. C (b) It finds the root of at least one of a set of constraint C functions g(i) of the independent and dependent variables. C It finds only those roots for which some g(i), as a function C of t, changes sign in the interval of integration. C It then returns the solution at the root, if that occurs C sooner than the specified stop condition, and otherwise returns C the solution according the specified stop condition. C C Authors: Alan C. Hindmarsh, C Center for Applied Scientific Computing, L-561 C Lawrence Livermore National Laboratory C Livermore, CA 94551 C and C Linda R. Petzold C Univ. of California at Santa Barbara C Dept. of Computer Science C Santa Barbara, CA 93106 C C References: C 1. Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), C North-Holland, Amsterdam, 1983, pp. 55-64. C 2. Linda R. Petzold, Automatic Selection of Methods for Solving C Stiff and Nonstiff Systems of Ordinary Differential Equations, C Siam J. Sci. Stat. Comput. 4 (1983), pp. 136-148. C 3. Kathie L. Hiebert and Lawrence F. Shampine, Implicitly Defined C Output Points for Solutions of ODEs, Sandia Report SAND80-0180, C February 1980. C----------------------------------------------------------------------- C Summary of Usage. C C Communication between the user and the DLSODAR package, for normal C situations, is summarized here. This summary describes only a subset C of the full set of options available. See the full description for C details, including alternative treatment of the Jacobian matrix, C optional inputs and outputs, nonstandard options, and C instructions for special situations. See also the example C problem (with program and output) following this summary. C C A. First provide a subroutine of the form: C SUBROUTINE F (NEQ, T, Y, YDOT,rpar,ipar) C INTEGER NEQ,ipar(*) C DOUBLE PRECISION T, Y(*), YDOT(*),rpar(*) C which supplies the vector function f by loading YDOT(i) with f(i). C C B. Provide a subroutine of the form: C SUBROUTINE G (NEQ, T, Y, NG, GOUT, rpar, ipar) C DOUBLE PRECISION T, Y(*), GOUT(NG), rpar(*) C which supplies the vector function g by loading GOUT(i) with C g(i), the i-th constraint function whose root is sought. C C C. Write a main program which calls Subroutine DLSODAR once for C each point at which answers are desired. This should also provide C for possible use of logical unit 6 for output of error messages by C DLSODAR. On the first call to DLSODAR, supply arguments as follows: C F = name of subroutine for right-hand side vector f. C This name must be declared External in calling program. C NEQ = number of first order ODEs. C Y = array of initial values, of length NEQ. C T = the initial value of the independent variable. C TOUT = first point where output is desired (.ne. T). C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. C RTOL = relative tolerance parameter (scalar). C ATOL = absolute tolerance parameter (scalar or array). C the estimated local error in y(i) will be controlled so as C to be less than C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. C Thus the local error test passes if, in each component, C either the absolute error is less than ATOL (or ATOL(i)), C or the relative error is less than RTOL. C Use RTOL = 0.0 for pure absolute error control, and C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error C control. Caution: actual (global) errors may exceed these C local tolerances, so choose them conservatively. C ITASK = 1 for normal computation of output values of y at t = TOUT. C ISTATE = integer flag (input and output). Set ISTATE = 1. C IOPT = 0 to indicate no optional inputs used. C RWORK = real work array of length at least: C 22 + NEQ * MAX(16, NEQ + 9) + 3*NG. C See also Paragraph F below. C LRW = declared length of RWORK (in user's dimension). C IWORK = integer work array of length at least 20 + NEQ. C LIW = declared length of IWORK (in user's dimension). C JAC = name of subroutine for Jacobian matrix. C Use a dummy name. See also Paragraph F below. C JT = Jacobian type indicator. Set JT = 2. C See also Paragraph F below. C G = name of subroutine for constraint functions, whose C roots are desired during the integration. C This name must be declared External in calling program. C NG = number of constraint functions g(i). If there are none, C set NG = 0, and pass a dummy name for G. C JROOT = integer array of length NG for output of root information. C See next paragraph. C Note that the main program must declare arrays Y, RWORK, IWORK, C JROOT, and possibly ATOL. C C D. The output from the first call (or any call) is: C Y = array of computed values of y(t) vector. C T = corresponding value of independent variable. This is C TOUT if ISTATE = 2, or the root location if ISTATE = 3, C or the farthest point reached if DLSODAR was unsuccessful. C ISTATE = 2 or 3 if DLSODAR was successful, negative otherwise. C 2 means no root was found, and TOUT was reached as desired. C 3 means a root was found prior to reaching TOUT. C -1 means excess work done on this call (perhaps wrong JT). C -2 means excess accuracy requested (tolerances too small). C -3 means illegal input detected (see printed message). C -4 means repeated error test failures (check all inputs). C -5 means repeated convergence failures (perhaps bad Jacobian C supplied or wrong choice of JT or tolerances). C -6 means error weight became zero during problem. (Solution C component i vanished, and ATOL or ATOL(i) = 0.) C -7 means work space insufficient to finish (see messages). C JROOT = array showing roots found if ISTATE = 3 on return. C JROOT(i) = 1 if g(i) has a root at t, or 0 otherwise. C C E. To continue the integration after a successful return, proceed C as follows: C (a) If ISTATE = 2 on return, reset TOUT and call DLSODAR again. C (b) If ISTATE = 3 on return, reset ISTATE to 2, call DLSODAR again. C In either case, no other parameters need be reset. C C F. Note: If and when DLSODAR regards the problem as stiff, and C switches methods accordingly, it must make use of the NEQ by NEQ C Jacobian matrix, J = df/dy. For the sake of simplicity, the C inputs to DLSODAR recommended in Paragraph C above cause DLSODAR to C treat J as a full matrix, and to approximate it internally by C difference quotients. Alternatively, J can be treated as a band C matrix (with great potential reduction in the size of the RWORK C array). Also, in either the full or banded case, the user can supply C J in closed form, with a routine whose name is passed as the JAC C argument. These alternatives are described in the paragraphs on C RWORK, JAC, and JT in the full description of the call sequence below. C C----------------------------------------------------------------------- C Example Problem. C C The following is a simple example problem, with the coding C needed for its solution by DLSODAR. The problem is from chemical C kinetics, and consists of the following three rate equations: C dy1/dt = -.04*y1 + 1.e4*y2*y3 C dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2 C dy3/dt = 3.e7*y2**2 C on the interval from t = 0.0 to t = 4.e10, with initial conditions C y1 = 1.0, y2 = y3 = 0. The problem is stiff. C In addition, we want to find the values of t, y1, y2, and y3 at which C (1) y1 reaches the value 1.e-4, and C (2) y3 reaches the value 1.e-2. C C The following coding solves this problem with DLSODAR, C printing results at t = .4, 4., ..., 4.e10, and at the computed C roots. It uses ITOL = 2 and ATOL much smaller for y2 than y1 or y3 C because y2 has much smaller values. C At the end of the run, statistical quantities of interest are C printed (see optional outputs in the full description below). C C EXTERNAL FEX, GEX C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y C DIMENSION Y(3), ATOL(3), RWORK(76), IWORK(23), JROOT(2) C NEQ = 3 C Y(1) = 1. C Y(2) = 0. C Y(3) = 0. C T = 0. C TOUT = .4 C ITOL = 2 C RTOL = 1.D-4 C ATOL(1) = 1.D-6 C ATOL(2) = 1.D-10 C ATOL(3) = 1.D-6 C ITASK = 1 C ISTATE = 1 C IOPT = 0 C LRW = 76 C LIW = 23 C JT = 2 C NG = 2 C DO 40 IOUT = 1,12 C 10 CALL DLSODAR(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE, C 1 IOPT,RWORK,LRW,IWORK,LIW,JDUM,JT,GEX,NG,JROOT) C WRITE(6,20)T,Y(1),Y(2),Y(3) C 20 FORMAT(' At t =',D12.4,' Y =',3D14.6) C IF (ISTATE .LT. 0) GO TO 80 C IF (ISTATE .EQ. 2) GO TO 40 C WRITE(6,30)JROOT(1),JROOT(2) C 30 FORMAT(5X,' The above line is a root, JROOT =',2I5) C ISTATE = 2 C GO TO 10 C 40 TOUT = TOUT*10. C WRITE(6,60)IWORK(11),IWORK(12),IWORK(13),IWORK(10), C 1 IWORK(19),RWORK(15) C 60 FORMAT(/' No. steps =',I4,' No. f-s =',I4,' No. J-s =',I4, C 1 ' No. g-s =',I4/ C 2 ' Method last used =',I2,' Last switch was at t =',D12.4) C STOP C 80 WRITE(6,90)ISTATE C 90 FORMAT(///' Error halt.. ISTATE =',I3) C STOP C END C C SUBROUTINE FEX (NEQ, T, Y, YDOT,rpar,ipar) C DOUBLE PRECISION T, Y, YDOT,rpar(*) C DIMENSION Y(3), YDOT(3) C YDOT(1) = -.04*Y(1) + 1.D4*Y(2)*Y(3) C YDOT(3) = 3.D7*Y(2)*Y(2) C YDOT(2) = -YDOT(1) - YDOT(3) C RETURN C END C C SUBROUTINE GEX (NEQ, T, Y, NG, GOUT) C DOUBLE PRECISION T, Y, GOUT C DIMENSION Y(3), GOUT(2) C GOUT(1) = Y(1) - 1.D-4 C GOUT(2) = Y(3) - 1.D-2 C RETURN C END C C The output of this program (on a CDC-7600 in single precision) C is as follows: C C At t = 2.6400e-01 y = 9.899653e-01 3.470563e-05 1.000000e-02 C The above line is a root, JROOT = 0 1 C At t = 4.0000e-01 Y = 9.851712e-01 3.386380e-05 1.479493e-02 C At t = 4.0000e+00 Y = 9.055333e-01 2.240655e-05 9.444430e-02 C At t = 4.0000e+01 Y = 7.158403e-01 9.186334e-06 2.841505e-01 C At t = 4.0000e+02 Y = 4.505250e-01 3.222964e-06 5.494717e-01 C At t = 4.0000e+03 Y = 1.831975e-01 8.941774e-07 8.168016e-01 C At t = 4.0000e+04 Y = 3.898730e-02 1.621940e-07 9.610125e-01 C At t = 4.0000e+05 Y = 4.936363e-03 1.984221e-08 9.950636e-01 C At t = 4.0000e+06 Y = 5.161831e-04 2.065786e-09 9.994838e-01 C At t = 2.0745e+07 Y = 1.000000e-04 4.000395e-10 9.999000e-01 C The above line is a root, JROOT = 1 0 C At t = 4.0000e+07 Y = 5.179817e-05 2.072032e-10 9.999482e-01 C At t = 4.0000e+08 Y = 5.283401e-06 2.113371e-11 9.999947e-01 C At t = 4.0000e+09 Y = 4.659031e-07 1.863613e-12 9.999995e-01 C At t = 4.0000e+10 Y = 1.404280e-08 5.617126e-14 1.000000e+00 C C No. steps = 361 No. f-s = 693 No. J-s = 64 No. g-s = 390 C Method last used = 2 Last switch was at t = 6.0092e-03 C C----------------------------------------------------------------------- C Full Description of User Interface to DLSODAR. C C The user interface to DLSODAR consists of the following parts. C C 1. The call sequence to Subroutine DLSODAR, which is a driver C routine for the solver. This includes descriptions of both C the call sequence arguments and of user-supplied routines. C Following these descriptions is a description of C optional inputs available through the call sequence, and then C a description of optional outputs (in the work arrays). C C 2. Descriptions of other routines in the DLSODAR package that may be C (optionally) called by the user. These provide the ability to C alter error message handling, save and restore the internal C Common, and obtain specified derivatives of the solution y(t). C C 3. Descriptions of Common blocks to be declared in overlay C or similar environments, or to be saved when doing an interrupt C of the problem and continued solution later. C C 4. Description of a subroutine in the DLSODAR package, C which the user may replace with his/her own version, if desired. C this relates to the measurement of errors. C C----------------------------------------------------------------------- C Part 1. Call Sequence. C C The call sequence parameters used for input only are C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, C JT, G, and NG, C that used only for output is JROOT, C and those used for both input and output are C Y, T, ISTATE. C The work arrays RWORK and IWORK are also used for conditional and C optional inputs and optional outputs. (The term output here refers C to the return from Subroutine DLSODAR to the user's calling program.) C C The legality of input parameters will be thoroughly checked on the C initial call for the problem, but not checked thereafter unless a C change in input parameters is flagged by ISTATE = 3 on input. C C The descriptions of the call arguments are as follows. C C F = the name of the user-supplied subroutine defining the C ODE system. The system must be put in the first-order C form dy/dt = f(t,y), where f is a vector-valued function C of the scalar t and the vector y. Subroutine F is to C compute the function f. It is to have the form C SUBROUTINE F (NEQ, T, Y, YDOT,rpar,ipar) C INTEGER NEQ,ipar(*) C DOUBLE PRECISION T, Y(*), YDOT(*),rpar(*) C where NEQ, T, and Y are input, and the array YDOT = f(t,y) C is output. Y and YDOT are arrays of length NEQ. C Subroutine F should not alter Y(1),...,Y(NEQ). C F must be declared External in the calling program. C C Subroutine F may access user-defined quantities in C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array C (dimensioned in F) and/or Y has length exceeding NEQ(1). C See the descriptions of NEQ and Y below. C C If quantities computed in the F routine are needed C externally to DLSODAR, an extra call to F should be made C for this purpose, for consistent and accurate results. C If only the derivative dy/dt is needed, use DINTDY instead. C C NEQ = the size of the ODE system (number of first order C ordinary differential equations). Used only for input. C NEQ may be decreased, but not increased, during the problem. C If NEQ is decreased (with ISTATE = 3 on input), the C remaining components of Y should be left undisturbed, if C these are to be accessed in F and/or JAC. C C Normally, NEQ is a scalar, and it is generally referred to C as a scalar in this user interface description. However, C NEQ may be an array, with NEQ(1) set to the system size. C (The DLSODAR package accesses only NEQ(1).) In either case, C this parameter is passed as the NEQ argument in all calls C to F, JAC, and G. Hence, if it is an array, locations C NEQ(2),... may be used to store other integer data and pass C it to F, JAC, and G. Each such subroutine must include C NEQ in a Dimension statement in that case. C C Y = a real array for the vector of dependent variables, of C length NEQ or more. Used for both input and output on the C first call (ISTATE = 1), and only for output on other calls. C On the first call, Y must contain the vector of initial C values. On output, Y contains the computed solution vector, C evaluated at T. If desired, the Y array may be used C for other purposes between calls to the solver. C C This array is passed as the Y argument in all calls to F, C JAC, and G. Hence its length may exceed NEQ, and locations C Y(NEQ+1),... may be used to store other real data and C pass it to F, JAC, and G. (The DLSODAR package accesses only C Y(1),...,Y(NEQ).) C C T = the independent variable. On input, T is used only on the C first call, as the initial point of the integration. C On output, after each call, T is the value at which a C computed solution y is evaluated (usually the same as TOUT). C If a root was found, T is the computed location of the C root reached first, on output. C On an error return, T is the farthest point reached. C C TOUT = the next value of t at which a computed solution is desired. C Used only for input. C C When starting the problem (ISTATE = 1), TOUT may be equal C to T for one call, then should .ne. T for the next call. C For the initial T, an input value of TOUT .ne. T is used C in order to determine the direction of the integration C (i.e. the algebraic sign of the step sizes) and the rough C scale of the problem. Integration in either direction C (forward or backward in t) is permitted. C C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after C the first call (i.e. the first call with TOUT .ne. T). C Otherwise, TOUT is required on every call. C C If ITASK = 1, 3, or 4, the values of TOUT need not be C monotone, but a value of TOUT which backs up is limited C to the current internal T interval, whose endpoints are C TCUR - HU and TCUR (see optional outputs, below, for C TCUR and HU). C C ITOL = an indicator for the type of error control. See C description below under ATOL. Used only for input. C C RTOL = a relative error tolerance parameter, either a scalar or C an array of length NEQ. See description below under ATOL. C Input only. C C ATOL = an absolute error tolerance parameter, either a scalar or C an array of length NEQ. Input only. C C The input parameters ITOL, RTOL, and ATOL determine C the error control performed by the solver. The solver will C control the vector E = (E(i)) of estimated local errors C in y, according to an inequality of the form C max-norm of ( E(i)/EWT(i) ) .le. 1, C where EWT = (EWT(i)) is a vector of positive error weights. C The values of RTOL and ATOL should all be non-negative. C The following table gives the types (scalar/array) of C RTOL and ATOL, and the corresponding form of EWT(i). C C ITOL RTOL ATOL EWT(i) C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) C C When either of these parameters is a scalar, it need not C be dimensioned in the user's calling program. C C If none of the above choices (with ITOL, RTOL, and ATOL C fixed throughout the problem) is suitable, more general C error controls can be obtained by substituting a C user-supplied routine for the setting of EWT. C See Part 4 below. C C If global errors are to be estimated by making a repeated C run on the same problem with smaller tolerances, then all C components of RTOL and ATOL (i.e. of EWT) should be scaled C down uniformly. C C ITASK = an index specifying the task to be performed. C input only. ITASK has the following values and meanings. C 1 means normal computation of output values of y(t) at C t = TOUT (by overshooting and interpolating). C 2 means take one step only and return. C 3 means stop at the first internal mesh point at or C beyond t = TOUT and return. C 4 means normal computation of output values of y(t) at C t = TOUT but without overshooting t = TCRIT. C TCRIT must be input as RWORK(1). TCRIT may be equal to C or beyond TOUT, but not behind it in the direction of C integration. This option is useful if the problem C has a singularity at or beyond t = TCRIT. C 5 means take one step, without passing TCRIT, and return. C TCRIT must be input as RWORK(1). C C Note: If ITASK = 4 or 5 and the solver reaches TCRIT C (within roundoff), it will return T = TCRIT (exactly) to C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, C in which case answers at t = TOUT are returned first). C C ISTATE = an index used for input and output to specify the C the state of the calculation. C C On input, the values of ISTATE are as follows. C 1 means this is the first call for the problem C (initializations will be done). See note below. C 2 means this is not the first call, and the calculation C is to continue normally, with no change in any input C parameters except possibly TOUT and ITASK. C (If ITOL, RTOL, and/or ATOL are changed between calls C with ISTATE = 2, the new values will be used but not C tested for legality.) C 3 means this is not the first call, and the C calculation is to continue normally, but with C a change in input parameters other than C TOUT and ITASK. Changes are allowed in C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, JT, ML, MU, C and any optional inputs except H0, MXORDN, and MXORDS. C (See IWORK description for ML and MU.) C In addition, immediately following a return with C ISTATE = 3 (root found), NG and G may be changed. C (But changing NG from 0 to .gt. 0 is not allowed.) C Note: A preliminary call with TOUT = T is not counted C as a first call here, as no initialization or checking of C input is done. (Such a call is sometimes useful for the C purpose of outputting the initial conditions.) C Thus the first call for which TOUT .ne. T requires C ISTATE = 1 on input. C C On output, ISTATE has the following values and meanings. C 1 means nothing was done; TOUT = t and ISTATE = 1 on input. C 2 means the integration was performed successfully, and C no roots were found. C 3 means the integration was successful, and one or more C roots were found before satisfying the stop condition C specified by ITASK. See JROOT. C -1 means an excessive amount of work (more than MXSTEP C steps) was done on this call, before completing the C requested task, but the integration was otherwise C successful as far as T. (MXSTEP is an optional input C and is normally 500.) To continue, the user may C simply reset ISTATE to a value .gt. 1 and call again C (the excess work step counter will be reset to 0). C In addition, the user may increase MXSTEP to avoid C this error return (see below on optional inputs). C -2 means too much accuracy was requested for the precision C of the machine being used. This was detected before C completing the requested task, but the integration C was successful as far as T. To continue, the tolerance C parameters must be reset, and ISTATE must be set C to 3. The optional output TOLSF may be used for this C purpose. (Note: If this condition is detected before C taking any steps, then an illegal input return C (ISTATE = -3) occurs instead.) C -3 means illegal input was detected, before taking any C integration steps. See written message for details. C Note: If the solver detects an infinite loop of calls C to the solver with illegal input, it will cause C the run to stop. C -4 means there were repeated error test failures on C one attempted step, before completing the requested C task, but the integration was successful as far as T. C The problem may have a singularity, or the input C may be inappropriate. C -5 means there were repeated convergence test failures on C one attempted step, before completing the requested C task, but the integration was successful as far as T. C This may be caused by an inaccurate Jacobian matrix, C if one is being used. C -6 means EWT(i) became zero for some i during the C integration. Pure relative error control (ATOL(i)=0.0) C was requested on a variable which has now vanished. C The integration was successful as far as T. C -7 means the length of RWORK and/or IWORK was too small to C proceed, but the integration was successful as far as T. C This happens when DLSODAR chooses to switch methods C but LRW and/or LIW is too small for the new method. C C Note: Since the normal output value of ISTATE is 2, C it does not need to be reset for normal continuation. C Also, since a negative input value of ISTATE will be C regarded as illegal, a negative output value requires the C user to change it, and possibly other inputs, before C calling the solver again. C C IOPT = an integer flag to specify whether or not any optional C inputs are being used on this call. Input only. C The optional inputs are listed separately below. C IOPT = 0 means no optional inputs are being used. C Default values will be used in all cases. C IOPT = 1 means one or more optional inputs are being used. C C RWORK = a real array (double precision) for work space, and (in the C first 20 words) for conditional and optional inputs and C optional outputs. C As DLSODAR switches automatically between stiff and nonstiff C methods, the required length of RWORK can change during the C problem. Thus the RWORK array passed to DLSODAR can either C have a static (fixed) length large enough for both methods, C or have a dynamic (changing) length altered by the calling C program in response to output from DLSODAR. C C --- Fixed Length Case --- C If the RWORK length is to be fixed, it should be at least C max (LRN, LRS), C where LRN and LRS are the RWORK lengths required when the C current method is nonstiff or stiff, respectively. C C The separate RWORK length requirements LRN and LRS are C as follows: C If NEQ is constant and the maximum method orders have C their default values, then C LRN = 20 + 16*NEQ + 3*NG, C LRS = 22 + 9*NEQ + NEQ**2 + 3*NG (JT = 1 or 2), C LRS = 22 + 10*NEQ + (2*ML+MU)*NEQ + 3*NG (JT = 4 or 5). C Under any other conditions, LRN and LRS are given by: C LRN = 20 + NYH*(MXORDN+1) + 3*NEQ + 3*NG, C LRS = 20 + NYH*(MXORDS+1) + 3*NEQ + LMAT + 3*NG, C where C NYH = the initial value of NEQ, C MXORDN = 12, unless a smaller value is given as an C optional input, C MXORDS = 5, unless a smaller value is given as an C optional input, C LMAT = length of matrix work space: C LMAT = NEQ**2 + 2 if JT = 1 or 2, C LMAT = (2*ML + MU + 1)*NEQ + 2 if JT = 4 or 5. C C --- Dynamic Length Case --- C If the length of RWORK is to be dynamic, then it should C be at least LRN or LRS, as defined above, depending on the C current method. Initially, it must be at least LRN (since C DLSODAR starts with the nonstiff method). On any return C from DLSODAR, the optional output MCUR indicates the current C method. If MCUR differs from the value it had on the C previous return, or if there has only been one call to C DLSODAR and MCUR is now 2, then DLSODAR has switched C methods during the last call, and the length of RWORK C should be reset (to LRN if MCUR = 1, or to LRS if C MCUR = 2). (An increase in the RWORK length is required C if DLSODAR returned ISTATE = -7, but not otherwise.) C After resetting the length, call DLSODAR with ISTATE = 3 C to signal that change. C C LRW = the length of the array RWORK, as declared by the user. C (This will be checked by the solver.) C C IWORK = an integer array for work space. C As DLSODAR switches automatically between stiff and nonstiff C methods, the required length of IWORK can change during C problem, between C LIS = 20 + NEQ and LIN = 20, C respectively. Thus the IWORK array passed to DLSODAR can C either have a fixed length of at least 20 + NEQ, or have a C dynamic length of at least LIN or LIS, depending on the C current method. The comments on dynamic length under C RWORK above apply here. Initially, this length need C only be at least LIN = 20. C C The first few words of IWORK are used for conditional and C optional inputs and optional outputs. C C The following 2 words in IWORK are conditional inputs: C IWORK(1) = ML These are the lower and upper C IWORK(2) = MU half-bandwidths, respectively, of the C banded Jacobian, excluding the main diagonal. C The band is defined by the matrix locations C (i,j) with i-ML .le. j .le. i+MU. ML and MU C must satisfy 0 .le. ML,MU .le. NEQ-1. C These are required if JT is 4 or 5, and C ignored otherwise. ML and MU may in fact be C the band parameters for a matrix to which C df/dy is only approximately equal. C C LIW = the length of the array IWORK, as declared by the user. C (This will be checked by the solver.) C C Note: The base addresses of the work arrays must not be C altered between calls to DLSODAR for the same problem. C The contents of the work arrays must not be altered C between calls, except possibly for the conditional and C optional inputs, and except for the last 3*NEQ words of RWORK. C The latter space is used for internal scratch space, and so is C available for use by the user outside DLSODAR between calls, if C desired (but not for use by F, JAC, or G). C C JAC = the name of the user-supplied routine to compute the C Jacobian matrix, df/dy, if JT = 1 or 4. The JAC routine C is optional, but if the problem is expected to be stiff much C of the time, you are encouraged to supply JAC, for the sake C of efficiency. (Alternatively, set JT = 2 or 5 to have C DLSODAR compute df/dy internally by difference quotients.) C If and when DLSODAR uses df/dy, it treats this NEQ by NEQ C matrix either as full (JT = 1 or 2), or as banded (JT = C 4 or 5) with half-bandwidths ML and MU (discussed under C IWORK above). In either case, if JT = 1 or 4, the JAC C routine must compute df/dy as a function of the scalar t C and the vector y. It is to have the form C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD,rpar,ipar) C DOUBLE PRECISION T, Y(*), PD(NROWPD,*),rpar(*) C where NEQ, T, Y, ML, MU, and NROWPD are input and the array C PD is to be loaded with partial derivatives (elements of C the Jacobian matrix) on output. PD must be given a first C dimension of NROWPD. T and Y have the same meaning as in C Subroutine F. C In the full matrix case (JT = 1), ML and MU are C ignored, and the Jacobian is to be loaded into PD in C columnwise manner, with df(i)/dy(j) loaded into pd(i,j). C In the band matrix case (JT = 4), the elements C within the band are to be loaded into PD in columnwise C manner, with diagonal lines of df/dy loaded into the rows C of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). C ML and MU are the half-bandwidth parameters (see IWORK). C The locations in PD in the two triangular areas which C correspond to nonexistent matrix elements can be ignored C or loaded arbitrarily, as they are overwritten by DLSODAR. C JAC need not provide df/dy exactly. A crude C approximation (possibly with a smaller bandwidth) will do. C In either case, PD is preset to zero by the solver, C so that only the nonzero elements need be loaded by JAC. C Each call to JAC is preceded by a call to F with the same C arguments NEQ, T, and Y. Thus to gain some efficiency, C intermediate quantities shared by both calculations may be C saved in a user Common block by F and not recomputed by JAC, C if desired. Also, JAC may alter the Y array, if desired. C JAC must be declared External in the calling program. C Subroutine JAC may access user-defined quantities in C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array C (dimensioned in JAC) and/or Y has length exceeding NEQ(1). C See the descriptions of NEQ and Y above. C C JT = Jacobian type indicator. Used only for input. C JT specifies how the Jacobian matrix df/dy will be C treated, if and when DLSODAR requires this matrix. C JT has the following values and meanings: C 1 means a user-supplied full (NEQ by NEQ) Jacobian. C 2 means an internally generated (difference quotient) full C Jacobian (using NEQ extra calls to F per df/dy value). C 4 means a user-supplied banded Jacobian. C 5 means an internally generated banded Jacobian (using C ML+MU+1 extra calls to F per df/dy evaluation). C If JT = 1 or 4, the user must supply a Subroutine JAC C (the name is arbitrary) as described above under JAC. C If JT = 2 or 5, a dummy argument can be used. C C G = the name of subroutine for constraint functions, whose C roots are desired during the integration. It is to have C the form C SUBROUTINE G (NEQ, T, Y, NG, GOUT, rpar, ipar) C DOUBLE PRECISION T, Y(*), GOUT(NG), rpar(*) C where NEQ, T, Y, and NG are input, and the array GOUT C is output. NEQ, T, and Y have the same meaning as in C the F routine, and GOUT is an array of length NG. C For i = 1,...,NG, this routine is to load into GOUT(i) C the value at (T,Y) of the i-th constraint function g(i). C DLSODAR will find roots of the g(i) of odd multiplicity C (i.e. sign changes) as they occur during the integration. C G must be declared External in the calling program. C C Caution: Because of numerical errors in the functions C g(i) due to roundoff and integration error, DLSODAR may C return false roots, or return the same root at two or more C nearly equal values of t. If such false roots are C suspected, the user should consider smaller error tolerances C and/or higher precision in the evaluation of the g(i). C C If a root of some g(i) defines the end of the problem, C the input to DLSODAR should nevertheless allow integration C to a point slightly past that root, so that DLSODAR can C locate the root by interpolation. C C Subroutine G may access user-defined quantities in C NEQ(2),... and Y(NEQ(1)+1),... if NEQ is an array C (dimensioned in G) and/or Y has length exceeding NEQ(1). C See the descriptions of NEQ and Y above. C C NG = number of constraint functions g(i). If there are none, C set NG = 0, and pass a dummy name for G. C C JROOT = integer array of length NG. Used only for output. C On a return with ISTATE = 3 (one or more roots found), C JROOT(i) = 1 if g(i) has a root at T, or JROOT(i) = 0 if not. C----------------------------------------------------------------------- C Optional Inputs. C C The following is a list of the optional inputs provided for in the C call sequence. (See also Part 2.) For each such input variable, C this table lists its name as used in this documentation, its C location in the call sequence, its meaning, and the default value. C The use of any of these inputs requires IOPT = 1, and in that C case all of these inputs are examined. A value of zero for any C of these optional inputs will cause the default value to be used. C Thus to use a subset of the optional inputs, simply preload C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and C then set those of interest to nonzero values. C C Name Location Meaning and Default Value C C H0 RWORK(5) the step size to be attempted on the first step. C The default value is determined by the solver. C C HMAX RWORK(6) the maximum absolute step size allowed. C The default value is infinite. C C HMIN RWORK(7) the minimum absolute step size allowed. C The default value is 0. (This lower bound is not C enforced on the final step before reaching TCRIT C when ITASK = 4 or 5.) C C IXPR IWORK(5) flag to generate extra printing at method switches. C IXPR = 0 means no extra printing (the default). C IXPR = 1 means print data on each switch. C T, H, and NST will be printed on the same logical C unit as used for error messages. C C MXSTEP IWORK(6) maximum number of (internally defined) steps C allowed during one call to the solver. C The default value is 500. C C MXHNIL IWORK(7) maximum number of messages printed (per problem) C warning that T + H = T on a step (H = step size). C This must be positive to result in a non-default C value. The default value is 10. C C MXORDN IWORK(8) the maximum order to be allowed for the nonstiff C (Adams) method. The default value is 12. C If MXORDN exceeds the default value, it will C be reduced to the default value. C MXORDN is held constant during the problem. C C MXORDS IWORK(9) the maximum order to be allowed for the stiff C (BDF) method. The default value is 5. C If MXORDS exceeds the default value, it will C be reduced to the default value. C MXORDS is held constant during the problem. C----------------------------------------------------------------------- C Optional Outputs. C C As optional additional output from DLSODAR, the variables listed C below are quantities related to the performance of DLSODAR C which are available to the user. These are communicated by way of C the work arrays, but also have internal mnemonic names as shown. C Except where stated otherwise, all of these outputs are defined C on any successful return from DLSODAR, and on any return with C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return C (ISTATE = -3), they will be unchanged from their existing values C (if any), except possibly for TOLSF, LENRW, and LENIW. C On any error return, outputs relevant to the error will be defined, C as noted below. C C Name Location Meaning C C HU RWORK(11) the step size in t last used (successfully). C C HCUR RWORK(12) the step size to be attempted on the next step. C C TCUR RWORK(13) the current value of the independent variable C which the solver has actually reached, i.e. the C current internal mesh point in t. On output, TCUR C will always be at least as far as the argument C T, but may be farther (if interpolation was done). C C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0, C computed when a request for too much accuracy was C detected (ISTATE = -3 if detected at the start of C the problem, ISTATE = -2 otherwise). If ITOL is C left unaltered but RTOL and ATOL are uniformly C scaled up by a factor of TOLSF for the next call, C then the solver is deemed likely to succeed. C (The user may also ignore TOLSF and alter the C tolerance parameters in any other way appropriate.) C C TSW RWORK(15) the value of t at the time of the last method C switch, if any. C C NGE IWORK(10) the number of g evaluations for the problem so far. C C NST IWORK(11) the number of steps taken for the problem so far. C C NFE IWORK(12) the number of f evaluations for the problem so far. C C NJE IWORK(13) the number of Jacobian evaluations (and of matrix C LU decompositions) for the problem so far. C C NQU IWORK(14) the method order last used (successfully). C C NQCUR IWORK(15) the order to be attempted on the next step. C C IMXER IWORK(16) the index of the component of largest magnitude in C the weighted local error vector ( E(i)/EWT(i) ), C on an error return with ISTATE = -4 or -5. C C LENRW IWORK(17) the length of RWORK actually required, assuming C that the length of RWORK is to be fixed for the C rest of the problem, and that switching may occur. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C LENIW IWORK(18) the length of IWORK actually required, assuming C that the length of IWORK is to be fixed for the C rest of the problem, and that switching may occur. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C MUSED IWORK(19) the method indicator for the last successful step: C 1 means Adams (nonstiff), 2 means BDF (stiff). C C MCUR IWORK(20) the current method indicator: C 1 means Adams (nonstiff), 2 means BDF (stiff). C This is the method to be attempted C on the next step. Thus it differs from MUSED C only if a method switch has just been made. C C The following two arrays are segments of the RWORK array which C may also be of interest to the user as optional outputs. C For each array, the table below gives its internal name, C its base address in RWORK, and its description. C C Name Base Address Description C C YH 21 + 3*NG the Nordsieck history array, of size NYH by C (NQCUR + 1), where NYH is the initial value C of NEQ. For j = 0,1,...,NQCUR, column j+1 C of YH contains HCUR**j/factorial(j) times C the j-th derivative of the interpolating C polynomial currently representing the solution, C evaluated at t = TCUR. C C ACOR LACOR array of size NEQ used for the accumulated C (from Common corrections on each step, scaled on output C as noted) to represent the estimated local error in y C on the last step. This is the vector E in C the description of the error control. It is C defined only on a successful return from C DLSODAR. The base address LACOR is obtained by C including in the user's program the C following 2 lines: C COMMON /DLS001/ RLS(218), ILS(37) C LACOR = ILS(22) C C----------------------------------------------------------------------- C Part 2. Other Routines Callable. C C The following are optional calls which the user may make to C gain additional capabilities in conjunction with DLSODAR. C (The routines XSETUN and XSETF are designed to conform to the C SLATEC error handling package.) C C Form of Call Function C CALL XSETUN(LUN) Set the logical unit number, LUN, for C output of messages from DLSODAR, if C the default is not desired. C The default value of LUN is 6. C C CALL XSETF(MFLAG) Set a flag to control the printing of C messages by DLSODAR. C MFLAG = 0 means do not print. (Danger: C This risks losing valuable information.) C MFLAG = 1 means print (the default). C C Either of the above calls may be made at C any time and will take effect immediately. C C CALL DSRCAR(RSAV,ISAV,JOB) saves and restores the contents of C the internal Common blocks used by C DLSODAR (see Part 3 below). C RSAV must be a real array of length 245 C or more, and ISAV must be an integer C array of length 55 or more. C JOB=1 means save Common into RSAV/ISAV. C JOB=2 means restore Common from RSAV/ISAV. C DSRCAR is useful if one is C interrupting a run and restarting C later, or alternating between two or C more problems solved with DLSODAR. C C CALL DINTDY(,,,,,) Provide derivatives of y, of various C (see below) orders, at a specified point t, if C desired. It may be called only after C a successful return from DLSODAR. C C The detailed instructions for using DINTDY are as follows. C The form of the call is: C C LYH = 21 + 3*NG C CALL DINTDY (T, K, RWORK(LYH), NYH, DKY, IFLAG) C C The input parameters are: C C T = value of independent variable where answers are desired C (normally the same as the T last returned by DLSODAR). C For valid results, T must lie between TCUR - HU and TCUR. C (See optional outputs for TCUR and HU.) C K = integer order of the derivative desired. K must satisfy C 0 .le. K .le. NQCUR, where NQCUR is the current order C (see optional outputs). The capability corresponding C to K = 0, i.e. computing y(t), is already provided C by DLSODAR directly. Since NQCUR .ge. 1, the first C derivative dy/dt is always available with DINTDY. C LYH = 21 + 3*NG = base address in RWORK of the history array YH. C NYH = column length of YH, equal to the initial value of NEQ. C C The output parameters are: C C DKY = a real array of length NEQ containing the computed value C of the K-th derivative of y(t). C IFLAG = integer flag, returned as 0 if K and T were legal, C -1 if K was illegal, and -2 if T was illegal. C On an error return, a message is also written. C----------------------------------------------------------------------- C Part 3. Common Blocks. C C If DLSODAR is to be used in an overlay situation, the user C must declare, in the primary overlay, the variables in: C (1) the call sequence to DLSODAR, and C (2) the three internal Common blocks C /DLS001/ of length 255 (218 double precision words C followed by 37 integer words), C /DLSA01/ of length 31 (22 double precision words C followed by 9 integer words). C /DLSR01/ of length 7 (3 double precision words C followed by 4 integer words). C C If DLSODAR is used on a system in which the contents of internal C Common blocks are not preserved between calls, the user should C declare the above Common blocks in the calling program to insure C that their contents are preserved. C C If the solution of a given problem by DLSODAR is to be interrupted C and then later continued, such as when restarting an interrupted run C or alternating between two or more problems, the user should save, C following the return from the last DLSODAR call prior to the C interruption, the contents of the call sequence variables and the C internal Common blocks, and later restore these values before the C next DLSODAR call for that problem. To save and restore the Common C blocks, use Subroutine DSRCAR (see Part 2 above). C C----------------------------------------------------------------------- C Part 4. Optionally Replaceable Solver Routines. C C Below is a description of a routine in the DLSODAR package which C relates to the measurement of errors, and can be C replaced by a user-supplied version, if desired. However, since such C a replacement may have a major impact on performance, it should be C done only when absolutely necessary, and only with great caution. C (Note: The means by which the package version of a routine is C superseded by the user's version may be system-dependent.) C C (a) DEWSET. C The following subroutine is called just before each internal C integration step, and sets the array of error weights, EWT, as C described under ITOL/RTOL/ATOL above: C Subroutine DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODAR call sequence, C YCUR contains the current dependent variable vector, and C EWT is the array of weights set by DEWSET. C C If the user supplies this subroutine, it must return in EWT(i) C (i = 1,...,NEQ) a positive quantity suitable for comparing errors C in y(i) to. The EWT array returned by DEWSET is passed to the C DMNORM routine, and also used by DLSODAR in the computation C of the optional output IMXER, and the increments for difference C quotient Jacobians. C C In the user-supplied version of DEWSET, it may be desirable to use C the current values of derivatives of y. Derivatives up to order NQ C are available from the history array YH, described above under C optional outputs. In DEWSET, YH is identical to the YCUR array, C extended to NQ + 1 columns with a column length of NYH and scale C factors of H**j/factorial(j). On the first call for the problem, C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. C NYH is the initial value of NEQ. The quantities NQ, H, and NST C can be obtained by including in DEWSET the statements: C DOUBLE PRECISION RLS C COMMON /DLS001/ RLS(218),ILS(37) C NQ = ILS(33) C NST = ILS(34) C H = RLS(212) C Thus, for example, the current value of dy/dt can be obtained as C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is C unnecessary when NST = 0). C----------------------------------------------------------------------- C C***REVISION HISTORY (YYYYMMDD) C 19811102 DATE WRITTEN C 19820126 Fixed bug in tests of work space lengths; C minor corrections in main prologue and comments. C 19820507 Fixed bug in RCHEK in setting HMING. C 19870330 Major update: corrected comments throughout; C removed TRET from Common; rewrote EWSET with 4 loops; C fixed t test in INTDY; added Cray directives in STODA; C in STODA, fixed DELP init. and logic around PJAC call; C combined routines to save/restore Common; C passed LEVEL = 0 in error message calls (except run abort). C 19970225 Fixed lines setting JSTART = -2 in Subroutine LSODAR. C 20010425 Major update: convert source lines to upper case; C added *DECK lines; changed from 1 to * in dummy dimensions; C changed names R1MACH/D1MACH to RUMACH/DUMACH; C renamed routines for uniqueness across single/double prec.; C converted intrinsic names to generic form; C removed ILLIN and NTREP (data loaded) from Common; C removed all 'own' variables from Common; C changed error messages to quoted strings; C replaced XERRWV/XERRWD with 1993 revised version; C converted prologues, comments, error messages to mixed case; C numerous corrections to prologues and internal comments. C 20010507 Converted single precision source to double precision. C 20010613 Revised excess accuracy test (to match rest of ODEPACK). C 20010808 Fixed bug in DPRJA (matrix in DBNORM call). C 20020502 Corrected declarations in descriptions of user routines. C 20031105 Restored 'own' variables to Common blocks, to enable C interrupt/restart feature. C 20031112 Added SAVE statements for data-loaded constants. C C----------------------------------------------------------------------- C Other routines in the DLSODAR package. C C In addition to Subroutine DLSODAR, the DLSODAR package includes the C following subroutines and function routines: C DRCHEK does preliminary checking for roots, and serves as an C interface between Subroutine DLSODAR and Subroutine DROOTS. C DROOTS finds the leftmost root of a set of functions. C DINTDY computes an interpolated value of the y vector at t = TOUT. C DSTODA is the core integrator, which does one step of the C integration and the associated error control. C DCFODE sets all method coefficients and test constants. C DPRJA computes and preprocesses the Jacobian matrix J = df/dy C and the Newton iteration matrix P = I - h*l0*J. C DSOLSY manages solution of linear system in chord iteration. C DEWSET sets the error weight vector EWT before each step. C DMNORM computes the weighted max-norm of a vector. C DFNORM computes the norm of a full matrix consistent with the C weighted max-norm on vectors. C DBNORM computes the norm of a band matrix consistent with the C weighted max-norm on vectors. C DSRCAR is a user-callable routine to save and restore C the contents of the internal Common blocks. C DGEFA and DGESL are routines from LINPACK for solving full C systems of linear algebraic equations. C DGBFA and DGBSL are routines from LINPACK for solving banded C linear systems. C DCOPY is one of the basic linear algebra modules (BLAS). C DUMACH computes the unit roundoff in a machine-independent manner. C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all C error messages and warnings. XERRWD is machine-dependent. C Note: DMNORM, DFNORM, DBNORM, DUMACH, IXSAV, and IUMACH are C function routines. All the others are subroutines. C C----------------------------------------------------------------------- EXTERNAL DPRJA, DSOLSY DOUBLE PRECISION DUMACH, DMNORM INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER INSUFR, INSUFI, IXPR, IOWNS21, IOWNS22, JTYP, MUSED, 1 MXORDN, MXORDS INTEGER LG0, LG1, LGX, IMAX, LAST, IRFND, ITASKC, NGC, NGE INTEGER I, I1, I2, IFLAG, IMXER, KGO, LENIW, 1 LENRW, LENWM, LF0, ML, MORD, MU, MXHNL0, MXSTP0 INTEGER LEN1, LEN1C, LEN1N, LEN1S, LEN2, LENIWC, LENRWC INTEGER IRFP, IRT, LENYH, LYHNEW DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION TSW, RCM1, RCM2, ROWNS21, ROWNS22, ROWNS23, 1 PDNORM DOUBLE PRECISION ALPHA, X2, T0, TLAST, TOUTC DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 DIMENSION MORD(2) LOGICAL IHIT CHARACTER(LEN=60) MSG SAVE MORD, MXSTP0, MXHNL0 C----------------------------------------------------------------------- C The following three internal Common blocks contain C (a) variables which are local to any subroutine but whose values must C be preserved between calls to the routine ("own" variables), and C (b) variables which are communicated between subroutines. C The block DLS001 is declared in subroutines DLSODAR, DINTDY, DSTODA, C DPRJA, and DSOLSY. C The block DLSA01 is declared in subroutines DLSODAR, DSTODA, DPRJA. C The block DLSR01 is declared in subroutines DLSODAR, DRCHEK, DROOTS. C Groups of variables are replaced by dummy arrays in the Common C declarations in routines where those variables are not used. C----------------------------------------------------------------------- COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C COMMON /DLSA01/ TSW, RCM1(12), RCM2(5), ROWNS21, ROWNS22, ROWNS23, 1 PDNORM, INSUFR, INSUFI, IXPR, IOWNS21, IOWNS22, JTYP, MUSED, 2 MXORDN, MXORDS C C COMMON /DLSR01/ ROWNR3(2), T0, TLAST, TOUTC, C 1 LG0, LG1, LGX, IOWNR3(2), IRFND, ITASKC, NGC, NGE COMMON /DLSR01/ ALPHA, X2, T0, TLAST, TOUTC, 1 LG0, LG1, LGX, IMAX, LAST, IRFND, ITASKC, NGC, NGE C DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ C----------------------------------------------------------------------- C Block A. C This code block is executed on every call. C It tests ISTATE and ITASK for legality and branches appropriately. C If ISTATE .gt. 1 but the flag INIT shows that initialization has C not yet been done, an error return occurs. C If ISTATE = 1 and TOUT = T, return immediately. C----------------------------------------------------------------------- C KARLINE: INITIALISED IHIT LEN1S TO AVOID COMPILER WARNINGS - SHOULD HAVE NO EFFEXT IHIT = .TRUE. LEN1S = 0 IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 ITASKC = ITASK IF (ISTATE .EQ. 1) GO TO 10 IF (INIT .EQ. 0) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) RETURN C----------------------------------------------------------------------- C Block B. C The next code block is executed for the initial call (ISTATE = 1), C or for a continuation call with parameter changes (ISTATE = 3). C It contains checking of all inputs and various initializations. C C First check legality of the non-optional inputs NEQ, ITOL, IOPT, C JT, ML, MU, and NG. C----------------------------------------------------------------------- 20 IF (NEQ(1) .LE. 0) GO TO 604 IF (ISTATE .EQ. 1) GO TO 25 IF (NEQ(1) .GT. N) GO TO 605 25 N = NEQ(1) IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 IF (JT .EQ. 3 .OR. JT .LT. 1 .OR. JT .GT. 5) GO TO 608 JTYP = JT IF (JT .LE. 2) GO TO 30 ML = IWORK(1) MU = IWORK(2) IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 30 CONTINUE IF (NG .LT. 0) GO TO 630 IF (ISTATE .EQ. 1) GO TO 35 IF (IRFND .EQ. 0 .AND. NG .NE. NGC) GO TO 631 35 NGC = NG C Next process and check the optional inputs. -------------------------- IF (IOPT .EQ. 1) GO TO 40 IXPR = 0 MXSTEP = MXSTP0 MXHNIL = MXHNL0 HMXI = 0.0D0 HMIN = 0.0D0 IF (ISTATE .NE. 1) GO TO 60 H0 = 0.0D0 MXORDN = MORD(1) MXORDS = MORD(2) GO TO 60 40 IXPR = IWORK(5) IF (IXPR .LT. 0 .OR. IXPR .GT. 1) GO TO 611 MXSTEP = IWORK(6) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .NE. 1) GO TO 50 H0 = RWORK(5) MXORDN = IWORK(8) IF (MXORDN .LT. 0) GO TO 628 IF (MXORDN .EQ. 0) MXORDN = 100 MXORDN = MIN(MXORDN,MORD(1)) MXORDS = IWORK(9) IF (MXORDS .LT. 0) GO TO 629 IF (MXORDS .EQ. 0) MXORDS = 100 MXORDS = MIN(MXORDS,MORD(2)) IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. 0.0D0) GO TO 615 HMXI = 0.0D0 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX HMIN = RWORK(7) IF (HMIN .LT. 0.0D0) GO TO 616 C----------------------------------------------------------------------- C Set work array pointers and check lengths LRW and LIW. C If ISTATE = 1, METH is initialized to 1 here to facilitate the C checking of work space lengths. C Pointers to segments of RWORK and IWORK are named by prefixing L to C the name of the segment. E.g., the segment YH starts at RWORK(LYH). C Segments of RWORK (in order) are denoted G0, G1, GX, YH, WM, C EWT, SAVF, ACOR. C If the lengths provided are insufficient for the current method, C an error return occurs. This is treated as illegal input on the C first call, but as a problem interruption with ISTATE = -7 on a C continuation call. If the lengths are sufficient for the current C method but not for both methods, a warning message is sent. C----------------------------------------------------------------------- 60 IF (ISTATE .EQ. 1) METH = 1 IF (ISTATE .EQ. 1) NYH = N LG0 = 21 LG1 = LG0 + NG LGX = LG1 + NG LYHNEW = LGX + NG IF (ISTATE .EQ. 1) LYH = LYHNEW IF (LYHNEW .EQ. LYH) GO TO 62 C If ISTATE = 3 and NG was changed, shift YH to its new location. ------ LENYH = L*NYH IF (LRW .LT. LYHNEW-1+LENYH) GO TO 62 I1 = 1 IF (LYHNEW .GT. LYH) I1 = -1 CALL DCOPY (LENYH, RWORK(LYH), I1, RWORK(LYHNEW), I1) LYH = LYHNEW 62 CONTINUE LEN1N = LYHNEW - 1 + (MXORDN + 1)*NYH LEN1S = LYHNEW - 1 + (MXORDS + 1)*NYH LWM = LEN1S + 1 IF (JT .LE. 2) LENWM = N*N + 2 IF (JT .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 LEN1S = LEN1S + LENWM LEN1C = LEN1N IF (METH .EQ. 2) LEN1C = LEN1S LEN1 = MAX(LEN1N,LEN1S) LEN2 = 3*N LENRW = LEN1 + LEN2 LENRWC = LEN1C + LEN2 IWORK(17) = LENRW LIWM = 1 LENIW = 20 + N LENIWC = 20 IF (METH .EQ. 2) LENIWC = LENIW IWORK(18) = LENIW IF (ISTATE .EQ. 1 .AND. LRW .LT. LENRWC) GO TO 617 IF (ISTATE .EQ. 1 .AND. LIW .LT. LENIWC) GO TO 618 IF (ISTATE .EQ. 3 .AND. LRW .LT. LENRWC) GO TO 550 IF (ISTATE .EQ. 3 .AND. LIW .LT. LENIWC) GO TO 555 LEWT = LEN1 + 1 INSUFR = 0 IF (LRW .GE. LENRW) GO TO 65 INSUFR = 2 LEWT = LEN1C + 1 MSG='DLSODAR- Warning.. RWORK length is sufficient for now, but ' CALL XERRWD (MSG, 60, 103, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' may not be later. Integration will proceed anyway. ' CALL XERRWD (MSG, 60, 103, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' Length needed is LENRW = I1, while LRW = I2.' CALL XERRWD (MSG, 50, 103, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 65 LSAVF = LEWT + N LACOR = LSAVF + N INSUFI = 0 IF (LIW .GE. LENIW) GO TO 70 INSUFI = 2 MSG='DLSODAR- Warning.. IWORK length is sufficient for now, but ' CALL XERRWD (MSG, 60, 104, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' may not be later. Integration will proceed anyway. ' CALL XERRWD (MSG, 60, 104, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' Length needed is LENIW = I1, while LIW = I2.' CALL XERRWD (MSG, 50, 104, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) 70 CONTINUE C Check RTOL and ATOL for legality. ------------------------------------ RTOLI = RTOL(1) ATOLI = ATOL(1) DO 75 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. 0.0D0) GO TO 619 IF (ATOLI .LT. 0.0D0) GO TO 620 75 CONTINUE IF (ISTATE .EQ. 1) GO TO 100 C if ISTATE = 3, set flag to signal parameter changes to DSTODA. ------- JSTART = -1 IF (N .EQ. NYH) GO TO 200 C NEQ was reduced. zero part of yh to avoid undefined references. ----- I1 = LYH + L*NYH I2 = LYH + (MAXORD + 1)*NYH - 1 IF (I1 .GT. I2) GO TO 200 DO 95 I = I1,I2 RWORK(I) = 0.0D0 95 CONTINUE GO TO 200 C----------------------------------------------------------------------- C Block C. C The next block is for the initial call only (ISTATE = 1). C It contains all remaining initializations, the initial call to F, C and the calculation of the initial step size. C The error weights in EWT are inverted after being loaded. C----------------------------------------------------------------------- 100 UROUND = DUMACH() TN = T TSW = T MAXORD = MXORDN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 1 H0 = TCRIT - T 110 JSTART = 0 NHNIL = 0 NST = 0 NJE = 0 NSLAST = 0 HU = 0.0D0 NQU = 0 MUSED = 0 MITER = 0 CCMAX = 0.3D0 MAXCOR = 3 MSBP = 20 MXNCF = 10 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- LF0 = LYH + NYH CALL F (NEQ, T, Y, RWORK(LF0), rpar, ipar) NFE = 1 C Load the initial value vector in YH. --------------------------------- DO 115 I = 1,N RWORK(I+LYH-1) = Y(I) 115 CONTINUE C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- NQ = 1 H = 1.0D0 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 120 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 120 CONTINUE C----------------------------------------------------------------------- C The coding below computes the step size, H0, to be attempted on the C first step, unless the user has supplied a value for this. C First check that TOUT - T differs significantly from zero. C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i)) C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted C so as to be between 100*UROUND and 1.0E-3. C Then the computed value H0 is given by: C C H0**(-2) = 1./(TOL * w0**2) + TOL * (norm(F))**2 C C where w0 = MAX ( ABS(T), ABS(TOUT) ), C F = the initial value of the vector f(t,y), and C norm() = the weighted vector norm used throughout, given by C the DMNORM function routine, and weighted by the C tolerances initially loaded into the EWT array. C The sign of H0 is inferred from the initial values of TOUT and T. C ABS(H0) is made .le. ABS(TOUT-T) in any case. C----------------------------------------------------------------------- IF (H0 .NE. 0.0D0) GO TO 180 TDIST = ABS(TOUT - T) W0 = MAX(ABS(T),ABS(TOUT)) IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 TOL = RTOL(1) IF (ITOL .LE. 2) GO TO 140 DO 130 I = 1,N TOL = MAX(TOL,RTOL(I)) 130 CONTINUE 140 IF (TOL .GT. 0.0D0) GO TO 160 ATOLI = ATOL(1) DO 150 I = 1,N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) AYI = ABS(Y(I)) IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 150 CONTINUE 160 TOL = MAX(TOL,100.0D0*UROUND) TOL = MIN(TOL,0.001D0) SUM = DMNORM (N, RWORK(LF0), RWORK(LEWT)) SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 H0 = 1.0D0/SQRT(SUM) H0 = MIN(H0,TDIST) H0 = SIGN(H0,TOUT-T) C Adjust H0 if necessary to meet HMAX bound. --------------------------- 180 RH = ABS(H0)*HMXI IF (RH .GT. 1.0D0) H0 = H0/RH C Load H with H0 and scale YH(*,2) by H0. ------------------------------ H = H0 DO 190 I = 1,N RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 190 CONTINUE C C Check for a zero of g at T. ------------------------------------------ IRFND = 0 TOUTC = TOUT IF (NGC .EQ. 0) GO TO 270 CALL DRCHEK (1, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .EQ. 0) GO TO 270 GO TO 632 C----------------------------------------------------------------------- C Block D. C The next code block is for continuation calls only (ISTATE = 2 or 3) C and is to check stop conditions before taking a step. C First, DRCHEK is called to check for a root within the last step C taken, other than the last root found there, if any. C If ITASK = 2 or 5, and y(TN) has not yet been returned to the user C because of an intervening root, return through Block G. C----------------------------------------------------------------------- 200 NSLAST = NST C IRFP = IRFND IF (NGC .EQ. 0) GO TO 205 IF (ITASK .EQ. 1 .OR. ITASK .EQ. 4) TOUTC = TOUT CALL DRCHEK (2, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .NE. 1) GO TO 205 IRFND = 1 ISTATE = 3 T = T0 GO TO 425 205 CONTINUE IRFND = 0 IF (IRFP .EQ. 1 .AND. TLAST .NE. TN .AND. ITASK .EQ. 2) GO TO 400 C IF (ITASK .EQ. 1) THEN GOTO 210 ELSE IF (ITASK .EQ. 2) THEN GOTO 250 ELSE IF (ITASK .EQ. 3) THEN GOTO 220 ELSE IF (ITASK .EQ. 4) THEN GOTO 230 ELSE IF (ITASK .EQ. 5) THEN GOTO 240 ENDIF C GO TO (210, 250, 220, 230, 240), ITASK 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 T = TN GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 245 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) T = TCRIT IF (IRFP .EQ. 1 .AND. TLAST .NE. TN .AND. ITASK .EQ. 5) GO TO 400 IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (ISTATE .EQ. 2 .AND. JSTART .GE. 0) JSTART = -2 C----------------------------------------------------------------------- C Block E. C The next block is normally executed for all calls and contains C the call to the one-step core integrator DSTODA. C C This is a looping point for the integration steps. C C First check for too many steps being taken, update EWT (if not at C start of problem), check for too much accuracy being requested, and C check for H below the roundoff level in T. C----------------------------------------------------------------------- 250 CONTINUE IF (METH .EQ. MUSED) GO TO 255 IF (INSUFR .EQ. 1) GO TO 550 IF (INSUFI .EQ. 1) GO TO 555 255 IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 260 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 260 CONTINUE 270 TOLSF = UROUND*DMNORM (N, RWORK(LYH), RWORK(LEWT)) IF (TOLSF .LE. 1.0D0) GO TO 280 TOLSF = TOLSF*2.0D0 IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 MSG = 'DLSODAR- Warning..Internal T(=R1) and H(=R2) are ' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' such that in the machine, T + H = T on the next step ' CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' (H = step size). Solver will continue anyway.' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 MSG = 'DLSODAR- Above warning has been issued I1 times. ' CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' It will not be issued again for this problem.' CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 290 CONTINUE C----------------------------------------------------------------------- C CALL DSTODA(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,DPRJA,DSOLSY) C----------------------------------------------------------------------- CALL DSTODA (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), 2 F, JAC, DPRJA, DSOLSY, rpar, ipar) KGO = 1 - KFLAG IF (KGO .EQ. 1) THEN GOTO 300 ELSE IF (KGO .EQ. 2) THEN GOTO 530 ELSE IF (KGO .EQ. 3) THEN GOTO 540 ENDIF C GO TO (300, 530, 540), KGO C----------------------------------------------------------------------- C Block F. C The following block handles the case of a successful return from the C core integrator (KFLAG = 0). C If a method switch was just made, record TSW, reset MAXORD, C set JSTART to -1 to signal DSTODA to complete the switch, C and do extra printing of data if IXPR = 1. C Then call DRCHEK to check for a root within the last step. C Then, if no root was found, check for stop conditions. C----------------------------------------------------------------------- 300 INIT = 1 IF (METH .EQ. MUSED) GO TO 310 TSW = TN MAXORD = MXORDN IF (METH .EQ. 2) MAXORD = MXORDS IF (METH .EQ. 2) RWORK(LWM) = SQRT(UROUND) INSUFR = MIN(INSUFR,1) INSUFI = MIN(INSUFI,1) JSTART = -1 IF (IXPR .EQ. 0) GO TO 310 IF (METH .EQ. 2) THEN MSG='DLSODAR- A switch to the BDF (stiff) method has occurred' C KS CALL XERRWD (MSG, 60, 105, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) C CALL DBLEPR(MSG, 60, 0, 0) CALL rprintf(MSG // char(0)) ENDIF IF (METH .EQ. 1) THEN MSG='DLSODAR- A switch to the Adams (nonstiff) method occurred' C CALL XERRWD (MSG, 60, 106, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) C CALL DBLEPR(MSG, 60, 0, 0) CALL rprintf(MSG // char(0)) ENDIF MSG = 'at T (R1), the new step size is (R2): %g, %g ' call rprintfd2 (MSG // char(0), TN, H) 310 CONTINUE C IF (NGC .EQ. 0) GO TO 315 CALL DRCHEK (3, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .NE. 1) GO TO 315 IRFND = 1 ISTATE = 3 T = T0 GO TO 425 315 CONTINUE C IF (ITASK .EQ. 1) THEN GOTO 320 ELSE IF (ITASK .EQ. 2) THEN GOTO 400 ELSE IF (ITASK .EQ. 3) THEN GOTO 330 ELSE IF (ITASK .EQ. 4) THEN GOTO 340 ELSE IF (ITASK .EQ. 5) THEN GOTO 350 ENDIF C karline: changed from C GO TO (320, 400, 330, 340, 350), ITASK C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 320 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 GO TO 250 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 345 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (JSTART .GE. 0) JSTART = -2 GO TO 250 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 350 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX C----------------------------------------------------------------------- C Block G. C The following block handles all successful returns from DLSODAR. C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. C ISTATE is set to 2, and the optional outputs are loaded into the C work arrays before returning. C----------------------------------------------------------------------- 400 DO 410 I = 1,N Y(I) = RWORK(I+LYH-1) 410 CONTINUE T = TN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 IF (IHIT) T = TCRIT 420 ISTATE = 2 425 CONTINUE RWORK(11) = HU RWORK(12) = H RWORK(13) = TN RWORK(15) = TSW IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = MUSED IWORK(20) = METH IWORK(10) = NGE TLAST = T RETURN C----------------------------------------------------------------------- C Block H. C The following block handles all unsuccessful returns other than C those for illegal input. First the error message routine is called. C If there was an error test or convergence test failure, IMXER is set. C Then Y is loaded from YH and T is set to TN. C The optional outputs are loaded into the work arrays before returning. C----------------------------------------------------------------------- C The maximum number of steps was taken before reaching TOUT. ---------- 500 MSG = 'DLSODAR- At current T (=R1), MXSTEP (=I1) steps ' CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' taken on this call before reaching TOUT ' CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) ISTATE = -1 GO TO 580 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 510 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODAR- At T(=R1), EWT(I1) has become R2 .le. 0.' CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) ISTATE = -6 GO TO 580 C Too much accuracy requested for machine precision. ------------------- 520 MSG = 'DLSODAR- At T (=R1), too much accuracy requested ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' for precision of machine.. See TOLSF (=R2) ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) RWORK(14) = TOLSF ISTATE = -2 GO TO 580 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 530 MSG = 'DLSODAR- At T(=R1), step size H(=R2), the error ' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' test failed repeatedly or with ABS(H) = HMIN' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) ISTATE = -4 GO TO 560 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 540 MSG = 'DLSODAR- At T (=R1) and step size H (=R2), the ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' corrector convergence failed repeatedly ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' or with ABS(H) = HMIN ' CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) ISTATE = -5 GO TO 560 C RWORK length too small to proceed. ----------------------------------- 550 MSG = 'DLSODAR- At current T(=R1), RWORK length too small' CALL XERRWD (MSG, 50, 206, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' to proceed. The integration was otherwise successful.' CALL XERRWD (MSG, 60, 206, 0, 0, 0, 0, 1, TN, 0.0D0) ISTATE = -7 GO TO 580 C IWORK length too small to proceed. ----------------------------------- 555 MSG = 'DLSODAR- At current T(=R1), IWORK length too small' CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' to proceed. The integration was otherwise successful.' CALL XERRWD (MSG, 60, 207, 0, 0, 0, 0, 1, TN, 0.0D0) ISTATE = -7 GO TO 580 C Compute IMXER if relevant. ------------------------------------------- 560 BIG = 0.0D0 IMXER = 1 DO 570 I = 1,N SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) IF (BIG .GE. SIZE) GO TO 570 BIG = SIZE IMXER = I 570 CONTINUE IWORK(16) = IMXER C Set Y vector, T, and optional outputs. ------------------------------- 580 DO 590 I = 1,N Y(I) = RWORK(I+LYH-1) 590 CONTINUE T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN RWORK(15) = TSW IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = MUSED IWORK(20) = METH IWORK(10) = NGE TLAST = T RETURN C----------------------------------------------------------------------- C Block I. C The following block handles all error returns due to illegal input C (ISTATE = -3), as detected before calling the core integrator. C First the error message routine is called. If the illegal input C is a negative ISTATE, the run is aborted (apparent infinite loop). C----------------------------------------------------------------------- 601 MSG = 'DLSODAR- ISTATE(=I1) illegal.' CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) IF (ISTATE .LT. 0) GO TO 800 GO TO 700 602 MSG = 'DLSODAR- ITASK (=I1) illegal.' CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) GO TO 700 603 MSG = 'DLSODAR- ISTATE.gt.1 but DLSODAR not initialized.' CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) GO TO 700 604 MSG = 'DLSODAR- NEQ (=I1) .lt. 1 ' CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) GO TO 700 605 MSG = 'DLSODAR- ISTATE = 3 and NEQ increased (I1 to I2).' CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 606 MSG = 'DLSODAR- ITOL (=I1) illegal. ' CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) GO TO 700 607 MSG = 'DLSODAR- IOPT (=I1) illegal. ' CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) GO TO 700 608 MSG = 'DLSODAR- JT (=I1) illegal. ' CALL XERRWD (MSG, 30, 8, 0, 1, JT, 0, 0, 0.0D0, 0.0D0) GO TO 700 609 MSG = 'DLSODAR- ML (=I1) illegal: .lt.0 or .ge.NEQ (=I2)' CALL XERRWD (MSG, 50, 9, 0, 2, ML, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 610 MSG = 'DLSODAR- MU (=I1) illegal: .lt.0 or .ge.NEQ (=I2)' CALL XERRWD (MSG, 50, 10, 0, 2, MU, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 611 MSG = 'DLSODAR- IXPR (=I1) illegal. ' CALL XERRWD (MSG, 30, 11, 0, 1, IXPR, 0, 0, 0.0D0, 0.0D0) GO TO 700 612 MSG = 'DLSODAR- MXSTEP (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) GO TO 700 613 MSG = 'DLSODAR- MXHNIL (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) GO TO 700 614 MSG = 'DLSODAR- TOUT (=R1) behind T (=R2) ' CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) MSG = ' Integration direction is given by H0 (=R1) ' CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) GO TO 700 615 MSG = 'DLSODAR- HMAX (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) GO TO 700 616 MSG = 'DLSODAR- HMIN (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) GO TO 700 617 MSG='DLSODAR- RWORK length needed, LENRW(=I1), exceeds LRW(=I2) ' CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 618 MSG='DLSODAR- IWORK length needed, LENIW(=I1), exceeds LIW(=I2) ' CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) GO TO 700 619 MSG = 'DLSODAR- RTOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) GO TO 700 620 MSG = 'DLSODAR- ATOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) GO TO 700 621 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODAR- EWT(I1) is R1 .le. 0.0 ' CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) GO TO 700 622 MSG='DLSODAR- TOUT(=R1) too close to T(=R2) to start integration.' CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) GO TO 700 623 MSG='DLSODAR- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) GO TO 700 624 MSG='DLSODAR- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) GO TO 700 625 MSG='DLSODAR- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) GO TO 700 626 MSG = 'DLSODAR- At start of problem, too much accuracy ' CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' requested for precision of machine.. See TOLSF (=R1) ' CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) RWORK(14) = TOLSF GO TO 700 627 MSG = 'DLSODAR- Trouble in DINTDY. ITASK = I1, TOUT = R1' CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) GO TO 700 628 MSG = 'DLSODAR- MXORDN (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 28, 0, 1, MXORDN, 0, 0, 0.0D0, 0.0D0) GO TO 700 629 MSG = 'DLSODAR- MXORDS (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 29, 0, 1, MXORDS, 0, 0, 0.0D0, 0.0D0) GO TO 700 630 MSG = 'DLSODAR- NG (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 30, 0, 1, NG, 0, 0, 0.0D0, 0.0D0) GO TO 700 631 MSG = 'DLSODAR- NG changed (from I1 to I2) illegally, ' CALL XERRWD (MSG, 50, 31, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' i.e. not immediately after a root was found.' CALL XERRWD (MSG, 50, 31, 0, 2, NGC, NG, 0, 0.0D0, 0.0D0) GO TO 700 632 MSG = 'DLSODAR- One or more components of g has a root ' CALL XERRWD (MSG, 50, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' too near to the initial point. ' CALL XERRWD (MSG, 40, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) C 700 ISTATE = -3 RETURN C 800 MSG = 'DLSODAR- Run aborted.. apparent infinite loop. ' CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) RETURN C----------------------- End of Subroutine DLSODAR --------------------- END *DECK DLSODPK *DECK DLSODKR *DECK DLSODI *DECK DLSOIBT *DECK DLSODIS deSolve/src/daux.f0000644000176000001440000000145513564603725013622 0ustar ripleyusersC The code in this file is based on ODEPACK from netlib C https://www.netlib.org/odepack/ C C Adapted for use in R package deSolve by the deSolve authors. DOUBLE PRECISION FUNCTION D1MACH (IDUM) INTEGER IDUM C----------------------------------------------------------------------- C THIS ROUTINE COMPUTES THE UNIT ROUNDOFF OF THE MACHINE IN DOUBLE C PRECISION. THIS IS DEFINED AS THE SMALLEST POSITIVE MACHINE NUMBER C U SUCH THAT 1.0D0 + U .NE. 1.0D0 (IN DOUBLE PRECISION). C----------------------------------------------------------------------- DOUBLE PRECISION U, COMP U = 1.0D0 10 U = U*0.5D0 COMP = 1.0D0 + U IF (COMP .NE. 1.0D0) GO TO 10 D1MACH = U*2.0D0 RETURN C----------------------- END OF FUNCTION D1MACH ------------------------ END deSolve/src/call_daspk.c0000644000176000001440000004172213274246336014753 0ustar ripleyusers#include #include #include "deSolve.h" #include "externalptr.h" /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Differential algebraic equation solver daspk. The C-wrappers that provide the interface between FORTRAN codes and R-code are: C_res_func : interface with R-code "res", passes function residuals C_out : interface with R-code "res", passes output variables C_daejac_func: interface with R-code "jacres", passes jacobian DLL_forc_dae provides the interface between the residual function specified in a DLL and daspk, in case there are forcing functions. changes since 1.4 karline: version 1.5: added forcing functions in DLL karline: version 1.6: added events karline: version 1.7: added time lags -> delay differential equations improving names karline: version 2.0: func in compiled code (was only res) to do: implement psolfunc +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ /* globals for when mass matrix is used with func in a DLL with mass matrix */ int isMass; double * mass, *dytmp; /* define data types for function pointers */ /* generic function pointer type */ typedef void (*funcptr)(void); /* function pointers for different argument lists */ typedef void C_daejac_func_type(double *, double *, double *, double *, double *, double *, int *); typedef void C_psol_func_type(int *, double *, double *, double *, double *, double *, double *, double *, double *, int*, double *, double *, int*, double *, int*); typedef void C_kryljac_func_type(double *, int *, int *, double *, double *, double *, double *, double *, double *, double *, double *, double *, int*, int*, double *, int*); /* ----------------- Matrix-Vector Multiplication A*x=c -------------------- */ void matvecmult (int nr, int nc, double* A, double* x, double* c) { int i, j; for (i = 0; i < nr; i++) { c[i] = 0.; for (j = 0; j < nc; j++) c[i] += A[i + nr * j] * x[j]; } } /* definition of the call to the FORTRAN function ddaspk - in file ddaspk.f*/ void F77_NAME(ddaspk)(void (*)(double *, double *, double *, double*, double *, int*, double *, int*), int *, double *, double *, double *, double *, int *,double *, double *, int *, double *, int *, int *, int *, double *, int *, void(*)(void)/*(double *, double *, double *, double *, double *, double *, int *)*/, void (*)(int *, double *, double *, double *, double *, double *, double *, double *, double *, int *, double *, double *, int *, double *, int *)); /* func is in a DLL, */ static void DLL_res_ode (double *t, double *y, double *yprime, double *cj, double *delta, int *ires, double *yout, int *iout) { int i; DLL_deriv_func (&n_eq, t, y, delta, yout, iout); if (isMass) { matvecmult(n_eq, n_eq, mass, yprime, dytmp); for ( i = 0; i < n_eq; i++) delta[i] = dytmp[i] - delta[i]; } else { for ( i = 0; i < n_eq; i++) delta[i] = yprime[i] - delta[i]; } } /* res is in a DLL, with forcing functions */ static void DLL_forc_dae (double *t, double *y, double *yprime, double *cj, double *delta, int *ires, double *yout, int *iout) { updatedeforc(t); DLL_res_func(t, y, yprime, cj, delta, ires, yout, iout); } /* func is in a DLL, with forcing function */ static void DLL_forc_dae2 (double *t, double *y, double *yprime, double *cj, double *delta, int *ires, double *yout, int *iout) { updatedeforc(t); DLL_res_ode(t, y, yprime, cj, delta, ires, yout, iout); } /* not yet implemented */ static void C_psol_func (int *neq, double *t, double *y, double *yprime, double *savr, double *wk, double *cj, double* wght, double *wp, int *iwp, double *b, double *eplin, int *ierr, double *RPAR, int *IPAR) { } /* interface between FORTRAN function calls and R functions */ static void C_res_func (double *t, double *y, double *yprime, double *cj, double *delta, int *ires, double *yout, int *iout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < n_eq; i++) { REAL(Y)[i] = y[i]; REAL (YPRIME)[i] = yprime[i]; } PROTECT(Time = ScalarReal(*t)); PROTECT(R_fcall = lang4(R_res_func,Time, Y, YPRIME)); PROTECT(ans = eval(R_fcall, R_envir)); for (i = 0; i < n_eq; i++) delta[i] = REAL(ans)[i]; UNPROTECT(3); } /* deriv output function */ static void C_out (int *nout, double *t, double *y, double *yprime, double *yout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < n_eq; i++) { REAL(Y)[i] = y[i]; REAL (YPRIME)[i] = yprime[i]; } PROTECT(Time = ScalarReal(*t)); PROTECT(R_fcall = lang4(R_res_func,Time, Y, YPRIME)); PROTECT(ans = eval(R_fcall, R_envir)); for (i = 0; i < *nout; i++) yout[i] = REAL(ans)[i + n_eq]; UNPROTECT(3); } /* interface between FORTRAN call to jacobian and R function */ static void C_daejac_func (double *t, double *y, double *yprime, double *pd, double *cj, double *RPAR, int *IPAR) { int i; SEXP R_fcall, ans; REAL(Rin)[0] = *t; REAL(Rin)[1] = *cj; for (i = 0; i < n_eq; i++) { REAL(Y)[i] = y[i]; REAL (YPRIME)[i] = yprime[i]; } PROTECT(R_fcall = lang4(R_daejac_func, Rin, Y, YPRIME)); PROTECT(ans = eval(R_fcall, R_envir)); for (i = 0; i < n_eq * nrowpd; i++) pd[i] = REAL(ans)[i]; UNPROTECT(2); } /* MAIN C-FUNCTION, CALLED FROM R-code */ SEXP call_daspk(SEXP y, SEXP yprime, SEXP times, SEXP resfunc, SEXP parms, SEXP rtol, SEXP atol, SEXP rho, SEXP tcrit, SEXP jacfunc, SEXP initfunc, SEXP psolfunc, SEXP verbose, SEXP info, SEXP iWork, SEXP rWork, SEXP nOut, SEXP maxIt, SEXP bu, SEXP bd, SEXP nRowpd, SEXP Rpar, SEXP Ipar, SEXP flist, SEXP elag, SEXP eventfunc, SEXP elist, SEXP Mass) { /******************************************************************************/ /****** DECLARATION SECTION ******/ /******************************************************************************/ int j, nt, ny, repcount, latol, lrtol, lrw, liw, isDll; int maxit, isForcing, isEvent, islag, istate; double *xytmp, *xdytmp, tin, tout, *Atol, *Rtol; double *delta=NULL, cj = 0.; int *Info, ninfo, idid, mflag, ires = 0; int *iwork, it, ntot= 0, nout, funtype; double *rwork; /* pointers to functions passed to FORTRAN */ C_res_func_type *res_func = NULL; C_daejac_func_type *daejac_func = NULL; C_psol_func_type *psol_func = NULL; C_kryljac_func_type *kryljac_func = NULL; /******************************************************************************/ /****** STATEMENTS ******/ /******************************************************************************/ lock_solver(); /* prevent nested call of solvers that have global variables */ /* #### initialisation #### */ int nprot = 0; ny = LENGTH(y); n_eq = ny; /* n_eq is a global variable */ nt = LENGTH(times); mflag = INTEGER(verbose)[0]; ninfo=LENGTH(info); nrowpd = INTEGER(nRowpd)[0]; maxit = INTEGER(maxIt)[0]; /* function is a dll ?*/ if (inherits(resfunc, "NativeSymbol")) { isDll = 1; } else { isDll = 0; } initOutC(isDll, &nout, &ntot, n_eq, nOut, Rpar, Ipar); /* copies of all variables that will be changed in the FORTRAN subroutine */ Info = (int *) R_alloc(ninfo,sizeof(int)); for (j = 0; j < ninfo; j++) Info[j] = INTEGER(info)[j]; if (mflag == 1) Info[17] = 1; xytmp = (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) xytmp[j] = REAL(y)[j]; xdytmp = (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) xdytmp[j] = REAL(yprime)[j]; latol = LENGTH(atol); Atol = (double *) R_alloc((int) latol, sizeof(double)); for (j = 0; j < latol; j++) Atol[j] = REAL(atol)[j]; lrtol = LENGTH(rtol); Rtol = (double *) R_alloc((int) lrtol, sizeof(double)); for (j = 0; j < lrtol; j++) Rtol[j] = REAL(rtol)[j]; liw = LENGTH(iWork); iwork = (int *) R_alloc(liw, sizeof(int)); for (j = 0; j < liw; j++) iwork[j] = INTEGER(iWork)[j]; lrw = LENGTH(rWork); rwork = (double *) R_alloc(lrw, sizeof(double)); for (j = 0; j < lrw; j++) rwork[j] = REAL(rWork)[j]; //timesteps = (double *) R_alloc(2, sizeof(double)); for (j = 0; j < 2; j++) timesteps[j] = 0.; /**************************************************************************/ /****** Initialization of globals, Parameters and Forcings (DLLs) ******/ /**************************************************************************/ //thpe 2017-07-17: internalize this to make PROTECT/UNPROTECT more transparent //initdaeglobals(nt, ntot); PROTECT(Rin = NEW_NUMERIC(2)); nprot++; PROTECT(Y = allocVector(REALSXP,n_eq)); nprot++; PROTECT(YPRIME = allocVector(REALSXP,n_eq)); nprot++; PROTECT(YOUT = allocMatrix(REALSXP,ntot+1,nt)); nprot++; // end //initParms(initfunc, parms); if (initfunc != NA_STRING) { if (inherits(initfunc, "NativeSymbol")) { init_func_type *initializer; PROTECT(de_gparms = parms); nprot++; initializer = (init_func_type *) R_ExternalPtrAddrFn_(initfunc); initializer(Initdeparms); } } // end inline initParms isForcing = initForcings(flist); isEvent = initEvents(elist, eventfunc, 0); /* zero roots */ islag = initLags(elag, 0, 0); /* pointers to functions res_func, psol_func and daejac_func, passed to the FORTRAN subroutine */ isMass = 0; if (isDll == 1) { /* DLL address passed to FORTRAN */ funtype = Info[19]; if (funtype == 1) { /* res is in DLL */ res_func = (C_res_func_type *) R_ExternalPtrAddrFn_(resfunc); if(isForcing==1) { DLL_res_func = (C_res_func_type *) R_ExternalPtrAddrFn_(resfunc); res_func = (C_res_func_type *) DLL_forc_dae; } } else if (funtype <= 3){ /* func is in DLL, +- mass matrix */ res_func = DLL_res_ode; DLL_deriv_func = (C_deriv_func_type *) R_ExternalPtrAddrFn_(resfunc); if(isForcing==1) { res_func = (C_res_func_type *) DLL_forc_dae2; } if (funtype == 3) { /* mass matrix */ isMass = 1; mass = (double *)R_alloc(n_eq * n_eq, sizeof(double)); for (j = 0; j < n_eq * n_eq; j++) mass[j] = REAL(Mass)[j]; dytmp = (double *) R_alloc(n_eq, sizeof(double)); } } else error("DLL function type not yet implemented"); delta = (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) delta[j] = 0.; } else { /* interface function between FORTRAN and R passed to FORTRAN */ res_func = (C_res_func_type *) C_res_func; /* needed to communicate with R */ R_res_func = resfunc; } R_envir = rho; /* karline: this to allow merging compiled and R-code (e.g. events)*/ if (!isNull(jacfunc)) { if (inherits(jacfunc,"NativeSymbol")) { if (Info[11] ==0) { /*ordinary jac*/ daejac_func = (C_daejac_func_type *) R_ExternalPtrAddrFn_(jacfunc); } else { /*krylov*/ kryljac_func = (C_kryljac_func_type *) R_ExternalPtrAddrFn_(jacfunc); } } else { R_daejac_func = jacfunc; daejac_func = C_daejac_func; } } if (!isNull(psolfunc)) { if (inherits(psolfunc,"NativeSymbol")) { psol_func = (C_psol_func_type *) R_ExternalPtrAddrFn_(psolfunc); } else { R_psol_func = psolfunc; psol_func = C_psol_func; } } /* #### initial time step #### */ idid = 1; REAL(YOUT)[0] = REAL(times)[0]; for (j = 0; j < n_eq; j++) REAL(YOUT)[j+1] = REAL(y)[j]; if (islag == 1) updatehistini(REAL(times)[0], xytmp, xdytmp, rwork, iwork); if (nout>0) { tin = REAL(times)[0]; if (isDll == 1) res_func (&tin, xytmp, xdytmp, &cj, delta, &ires, out, ipar) ; else C_out(&nout,&tin,xytmp,xdytmp,out); for (j = 0; j < nout; j++) REAL(YOUT)[j + n_eq + 1] = out[j]; } /* #### main time loop #### */ for (it = 0; it < nt-1; it++) { tin = REAL(times)[it]; tout = REAL(times)[it+1]; if (isEvent) { istate = 2; updateevent(&tin, xytmp, &istate); if (istate == 1) Info[0] = 0; Info[3] = 1; rwork[0] = tout; } repcount = 0; do /* iterations in case maxsteps > 500* or in case islag */ { if (Info[11] == 0) { /* ordinary jac */ F77_CALL(ddaspk) (res_func, &ny, &tin, xytmp, xdytmp, &tout, Info, Rtol, Atol, &idid, rwork, &lrw, iwork, &liw, out, ipar, (funcptr)daejac_func, psol_func); } else { /* krylov - not yet used */ F77_CALL(ddaspk) (res_func, &ny, &tin, xytmp, xdytmp, &tout, Info, Rtol, Atol, &idid, rwork, &lrw, iwork, &liw, out, ipar, (funcptr)kryljac_func, psol_func); } /* in case timestep is asked for... */ timesteps [0] = rwork[10]; timesteps [1] = rwork[11]; if (islag == 1) updatehist(tin, xytmp, xdytmp, rwork, iwork); repcount ++; if (idid == -1) { Info[0]=1; } else if (idid == -2) { warning("Excessive precision requested. scale up `rtol' and `atol' e.g. by the factor %g\n",10.0); Info[0]=1; repcount=maxit+2; } else if (idid == -3) { warning("Error term became zero for some i: pure relative error control (ATOL(i)=0.0) for a variable which is now vanished"); repcount=maxit+2; } else if (idid == -5) { warning("jacfun routine failed with the Krylov method"); repcount = maxit+2; } else if (idid == -6) { warning("repeated error test failures on a step - singularity ?"); repcount = maxit+2; } else if (idid == -7) { warning("repeated convergence test failures on a step - inaccurate Jacobian or preconditioner?"); repcount = maxit+2; } else if (idid == -8) { warning("matrix of partial derivatives is singular with direct method-some equations redundant"); repcount = maxit+2; } else if (idid == -9) { warning("repeated convergence test failures and error test failures ?"); repcount = maxit+2; } else if (idid == -10) { warning("repeated convergence test failures on a step, because ires was -1"); repcount = maxit+2; } else if (idid == -11) { warning("unrecoverable error from inside noninear solver, ires=-2 "); repcount = maxit+2; } else if (idid == -12) { warning("failed to compute initial y and yprime vectors"); repcount = maxit+2; } else if (idid == -13) { warning("unrecoverable error inside the PSOL routine"); repcount = maxit+2; } else if (idid == -14) { warning("Krylov linear system solver failed to converge"); repcount = maxit+2; } else if (idid == -33) { warning("fatal error"); repcount = maxit+2; } } while (tin < tout && repcount < maxit); REAL(YOUT)[(it+1)*(ntot+1)] = tin; for (j = 0; j < n_eq; j++) REAL(YOUT)[(it+1)*(ntot + 1) + j + 1] = xytmp[j]; if (nout>0) { if (isDll == 1) res_func (&tin, xytmp, xdytmp, &cj, delta, &ires, out, ipar) ; else C_out(&nout,&tin,xytmp,xdytmp,out); for (j = 0; j < nout; j++) REAL(YOUT)[(it+1)*(ntot + 1) + j + n_eq + 1] = out[j]; } /* #### an error occurred #### */ if (repcount > maxit || tin < tout || idid <= 0) { idid = 0; PROTECT(YOUT2 = allocMatrix(REALSXP,ntot+1,(it+2))); nprot++; returnearly(1, it, ntot); break; } } /* end main time loop */ /* #### returning output #### */ PROTECT(ISTATE = allocVector(INTSXP, 23)); nprot++; PROTECT(RWORK = allocVector(REALSXP, 3)); nprot++; terminate(idid, iwork, 23, 0, rwork, 3, 1); REAL(RWORK)[0] = rwork[6]; unlock_solver(); UNPROTECT(nprot); if (idid > 0) return(YOUT); else return(YOUT2); } deSolve/src/dintdy2.f0000644000176000001440000000411013564603744014226 0ustar ripleyusersC The code in this file is based of function DINTDY from file C opdka1.f from https://www.netlib.org/odepack/ C C Original Author: Hindmarsh, Alan C., (LLNL) C Adapted for use in R package deSolve by the deSolve authors. SUBROUTINE INTERPOLY(T, K, I, YH, NYH, DKY, nq, tn, h) C***PURPOSE Interpolate solution derivatives to be used in C-code. C computes interpolated values of the K-th derivative of the i-th C dependent variable vector y, and stores it in DKY. This routine C is called within the package with K = 0 and T = TOUT, but may C also be called by the user for any K up to the current order. C (See detailed instructions in the usage documentation.) C C The computed values in DKY are gotten by interpolation using the C Nordsieck history array YH. This array corresponds uniquely to a C vector-valued polynomial of degree NQCUR or less, and DKY is set C to the K-th derivative of this polynomial at T. C The formula for DKY is: C q C DKY(i) = sum c(j,K) * (T - tn)**(j-K) * h**(-j) * YH(i,j+1) C j=K C where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, tn = TCUR, h = HCUR. C The above sum is done in reverse order. C IFLAG is returned negative if either K or T is out of bounds. C C***BASED ON DINTDY IMPLICIT NONE INTEGER K, NYH, NQ, I, IC, J, JB, JB2, JJ, JJ1, JP1 DOUBLE PRECISION T, DKY, H, C, R, S, Tn DOUBLE PRECISION YH(NYH,*) C C***FIRST EXECUTABLE STATEMENT S = (T - TN)/H IC = 1 IF (K .EQ. 0) GO TO 15 JJ1 = nq+1 - K DO 10 JJ = JJ1,NQ IC = IC*JJ 10 CONTINUE 15 C = IC DKY = C*YH(I,nq+1) IF (K .EQ. NQ) GO TO 55 JB2 = NQ - K DO 50 JB = 1,JB2 J = NQ - JB JP1 = J + 1 IC = 1 IF (K .EQ. 0) GO TO 35 JJ1 = JP1 - K DO 30 JJ = JJ1,J IC = IC*JJ 30 CONTINUE 35 C = IC DKY = C*YH(I,JP1) + S*DKY 50 CONTINUE IF (K .EQ. 0) RETURN 55 R = H**(-K) DKY = R*DKY RETURN C----------------------- END OF SUBROUTINE InterpolY ---------------------- END deSolve/src/rk_implicit.c0000644000176000001440000002047013274246234015156 0ustar ripleyusers/*==========================================================================*/ /* Implicit RK Solver with fixed step size */ /*==========================================================================*/ #include "rk_util.h" void F77_NAME(dgefa)(double*, int*, int*, int*, int*); void F77_NAME(dgesl)(double*, int*, int*, int*, double*, int*); /* void lu_solve(double, int, int, double); void kfunc(int, int, double, double, double, double, double, double, double, SEXP, SEXP, SEXP, double, double, double, int, int, int); void dkfunc(int, int, double, double, double, double, double, double, double, SEXP, SEXP, SEXP, double, double, double, double, int, int, int, double); */ /* lower upper decomposition - no error checking */ void lu_solve(double *alfa, int n, int *index, double *bet) { int info; F77_CALL(dgefa)(alfa, &n, &n, index, &info); if (info != 0) error("error during factorisation of matrix (dgefa), singular matrix"); F77_CALL(dgesl)(alfa, &n, &n, index, bet, &info); if (info != 0) error("error during backsubstitution"); } /* function that returns -k + dt*derivs(t+c[i]*dt, y+sum(a[i,)*k this is the function whose roots should be found in the implicit method */ void kfunc(int stage, int neq, double t, double dt, double *FF, double *Fj, double *A, double *cc, double *y0 , SEXP Func, SEXP Parms, SEXP Rho, double *tmp, double *tmp2, double *out, int *ipar, int isDll, int isForcing){ int i, j, k; /****** Prepare Coefficients from Butcher table ******/ for (j = 0; j < stage; j++) { for (i = 0; i < neq; i++) Fj[i] = 0.; for (k =0; k < stage; k++) { /* implicit part */ for(i = 0; i < neq; i++) Fj[i] = Fj[i] + A[j + stage * k] * FF[i + neq * k] * dt; } for (int i = 0; i < neq; i++) { tmp[i] = Fj[i] + y0[i]; } /****** Compute Derivatives ******/ /* pass option to avoid unnecessary copying in derivs note:tmp2 rather than FF */ derivs(Func, t + dt * cc[j], tmp, Parms, Rho, tmp2, out, j, neq, ipar, isDll, isForcing); } for (i = 0; i< neq*stage;i++) tmp[i] = FF[i] - tmp2[i]; /* tmp should be = 0 at root */ } /* function that returns the Jacobian of kfunc; df[i,j] should contain: dkfunc_i/dFFj CHECK */ void dkfunc(int stage, int neq, double t, double dt, double *FF, double *Fj, double *A, double *cc, double *y0, SEXP Func, SEXP Parms, SEXP Rho, double *tmp, double *tmp2, double *tmp3, double *out, int *ipar, int isDll, int isForcing, double *df){ int i, j, nroot; double d1, d2; nroot = neq*stage; /* function reference value in tmp2 */ kfunc(stage, neq, t, dt, FF, Fj, A, cc, y0, Func, Parms, Rho, tmp2, tmp3, out, ipar, isDll, isForcing); for (i = 0; i < nroot; i++) { d1 = FF[i]; /* copy */ d2 = fmax(1e-8, FF[i] * 1e-8); /* perturb */ FF[i] = FF[i] + d2; kfunc(stage, neq, t, dt, FF, Fj, A, cc, y0, Func, Parms, Rho, tmp, tmp3, out, ipar, isDll, isForcing); for (j = 0; j < nroot; j++) df[nroot * i + j] = (tmp[j] - tmp2[j])/d2; //df[j,i] j,i=1:nroot FF[i] = d1; /* restore */ } } /* ks: check if tmp3 necessary ... */ void rk_implicit( double * alfa, /* neq*stage * neq*stage */ int *index, /* neq*stage */ /* integers */ int fsal, int neq, int stage, int isDll, int isForcing, int verbose, int nknots, int interpolate, int maxsteps, int nt, /* int pointers */ int* _iknots, int* _it, int* _it_ext, int* _it_tot, int* istate, int* ipar, /* double */ double t, double tmax, double hini, /* double pointers */ double* _dt, /* arrays */ double* tt, double* y0, double* y1, double* dy1, double* f, double* y, double* Fj, double* tmp, double* tmp2, double* tmp3, double* FF, double* rr, double* A, double* out, double* bb1, double* cc, double* yknots, double* yout, /* SEXPs */ SEXP Func, SEXP Parms, SEXP Rho ) { int i = 0, one = 1; int iknots = *_iknots, it = *_it, it_ext = *_it_ext, it_tot = *_it_tot; double t_ext; double dt = *_dt; int iter, maxit = 100; double errf, errx; int nroot = neq * stage; /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ do { /* select time step (possibly irregular) */ if (hini > 0.0) dt = fmin(hini, tmax - t); /* adjust dt for step-by-step-mode */ else dt = tt[it] - tt[it-1]; timesteps[0] = timesteps[1]; timesteps[1] = dt; /* Newton-Raphson steps */ for (iter = 0; iter < maxit; iter++) { /* function value and Jacobian*/ kfunc(stage, neq, t, dt, FF, Fj, A, cc, y0, Func, Parms, Rho, tmp, tmp2, out, ipar, isDll, isForcing); it_tot++; /* count total number of time steps */ errf = 0.; for ( i = 0; i < nroot; i++) errf = errf + fabs(tmp[i]); if (errf < 1e-8) break; dkfunc(stage, neq, t, dt, FF, Fj, A, cc, y0, Func, Parms, Rho, tmp, tmp2, tmp3, out, ipar, isDll, isForcing, alfa); it_tot = it_tot + nroot + 1; lu_solve (alfa, nroot, index, tmp); errx = 0; for (i = 0; i < nroot; i++) { errx = errx + fabs(tmp[i]); FF[i] = FF[i] - tmp[i]; } // Rprintf("iter %i errf %g errx %g\n",iter, errf, errx); if (errx < 1e-8) break; } /*====================================================================*/ /* Estimation of new values */ /*====================================================================*/ /* use BLAS with reduced error checking */ blas_matprod1(FF, neq, stage, bb1, stage, one, dy1); for (i = 0; i < neq; i++) { y1[i] = y0[i] + dt * dy1[i]; } /*====================================================================*/ /* Interpolation and Data Storage */ /*====================================================================*/ if (interpolate) { /*------------------------------------------------------------------*/ /* Neville-Aitken-Interpolation */ /* the fixed step integrators have no dense output */ /*------------------------------------------------------------------*/ /* (1) collect number "nknots" of knots in advanve */ yknots[iknots] = t + dt; /* time in first column */ for (i = 0; i < neq; i++) yknots[iknots + nknots * (1 + i)] = y1[i]; if (iknots < (nknots - 1)) { iknots++; } else { /* (2) do polynomial interpolation */ t_ext = tt[it_ext]; while (t_ext <= t + dt) { neville(yknots, &yknots[nknots], t_ext, tmp, nknots, neq); /* (3) store outputs */ if (it_ext < nt) { yout[it_ext] = t_ext; for (i = 0; i < neq; i++) yout[it_ext + nt * (1 + i)] = tmp[i]; } if(it_ext < nt-1) t_ext = tt[++it_ext]; else break; } shiftBuffer(yknots, nknots, neq + 1); } } else { /*--------------------------------------------------------------------*/ /* No interpolation mode for step to step integration */ /* results are stored after the call */ /*--------------------------------------------------------------------*/ } /*--------------------------------------------------------------------*/ /* next time step */ /*--------------------------------------------------------------------*/ t = t + dt; it++; for (i = 0; i < neq; i++) y0[i] = y1[i]; if (it_ext > nt) { Rprintf("error in RK solver rk_implicit.c: output buffer overflow\n"); break; } if (it_tot > maxsteps) { istate[0] = -1; warning("Number of time steps %i exceeded maxsteps at t = %g\n", it, t); break; } /* tolerance to avoid rounding errors */ } while (t < (tmax - 100.0 * DBL_EPSILON * dt)); /* end of rk main loop */ /* return reference values */ *_iknots = iknots; *_it = it; *_it_ext = it_ext; *_it_tot = it_tot; } deSolve/src/call_lsoda.c0000644000176000001440000006134213507052710014741 0ustar ripleyusers#include #include #include "deSolve.h" #include "externalptr.h" /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Ordinary differential equation solvers lsoda, lsode, lsodes, lsodar, and vode. The C-wrappers that provide the interface between FORTRAN codes and R-code are: C_deriv_func: interface with R-code "func", passes derivatives C_deriv_out : interface with R-code "func", passes derivatives + output variables C_jac_func : interface with R-code "jacfunc", passes jacobian (except lsodes) C_jac_vec : interface with R-code "jacvec", passes jacobian (only lsodes) C_deriv_func_forc provides the interface between the function specified in a DLL and the integrator, in case there are forcing functions. Two integrators can locate the root of a function: lsodar and lsode (the latter by merging part of the FORTRAN codes lsodar and lsode, by KS). C_root_func provides the interface between the R root function and the FORTRAN code. changes since 1.4 karline: version 1.5: added forcing functions in DLL karline: version 1.6: added events karline: version 1.7: 1. added root finding in lsode -> lsoder (fortran code) 2. added time lags -> delay differential equations 3. output variables now in C-code -> lsodeSr (fortran code) improving names karline: version 1.9.1: root finding in lsodes version 1.10.4: 2D with mapping - still in testing phase, undocumented karline: version 1.13-1: combining compiled code function with R code event karline/thomas: version 1.24: union approach for overlay types +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ /* definition of the calls to the FORTRAN functions - in file opkdmain.f and in file dvode.f**/ void F77_NAME(dlsoda)(void (*)(int *, double *, double *, double *, double *, int *), int *, double *, double *, double *, int *, double *, double *, int *, int *, int *, double *,int *,int *, int *, void (*)(int *, double *, double *, int *, int *, double *, int *, double *, int *), int *, double *, int *); void F77_NAME(dlsode)(void (*)(int *, double *, double *, double *, double *, int *), int *, double *, double *, double *, int *, double *, double *, int *, int *, int *, double *,int *,int *, int *, void (*)(int *, double *, double *, int *, int *, double *, int *, double *, int *), int *, double *, int *); void F77_NAME(dlsoder)(void (*)(int *, double *, double *, double *, double *, int *), int *, double *, double *, double *, int *, double *, double *, int *, int *, int *, double *,int *,int *, int *, void (*)(int *, double *, double *, int *, int *, double *, int *, double *, int *), int *, void (*)(int *, double *, double *, int *, double *), /* rootfunc */ int *, int *, double *, int *); void F77_NAME(dlsodes)(void (*)(int *, double *, double *, double *, double *, int *), int *, double *, double *, double *, int *, double *, double *, int *, int *, int *, double *, int *, int *, int *, int *, /* extra 'double'; is integer in fortran, thpe: now u_work.iwk */ void (*)(int *, double *, double *, int *, int *, int *, double *, double *, int *), /* jacvec */ int *, double *, int *); void F77_NAME(dlsodesr)(void (*)(int *, double *, double *, double *, double *, int *), int *, double *, double *, double *, int *, double *, double *, int *, int *, int *, double *, int *, int *, int *, int *, /* extra 'double'; is integer in fortran, thpe now u_work.iwk */ void (*)(int *, double *, double *, int *, int *, int *, double *, double *, int *), /* jacvec */ int *, void (*)(int *, double *, double *, int *, double *), /* rootfunc */ int *, int *, double *, int *); void F77_NAME(dlsodar)(void (*)(int *, double *, double *, double *, double *, int *), int *, double *, double *, double *, int *, double *, double *, int *, int *, int *, double *,int *,int *, int *, void (*)(int *, double *, double *, int *, int *, double *, int *, double *, int *), int *, void (*)(int *, double *, double *, int *, double *), /* rootfunc */ int *, int *, double *, int *); void F77_NAME(dvode)(void (*)(int *, double *, double *, double *, double *, int *), int *, double *, double *, double *, int *, double *, double *, int *, int *, int *, double *,int *,int *, int *, void (*)(int *, double *, double *, int *, int *, double *, int *, double*, int*), int *, double *, int *); /* wrapper above the derivate function that first estimates the values of the forcing functions */ static void C_deriv_func_forc (int *neq, double *t, double *y, double *ydot, double *yout, int *iout) { updatedeforc(t); DLL_deriv_func(neq, t, y, ydot, yout, iout); } /* interface between FORTRAN function call and R function Fortran code calls C_deriv_func(N, t, y, ydot, yout, iout) R code called as R_deriv_func(time, y) and returns ydot Note: passing of parameter values and "..." is done in R-function lsodx*/ static void C_deriv_func (int *neq, double *t, double *y, double *ydot, double *yout, int *iout) { int i; SEXP R_fcall, ans, Time; for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); PROTECT(R_fcall = lang3(R_deriv_func,Time,Y)); PROTECT(ans = eval(R_fcall, R_envir)); for (i = 0; i < *neq; i++) ydot[i] = REAL(ans)[i]; UNPROTECT(3); } /* deriv output function */ static void C_deriv_out (int *nOut, double *t, double *y, double *ydot, double *yout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < n_eq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); PROTECT(R_fcall = lang3(R_deriv_func,Time, Y)); PROTECT(ans = eval(R_fcall, R_envir)); for (i = 0; i < n_eq; i++) ydot[i] = REAL (ans)[i] ; for (i = 0; i < *nOut; i++) yout[i] = REAL(ans)[i + n_eq]; UNPROTECT(3); } /* only if lsodar, lsoder, lsodesr: interface between FORTRAN call to root and corresponding R function */ static void C_root_func (int *neq, double *t, double *y, int *ng, double *gout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); PROTECT(R_fcall = lang3(R_root_func,Time,Y)); PROTECT(ans = eval(R_fcall, R_envir)); for (i = 0; i < *ng; i++) gout[i] = REAL(ans)[i]; UNPROTECT(3); } /* interface between FORTRAN call to jacobian and R function */ static void C_jac_func (int *neq, double *t, double *y, int *ml, int *mu, double *pd, int *nrowpd, double *yout, int *iout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); PROTECT(R_fcall = lang3(R_jac_func,Time,Y)); PROTECT(ans = eval(R_fcall, R_envir)); for (i = 0; i < *neq * *nrowpd; i++) pd[i] = REAL(ans)[i]; UNPROTECT(3); } /* only if lsodes: interface between FORTRAN call to jacvec and corresponding R function */ static void C_jac_vec (int *neq, double *t, double *y, int *j, int *ian, int *jan, double *pdj, double *yout, int *iout) { int i; SEXP R_fcall, ans, Time, J; PROTECT(J = NEW_INTEGER(1)); INTEGER(J)[0] = *j; for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); PROTECT(R_fcall = lang4(R_jac_vec,Time,Y,J)); PROTECT(ans = eval(R_fcall, R_envir)); for (i = 0; i < *neq ; i++) pdj[i] = REAL(ans)[i]; UNPROTECT(4); } /* give name to data types */ typedef void C_root_func_type (int *, double *, double *,int *, double *); typedef void C_jac_func_type (int *, double *, double *, int *, int *, double *, int *, double *, int *); typedef void C_jac_vec_type (int *, double *, double *, int *, int *, int *, double *, double *, int *); /* MAIN C-FUNCTION, CALLED FROM R-code */ SEXP call_lsoda(SEXP y, SEXP times, SEXP derivfunc, SEXP parms, SEXP rtol, SEXP atol, SEXP rho, SEXP tcrit, SEXP jacfunc, SEXP initfunc, SEXP eventfunc, SEXP verbose, SEXP iTask, SEXP rWork, SEXP iWork, SEXP jT, SEXP nOut, SEXP lRw, SEXP lIw, SEXP Solver, SEXP rootfunc, SEXP nRoot, SEXP Rpar, SEXP Ipar, SEXP Type, SEXP flist, SEXP elist, SEXP elag) { /******************************************************************************/ /****** DECLARATION SECTION ******/ /******************************************************************************/ int i, j, k, nt, repcount, latol, lrtol, lrw, liw; int maxit, solver, isForcing, isEvent, islag; double *xytmp, tin, tout, *Atol, *Rtol, *dy=NULL, ss, pt; int itol, itask, istate, iopt, jt, mflag, is, iterm; int nroot, *jroot=NULL, isDll, type; int *iwork, it, ntot, nout, iroot, *evals =NULL; double *rwork; SEXP TROOT, NROOT, VROOT; /* IROOT is in deSolve.h*/ /* pointers to functions passed to FORTRAN */ C_deriv_func_type *deriv_func; C_jac_func_type *jac_func=NULL; C_jac_vec_type *jac_vec=NULL; C_root_func_type *root_func=NULL; /* memory overlay, KS, TP 2019-07-03 */ union t_work { double * rwk; int * iwk; } u_work; /******************************************************************************/ /****** STATEMENTS ******/ /******************************************************************************/ lock_solver(); /* prevent nested call of solvers that have global variables */ /* #### initialisation #### */ int nprot = 0; jt = INTEGER(jT)[0]; /* method flag */ n_eq = LENGTH(y); /* number of equations */ nt = LENGTH(times); maxit = 10; /* number of iterations */ mflag = INTEGER(verbose)[0]; nroot = INTEGER(nRoot)[0]; /* number of roots (lsodar, lsode, lsodes) */ solver = INTEGER(Solver)[0]; /* 1=lsoda,2=lsode,3=lsodeS,4=lsodar,5=vode, 6=lsoder, 7 = lsodeSr */ /* is function a dll ?*/ if (inherits(derivfunc, "NativeSymbol")) { isDll = 1; } else { isDll = 0; } /* initialise output ... */ initOutC(isDll, &nout, &ntot, n_eq, nOut, Rpar, Ipar); /* copies of variables that will be changed in the FORTRAN subroutine */ xytmp = (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) xytmp[j] = REAL(y)[j]; latol = LENGTH(atol); Atol = (double *) R_alloc((int) latol, sizeof(double)); lrtol = LENGTH(rtol); Rtol = (double *) R_alloc((int) lrtol, sizeof(double)); liw = INTEGER (lIw)[0]; iwork = (int *) R_alloc(liw, sizeof(int)); for (j=0; j 0 || islag == 1) { dy = (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) dy[j] = 0.; } R_envir = rho; if (isDll) { /* DLL address passed to FORTRAN */ deriv_func = (C_deriv_func_type *) R_ExternalPtrAddrFn_(derivfunc); /* no need to communicate with R - but output variables set here */ /* here overruling deriv_func if forcing */ if (isForcing) { DLL_deriv_func = deriv_func; deriv_func = (C_deriv_func_type *) C_deriv_func_forc; } } else { /* interface function between FORTRAN and C/R passed to FORTRAN */ deriv_func = (C_deriv_func_type *) C_deriv_func; /* needed to communicate with R */ R_deriv_func = derivfunc; } R_envir = rho; /* karline: this to allow merging compiled and R-code (e.g. events)*/ if (!isNull(jacfunc) && solver != 3 && solver != 7) { /* lsodes uses jac_vec */ if (isDll) jac_func = (C_jac_func_type *) R_ExternalPtrAddrFn_(jacfunc); else { R_jac_func = jacfunc; jac_func = C_jac_func; } } else if (!isNull(jacfunc) && (solver == 3 || solver == 7)) { /*lsodes*/ if (isDll) jac_vec = (C_jac_vec_type *) R_ExternalPtrAddrFn_(jacfunc); else { R_jac_vec = jacfunc; jac_vec = C_jac_vec; } } if ((solver == 4 || solver == 6 || solver == 7) && nroot > 0) /* lsodar, lsoder, lsodeSr */ { jroot = (int *) R_alloc(nroot, sizeof(int)); for (j=0; j 1 && lrtol == 1 ) itol = 2; if (latol == 1 && lrtol > 1 ) itol = 3; if (latol > 1 && lrtol > 1 ) itol = 4; for (j = 0; j < lrtol; j++) Rtol[j] = REAL(rtol)[j]; for (j = 0; j < latol; j++) Atol[j] = REAL(atol)[j]; itask = INTEGER(iTask)[0]; if (isEvent) itask = 4; if (islag) itask = 5; /* one step and return */ if (isEvent && islag) itask = 5; istate = 1; iopt = 0; ss = 0.; is = 0 ; for (i = 5; i < 8 ; i++) ss = ss+rwork[i]; for (i = 5; i < 10; i++) is = is+iwork[i]; if (ss >0 || is > 0) iopt = 1; /* non-standard input */ /* #### initial time step #### */ tin = REAL(times)[0]; REAL(YOUT)[0] = tin; for (j = 0; j < n_eq; j++) REAL(YOUT)[j+1] = REAL(y)[j]; if (islag == 1) { if (isDll == 1) /* function in DLL and output */ // + thpe deriv_func (&n_eq, &tin, xytmp, dy, out, ipar); // + thpe else // + thpe C_deriv_func (&n_eq, &tin, xytmp, dy, out, ipar); updatehistini(tin, xytmp, dy, rwork, iwork); } if (nout>0) { tin = REAL(times)[0]; if (isDll == 1) /* function in DLL and output */ deriv_func (&n_eq, &tin, xytmp, dy, out, ipar) ; else C_deriv_out(&nout,&tin,xytmp,dy,out); for (j = 0; j < nout; j++) REAL(YOUT)[j + n_eq + 1] = out[j]; } iroot = 0; /* #### main time loop #### */ for (it = 0; it < nt-1; it++) { tin = REAL(times)[it]; tout = REAL(times)[it+1]; if (isEvent) { updateevent(&tin, xytmp, &istate); // check tEvent > tout to account for root events if ((iEvent < nEvent)&&(tEvent > tout)) { rwork[0] = tEvent; } else { rwork[0] = REAL(times)[nt-1]; } } repcount = 0; do { if (islag) rwork[0] = tout; /* error control */ if (istate == -2) { for (j = 0; j < lrtol; j++) Rtol[j] *= 10.0; for (j = 0; j < latol; j++) Atol[j] *= 10.0; warning("Excessive precision requested. `rtol' and `atol' have been scaled upwards by the factor %g\n",10.0); istate = 3; } if (solver == 1) { F77_CALL(dlsoda) (deriv_func, &n_eq, xytmp, &tin, &tout, &itol, Rtol, Atol, &itask, &istate, &iopt, rwork, &lrw, iwork, &liw, jac_func, &jt, out, ipar); } else if (solver == 2) { F77_CALL(dlsode) (deriv_func, &n_eq, xytmp, &tin, &tout, &itol, Rtol, Atol, &itask, &istate, &iopt, rwork, &lrw, iwork, &liw, jac_func, &jt, out, ipar); } else if (solver == 3) { F77_CALL(dlsodes) (deriv_func, &n_eq, xytmp, &tin, &tout, &itol, Rtol, Atol, &itask, &istate, &iopt, u_work.rwk, &lrw, iwork, &liw, u_work.iwk, jac_vec, &jt, out, ipar); /*rwork: iwk in fortran*/ } else if (solver == 4) { F77_CALL(dlsodar) (deriv_func, &n_eq, xytmp, &tin, &tout, &itol, Rtol, Atol, &itask, &istate, &iopt, rwork, &lrw, iwork, &liw, jac_func, &jt, root_func, &nroot, jroot, out, ipar); } else if (solver == 5) { F77_CALL(dvode) (deriv_func, &n_eq, xytmp, &tin, &tout, &itol, Rtol, Atol, &itask, &istate, &iopt, rwork, &lrw, iwork, &liw, jac_func, &jt, out, ipar); } else if (solver == 6) { F77_CALL(dlsoder) (deriv_func, &n_eq, xytmp, &tin, &tout, &itol, Rtol, Atol, &itask, &istate, &iopt, rwork, &lrw, iwork, &liw, jac_func, &jt, root_func, &nroot, jroot, out, ipar); } else if (solver == 7) { F77_CALL(dlsodesr) (deriv_func, &n_eq, xytmp, &tin, &tout, &itol, Rtol, Atol, &itask, &istate, &iopt, u_work.rwk, &lrw, iwork, &liw, u_work.iwk, jac_vec, &jt, root_func, &nroot, jroot, /*rwork: iwk in fortran*/ out, ipar); lyh = iwork[21]; } /* in case size of timesteps is called for */ timesteps [0] = rwork[10]; timesteps [1] = rwork[11]; if (istate == -1) { warning("an excessive amount of work (> maxsteps ) was done, but integration was not successful - increase maxsteps"); } else if (istate == 3 && (solver == 4 || solver == 6 || solver == 7)){ /* root found - take into account if an EVENT */ if (isEvent && rootevent) { pt = tEvent; tEvent = tin; /* function evaluations set to 0 again . */ for (j=0; j<3; j++) evals[j] = evals[j] + iwork[10+j]; if (iroot < Rootsave) { troot[iroot] = tin; for (j = 0; j < nroot; j++) if (jroot[j] == 1) nrroot[iroot] = j+1; for (j = 0; j < n_eq; j++) valroot[iroot*n_eq+j] = xytmp[j]; } iroot ++; iterm = 0; /* check if simulation should be terminated */ for (j = 0; j < nroot; j++) if (jroot[j] == 1 && termroot[j] == 1) iterm = 1; if (iterm == 0) { updateevent(&tin, xytmp, &istate); tEvent = pt; istate = 1; repcount = 0; if (mflag ==1) Rprintf("root found at time %g\n",tin); } else { istate = - 30; repcount = 50; if (mflag ==1) Rprintf("TERMINAL root found at time %g\n",tin); } } else { istate = -20; repcount = 50; } } else if (istate == -2) { warning("Excessive precision requested. scale up `rtol' and `atol' e.g by the factor %g\n",10.0); } else if (istate == -4) { warning("repeated error test failures on a step, but integration was successful - singularity ?"); } else if (istate == -5) { warning("repeated convergence test failures on a step, but integration was successful - inaccurate Jacobian matrix?"); } else if (istate == -6) { warning("Error term became zero for some i: pure relative error control (ATOL(i)=0.0) for a variable which is now vanished"); } if (islag == 1) { if (isDll == 1) /* function in DLL and output */ // + thpe deriv_func (&n_eq, &tin, xytmp, dy, out, ipar); // + thpe else // + thpe C_deriv_func (&n_eq, &tin, xytmp, dy, out, ipar); updatehist(tin, xytmp, dy, rwork, iwork); repcount = 0; } repcount ++; } while (tin < tout && istate >= 0 && repcount < maxit); if (istate == -3) { error("illegal input detected before taking any integration steps - see written message"); } else { REAL(YOUT)[(it+1)*(ntot+1)] = tin; for (j = 0; j < n_eq; j++) REAL(YOUT)[(it+1)*(ntot + 1) + j + 1] = xytmp[j]; if (nout>0) { if (isDll == 1) /* function in DLL and output */ deriv_func (&n_eq, &tin, xytmp, dy, out, ipar) ; else C_deriv_out(&nout,&tin,xytmp,dy,out); for (j = 0; j < nout; j++) REAL(YOUT)[(it+1)*(ntot + 1) + j + n_eq + 1] = out[j]; } } /* #### an error occurred #### */ if (istate < 0 || tin < tout) { PROTECT(YOUT2 = allocMatrix(REALSXP,ntot+1,(it+2))); nprot++; if (istate > -20) returnearly (1, it, ntot); else returnearly (0, it, ntot); /* stop because a root was found */ break; } } /* end main time loop */ /* #### returning output #### */ if (isEvent && rootevent && iroot > 0) for (j=0; j<3; j++) iwork[10+j] = evals[j]; PROTECT(ISTATE = allocVector(INTSXP, 21)); nprot++; PROTECT(RWORK = allocVector(REALSXP, 5)); nprot++; terminate(istate, iwork, 21, 0, rwork, 5, 10); /* istate, iwork, rwork */ if (istate <= -20) INTEGER(ISTATE)[0] = 3; if (istate == -20 && nroot > 0) { PROTECT(IROOT = allocVector(INTSXP, nroot)); nprot++; for (k = 0;k 0) { /* root + events */ PROTECT(NROOT = allocVector(INTSXP, 1)); nprot++; INTEGER(NROOT)[0] = iroot; if (iroot > Rootsave) iroot = Rootsave; PROTECT(TROOT = allocVector(REALSXP, iroot)); nprot++; for (k = 0; k < iroot; k++) REAL(TROOT)[k] = troot[k]; PROTECT(VROOT = allocVector(REALSXP, iroot*n_eq)); nprot++; for (k = 0; k < iroot*n_eq; k++) REAL(VROOT)[k] = valroot[k]; PROTECT(IROOT = allocVector(INTSXP, iroot)); nprot++; for (k = 0; k < iroot; k++) INTEGER(IROOT)[k] = nrroot[k]; if (istate > 0 ) { setAttrib(YOUT, install("troot"), TROOT); setAttrib(YOUT, install("nroot"), NROOT); setAttrib(YOUT, install("valroot"), VROOT); setAttrib(YOUT, install("indroot"), IROOT); } else { setAttrib(YOUT2, install("troot"), TROOT); setAttrib(YOUT2, install("nroot"), NROOT); setAttrib(YOUT2, install("valroot"), VROOT); setAttrib(YOUT2, install("indroot"), IROOT); } } /* #### termination #### */ unlock_solver(); UNPROTECT(nprot); if (istate > 0) return(YOUT); else return(YOUT2); } deSolve/src/call_rk4.c0000644000176000001440000001700613274246361014345 0ustar ripleyusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >=2 */ /* rk4 Fixed Step Integrator */ /* (special version with less overhead than the general solution) */ /*==========================================================================*/ #include "rk_util.h" #include "externalptr.h" SEXP call_rk4(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc, SEXP Parms, SEXP Nout, SEXP Rho, SEXP Verbose, SEXP Rpar, SEXP Ipar, SEXP Flist) { /* Initialization */ int nprot = 0; double *tt = NULL, *xs = NULL; double *tmp, *FF, *out; SEXP R_y, R_f, R_f1, R_f2, R_f3, R_f4; double *y, *f, *f1, *f2, *f3, *f4; SEXP R_y0, R_yout; double *y0, *yout; double t, dt; int i = 0, j=0, it=0, nt = 0, neq=0; int isForcing; /*------------------------------------------------------------------------*/ /* Processing of Arguments */ /*------------------------------------------------------------------------*/ PROTECT(Times = AS_NUMERIC(Times)); nprot++; tt = NUMERIC_POINTER(Times); nt = length(Times); PROTECT(Xstart = AS_NUMERIC(Xstart)); nprot++; xs = NUMERIC_POINTER(Xstart); neq = length(Xstart); tmp = (double *) R_alloc(neq, sizeof(double)); FF = (double *) R_alloc(neq, sizeof(double)); int nout = INTEGER(Nout)[0]; /* n of global outputs if func is in a DLL */ int verbose = INTEGER(Verbose)[0]; /*------------------------------------------------------------------------*/ /* timesteps (for advection computation in ReacTran) */ /*------------------------------------------------------------------------*/ for (i = 0; i < 2; i++) timesteps[i] = 0; /*------------------------------------------------------------------------*/ /* DLL, ipar, rpar (for compatibility with lsoda) */ /*------------------------------------------------------------------------*/ int isDll = FALSE; int lrpar= 0, lipar = 0; int *ipar = NULL; if (inherits(Func, "NativeSymbol")) { /* function is a dll */ isDll = TRUE; if (nout > 0) isOut = TRUE; lrpar = nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ isDll = FALSE; isOut = FALSE; lipar = 3; /* in lsoda = 1; */ lrpar = nout; /* in lsoda = 1; */ } out = (double *) R_alloc(lrpar, sizeof(double)); ipar = (int *) R_alloc(lipar, sizeof(int)); ipar[0] = nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; if (isDll == 1) { /* other elements of ipar are set in R-function lsodx via argument *ipar* */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* out: first nout elements of out are reserved for output variables other elements are set via argument *rpar* */ for (j = 0; j < nout; j++) out[j] = 0.0; for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j]; } /*------------------------------------------------------------------------*/ /* Allocation of Workspace */ /*------------------------------------------------------------------------*/ PROTECT(R_y0 = allocVector(REALSXP, neq)); nprot++; PROTECT(R_f = allocVector(REALSXP, neq)); nprot++; PROTECT(R_y = allocVector(REALSXP, neq)); nprot++; PROTECT(R_f1 = allocVector(REALSXP, neq)); nprot++; PROTECT(R_f2 = allocVector(REALSXP, neq)); nprot++; PROTECT(R_f3 = allocVector(REALSXP, neq)); nprot++; PROTECT(R_f4 = allocVector(REALSXP, neq)); nprot++; y0 = REAL(R_y0); f = REAL(R_f); y = REAL(R_y); f1 = REAL(R_f1); f2 = REAL(R_f2); f3 = REAL(R_f3); f4 = REAL(R_f4); /* matrix for holding the outputs */ PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); nprot++; yout = REAL(R_yout); /* attribute that stores state information, similar to lsoda */ SEXP R_istate; int *istate; PROTECT(R_istate = allocVector(INTSXP, 22)); nprot++; istate = INTEGER(R_istate); istate[0] = 0; /* assume succesful return */ for (i = 0; i < 22; i++) istate[i] = 0; /*------------------------------------------------------------------------*/ /* Initialization of Parameters (for DLL functions) */ /*------------------------------------------------------------------------*/ if (Initfunc != NA_STRING) { if (inherits(Initfunc, "NativeSymbol")) { init_func_type *initializer; PROTECT(de_gparms = Parms); nprot++; initializer = (init_func_type *) R_ExternalPtrAddrFn_(Initfunc); initializer(Initdeparms); } } isForcing = initForcings(Flist); /*------------------------------------------------------------------------*/ /* Initialization of Integration Loop */ /*------------------------------------------------------------------------*/ yout[0] = tt[0]; /* initial time */ for (i = 0; i < neq; i++) { y0[i] = xs[i]; yout[(i + 1) * nt] = y0[i]; } /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ for (it = 0; it < nt - 1; it++) { t = tt[it]; dt = tt[it + 1] - t; timesteps[0] = timesteps[1]; timesteps[1] = dt; if (verbose) Rprintf("Time steps = %d / %d time = %e\n", it + 1, nt, t); derivs(Func, t, y0, Parms, Rho, f1, out, 0, neq, ipar, isDll, isForcing); for (i = 0; i < neq; i++) { f1[i] = dt * f1[i]; f[i] = y0[i] + 0.5 * f1[i]; } derivs(Func, t + 0.5*dt, f, Parms, Rho, f2, out, 0, neq, ipar, isDll, isForcing); for (i = 0; i < neq; i++) { f2[i] = dt * f2[i]; f[i] = y0[i] + 0.5 * f2[i]; } derivs(Func, t + 0.5*dt, f, Parms, Rho, f3, out, 0, neq, ipar, isDll, isForcing); for (i = 0; i < neq; i++) { f3[i] = dt * f3[i]; f[i] = y0[i] + f3[i]; } derivs(Func, t + dt, f, Parms, Rho, f4, out, 0, neq, ipar, isDll, isForcing); for (i = 0; i < neq; i++) { f4[i] = dt * f4[i]; } /* Final computation of y */ for (i = 0; i < neq; i++) { f[i] = (f1[i] + 2.0 * f2[i] + 2.0 * f3[i] + f4[i]) / 6.0; y[i] = y0[i] + f[i]; y0[i] = y[i]; /* next time step */ } /* Store outputs */ if (it < nt) { yout[it + 1] = t + dt; for (i = 0; i < neq; i++) yout[it + 1 + nt * (1 + i)] = y[i]; } } /* end of rk main loop */ /*------------------------------------------------------------------------*/ /* call derivs again to get global outputs */ /* "-1" in derivs suppresses unnecessary copying */ /*------------------------------------------------------------------------*/ for (int j = 0; j < nt; j++) { t = yout[j]; for (i = 0; i < neq; i++) tmp[i] = yout[j + nt * (1 + i)]; derivs(Func, t, tmp, Parms, Rho, FF, out, -1, neq, ipar, isDll, isForcing); for (i = 0; i < nout; i++) { yout[j + nt * (1 + neq + i)] = out[i]; } } /* Attach diagnostic information (codes are compatible to lsoda) */ setIstate(R_yout, R_istate, istate, it, 4, 0, 4, 0); /* release R resources */ timesteps[0] = 0; timesteps[1] = 0; UNPROTECT(nprot); return(R_yout); } deSolve/src/rk_util.h0000644000176000001440000001060713136461013014316 0ustar ripleyusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >=2 */ /* Definitions and Utilities needed by Runge-Kutta Solvers */ /*==========================================================================*/ /* Load headers needed by the R interface */ #include #include #include #include "deSolve.h" #ifdef HAVE_LONG_DOUBLE # define LDOUBLE long double #else # define LDOUBLE double #endif /* sign of a number */ #define sign(x) (( x > 0 ) - ( x < 0 )) /*==========================================================================*/ /* general utilies and interpolation */ /*==========================================================================*/ void R_test_call(DllInfo *info); void R_unload_test_call(DllInfo *info); SEXP getvar(SEXP name, SEXP Rho); SEXP getInputs(SEXP symbol, SEXP Rho); void blas_matprod1(double *x, int nrx, int ncx, double *y, int nry, int ncy, double *z); void matprod(int m, int n, int o, double* a, double* b, double* c); double maxdiff(double *x, double *y, int n); double maxerr(double *y0, double *y1, double *y2, double* Atol, double* Rtol, int n); void derivs(SEXP Func, double t, double* y, SEXP Parms, SEXP Rho, double *ydot, double *yout, int j, int neq, int *ipar, int isDll, int isForcing); void denspar(double *FF, double *y0, double *y1, double dt, double *d, int neq, int stage, double *r); void densout(double *r, double t0, double t, double dt, double* res, int neq); void densoutck(double t0, double t, double dt, double * y0, double* FF, double* dy, double* res, int neq); void neville(double *xx, double *y, double tnew, double *ynew, int n, int ksig); void shiftBuffer (double *x, int n, int k); void setIstate(SEXP R_yout, SEXP R_istate, int *istate, int it_tot, int stage, int fsal, int qerr, int nrej); /*==========================================================================*/ /* core functions (main loop) for solvers with variable / fixed step size */ /*==========================================================================*/ void rk_auto( /* integers */ int fsal, int neq, int stage, int isDll, int isForcing, int verbose, int nknots, int interpolate, int densetype, int maxsteps, int nt, /* int pointers */ int* _iknots, int* _it, int* _it_ext, int* _it_tot, int *_it_rej, int* istate, int* ipar, /* double */ double t, double tmax, double hmin, double hmax, double alpha, double beta, /* double pointers */ double* _dt, double* _errold, /* arrays */ double* tt, double* y0, double* y1, double* y2, double* dy1, double* dy2, double* f, double* y, double* Fj, double* tmp, double* FF, double* rr, double* A, double* out, double* bb1, double* bb2, double* cc, double* dd, double* atol, double* rtol, double* yknots, double* yout, /* SEXPs */ SEXP Func, SEXP Parms, SEXP Rho ); void rk_fixed( /* integers */ int fsal, int neq, int stage, int isDll, int isForcing, int verbose, int nknots, int interpolate, int maxsteps, int nt, /* int pointers */ int* _iknots, int* _it, int* _it_ext, int* _it_tot, int* istate, int* ipar, /* double */ double t, double tmax, double hini, /* double pointers */ double* _dt, /* arrays */ double* tt, double* y0, double* y1,double* dy1, double* f, double* y, double* Fj, double* tmp, double* FF, double* rr, double* A, double* out, double* bb1, double* cc, double* yknots, double* yout, /* SEXPs */ SEXP Func, SEXP Parms, SEXP Rho ); void rk_implicit(double * alfa, int *index, /* integers */ int fsal, int neq, int stage, int isDll, int isForcing, int verbose, int nknots, int interpolate, int maxsteps, int nt, /* int pointers */ int* _iknots, int* _it, int* _it_ext, int* _it_tot, int* istate, int* ipar, /* double */ double t, double tmax, double hini, /* double pointers */ double* _dt, /* arrays */ double* tt, double* y0, double* y1, double* dy1, double* f, double* y, double* Fj, double* tmp, double* tmp2, double *tmp3, double* FF, double* rr, double* A, double* out, double* bb1, double* cc, double* yknots, double* yout, /* SEXPs */ SEXP Func, SEXP Parms, SEXP Rho ); deSolve/src/lags.c0000644000176000001440000003665113503760733013606 0ustar ripleyusers#include #include #include "deSolve.h" /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ time lags and delay-differential equations; from deSolve version 1.7 For delay-differential equations, a history of past values, past derivatives and past times, is kept (time-lags). They are in ring-vectors "histvar", "histdvar" and "histtime" respectively. These vectors are initialised at the start of the integration ("inithist") and then updated with new values every accepted timestep ("updatehist"). When the end of the history vectors is reached, new values are stored at the start (it is a ringbuffer); function "nexthist" finds the next position in this ringbuffer. The history buffers can be interrogated in the R-code, via R-functions "lagvalue(t,nr)" and "lagderiv(t,nr)", where nr can be one index or a vector containing the nr of the variable whose lag has to be computed at time t. These R-functions call C-functions "getLagValue" and "getLagDeriv" which first find the interval in the history vectors in which the lagged value is to be found ("findHistInt"), and then either use hermite interpolation to the requested time (functions "Hermite" and "dHermite" for values and derivatives), or use the Nordsieck history array. Note: findHistInt finds interval by bisectioning; only marginally more/less efficient than straightforward findHistInt2... +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ /*=========================================================================== Higher-order interpolation of y to x, based on Nordsieck history array if interpolMethod ==2 =========================================================================== */ /* definition of call to FORTRAN function INTERPOLY, as derived from dintdy */ void F77_NAME(interpoly)(double *, int *, int *, double *, int *, double *, int *, double *, double *); double interpolate(int i, int k, double t0, double hh, double t, double *Yh, int nq) { double res; if (nq > 12) error("illegal nq in interpolate, %i, at time %g", nq, t); if (k > nq) error("illegal k %i, nq in interpolate, %i, at time %g", k, nq, t); if (i > n_eq || i <1) error("illegal i %i, n_eq %i, at time %g", i, n_eq, t); F77_CALL(interpoly) (&t, &k, &i, Yh, &n_eq, &res, &nq, &t0, &hh); return(res); } /* continuous output formula for radau */ void F77_NAME (contr5alone) (int *, int *, double *, double *, int *, double *, double *, int *); void F77_NAME (getconra) (double *); /*=========================================================================== Hermitian interpolation of y to x (interpolMethod==1) =========================================================================== */ double Hermite (double t0, double t1, double y0, double y1, double dy0, double dy1, double t) { double tt0, tt1, tt12, tt02, hh, res; tt0 = t-t0; tt1 = t-t1; tt12 = tt1*tt1; tt02 = tt0*tt0; hh = t1-t0; if (hh) res=( dy0* tt0* tt12 + dy1* tt1* tt02 + ( y0* (2.0* tt0 + hh)* tt12 -y1* (2.0* tt1 - hh)* tt02 )/hh) / (hh * hh); else res=y0; return(res); } /*=========================================================================== Hermitian interpolation of dy to x =========================================================================== */ double dHermite (double t0, double t1, double y0, double y1, double dy0, double dy1, double t) { double tt0, tt1, tt12, tt02, hh, res; tt0 = t-t0; tt1 = t-t1; tt12 = tt1*tt1; tt02 = tt0*tt0; hh = t1-t0; if (hh) res=( dy0 * (tt12+2.0* tt0* tt1) + dy1 * ( tt02+2.0* tt0* tt1) + ( y0 *2.0* tt1*(2.0* tt0+ hh + tt1) -y1 *2.0* tt0*(2.0* tt1- hh + tt0))/ hh ) / ( hh* hh) ; else res= dy0; return(res); } /*=========================================================================== initialise history arrays + indices at start integration =========================================================================== */ void inithist(int max, int maxlags, int solver, int nroot) { int maxord; histsize = max; initialisehist = 1; indexhist = -1; /* indexhist+1 = next time in circular buffer. */ starthist = 0; /* start time in circular buffer. */ endreached = 0; /* if end of buffer reached and new values added at start */ /* interpolMethod = Hermite */ if (interpolMethod == 1) { offset = n_eq; /* size needed for saving one time-step in histvar*/ /* interpolMethod = HigherOrder, Livermore solvers */ } else if (interpolMethod == 2) { if (solver == 0) error("illegal input in lags - cannot combine interpol=2 with chosen solver"); maxord = 12; /* 5(bdf) or 12 (adams) */ lyh = 20; /* position of history array in rwork (C-index) */ lhh = 11; /* position of h in rwork (C-index) Note: for lsodx this is NEXT time step! */ lo = 13; /* position of method order in iwork (C-index) */ if (solver == 5) { /* different for vode! uses current time step*/ lhh = 10; lo = 13; } if (solver == 4 || solver == 6 || solver == 7) /* lsodar or lsoder */ lyh = 20+3*nroot; offset = n_eq*(maxord+1); histord = (int *) R_alloc (histsize, sizeof(int)); histhh = (double *) R_alloc (histsize, sizeof(double)); /* interpolMethod = 3; HigherOrder, radau */ } else { offset = n_eq * 4 + 2; histsave = (double *) R_alloc (2, sizeof(double)); } histtime = (double *) R_alloc (histsize, sizeof(double)); histvar = (double *) R_alloc (offset * histsize, sizeof(double)); histdvar = (double *) R_alloc (n_eq * histsize, sizeof(double)); } /*=========================================================================== given the maximum size of the history arrays; finds the next index =========================================================================== */ int nexthist(int i) { if (i < histsize-1) return(i+1); else { endreached = 1; return(0); } } /*=========================================================================== update history arrays each time step =========================================================================== */ /* first time: just store y, (dy) and t */ void updatehistini(double t, double *y, double *dY, double *rwork, int *iwork){ int intpol; intpol = interpolMethod; interpolMethod = 1; updatehist(t, y, dY, rwork, iwork); interpolMethod = intpol; if (interpolMethod == 2){ histord[0] = 0; histhh[0] = timesteps[0]; } } void updatehist(double t, double *y, double *dY, double *rwork, int *iwork) { int j, ii; double ss[2]; indexhist = nexthist(indexhist); ii = indexhist * offset; /* interpolMethod = Hermite */ if (interpolMethod == 1) { for (j = 0; j < n_eq; j++) histvar [ii + j ] = y[j]; /* higherOrder, livermores */ } else if (interpolMethod == 2) { histord[indexhist] = iwork[lo]; for (j = 0; j < offset; j++) histvar[ii + j] = rwork[lyh + j]; histhh [indexhist] = rwork[lhh]; /* higherOrder, radau */ } else if (interpolMethod == 3) { for (j = 0; j < 4 * n_eq; j++) histvar[ii + j] = rwork[j]; F77_CALL(getconra) (ss); for (j = 0; j < 2; j++) histvar[ii + 4*n_eq + j] = ss[j]; } ii = indexhist * n_eq; for (j = 0; j < n_eq; j++) histdvar[ii + j] = dY[j]; histtime [indexhist] = t; if (endreached == 1) /* starthist stays 0 until end reached... */ starthist = nexthist(starthist); } /*=========================================================================== find a past value (val=1) or a past derivative (val = 2) =========================================================================== */ double past(int i, int interval, double t, int val) /* finds past values (val=1) or past derivatives (val=2)*/ { int j, jn, nq, ip; double t0, t1, y0, y1, dy0, dy1, res, hh; double *Yh; /* error checking */ if ( i >= n_eq) error("illegal input in lagvalue - var nr too high, %i", i+1); /* equal to current value... */ if ( interval == indexhist && t == histtime[interval]) { if (val == 1) res = histvar [interval * offset + i ]; else res = histdvar [interval * offset + i ]; /* within last interval - for now: just extrapolate last value */ } else if ( interval == indexhist && interpolMethod == 1) { if (val == 1) { t0 = histtime[interval]; y0 = histvar [interval * offset + i ]; dy0 = histdvar [interval * n_eq + i ]; res = y0 + dy0*(t-t0); } else res = histdvar [interval * n_eq + i ]; /* Hermite interpolation */ } else if (interpolMethod == 1) { j = interval; jn = nexthist(j); t0 = histtime[j]; t1 = histtime[jn]; y0 = histvar [j * n_eq + i ]; y1 = histvar [jn * n_eq + i ]; dy0 = histdvar [j * n_eq + i ]; dy1 = histdvar [jn * n_eq + i ]; if (val == 1) res = Hermite (t0, t1, y0, y1, dy0, dy1, t); else res = dHermite (t0, t1, y0, y1, dy0, dy1, t); /* dense interpolation - livermore solvers */ } else if (interpolMethod == 2) { j = interval; jn = nexthist(j); t0 = histtime[j]; t1 = histtime[jn]; nq = histord [j]; if (nq == 0) { y0 = histvar [j * offset + i ]; y1 = histvar [jn * offset + i ]; dy0 = histdvar [j * n_eq + i ]; dy1 = histdvar [jn * n_eq + i ]; if (val == 1) res = Hermite (t0, t1, y0, y1, dy0, dy1, t); else res = dHermite (t0, t1, y0, y1, dy0, dy1, t); } else { Yh = &histvar [j * offset]; hh = histhh[j]; res = interpolate(i+1, val-1, t0, hh, t, Yh, nq); } /* dense interpolation - radau - gets all values (i not used) */ } else { // if (val == 2) // error("radau interpol = 2 does not work for lagderiv"); j = interval; Yh = &histvar [j * offset]; histsave = &histvar [j * offset + 4*n_eq]; ip = i+1; F77_CALL(contr5alone) (&ip, &n_eq, &t, Yh, &offset, histsave, &res, &val); } return(res); } /*=========================================================================== Find interval in history ring buffers, corresponding to "t" two alternatives; only findHistInt used =========================================================================== */ int findHistInt2 (double t) { int j, jn; if ( t >= histtime[indexhist]) return(indexhist); if ( t < histtime[starthist]) error("illegal input in lagvalue - lag, %g, too large, at time = %g\n", t, histtime[indexhist]); /* find embracing time starting from beginning */ j = starthist; jn = nexthist(j); while (histtime[jn]= histtime[indexhist]) return(indexhist); if ( t < histtime[starthist]) error("illegal input in lagvalue - lag, %g, too large, at time = %g\n", t, histtime[indexhist]); if (endreached == 0) { /* still filling buffer; not yet wrapped */ ilo = 0; ihi = indexhist; for(;;) { imid = (ilo + ihi) / 2; if (imid == ilo) return ilo; if (t >= histtime[imid]) ilo = imid; else ihi = imid; } } n = histsize -1; ilo = 0; ihi = n; for(;;) { imid = (ilo + ihi) / 2; ii = imid + starthist; if (ii > n) ii = ii - n - 1; if (imid == ilo) return ii; if (t >= histtime[ii]) ilo = imid; else ihi = imid; } } /*=========================================================================== C-equivalent of R-function lagvalue =========================================================================== */ SEXP getLagValue(SEXP T, SEXP nr) { SEXP value; int i, ilen, interval; double t; ilen = LENGTH(nr); if (initialisehist == 0) error("pastvalue can only be called from 'func' or 'res' when triggered by appropriate integrator."); if (!isNumeric(T)) error("'t' should be numeric"); t = *NUMERIC_POINTER(T); interval = findHistInt (t); if ((ilen ==1) && (INTEGER(nr)[0] == 0)) { PROTECT(value=NEW_NUMERIC(n_eq)); for(i=0; i= 2 */ /* General RK Solver for methods with adaptive step size */ /* -- main loop == core function -- */ /* Parts inspired by Press et al., 2002, 2007; */ /* see vignette for full references */ /*==========================================================================*/ #include "rk_util.h" void rk_auto( /* integers */ int fsal, int neq, int stage, int isDll, int isForcing, int verbose, int nknots, int interpolate, int densetype, int maxsteps, int nt, /* int pointers */ int* _iknots, int* _it, int* _it_ext, int* _it_tot, int* _it_rej, int* istate, int* ipar, /* double */ double t, double tmax, double hmin, double hmax, double alpha, double beta, /* double pointers */ double* _dt, double* _errold, /* arrays */ double* tt, double* y0, double* y1, double* y2, double* dy1, double* dy2, double* f, double* y, double* Fj, double* tmp, double* FF, double* rr, double* A, double* out, double* bb1, double* bb2, double* cc, double* dd, double* atol, double* rtol, double* yknots, double* yout, /* SEXPs */ SEXP Func, SEXP Parms, SEXP Rho ) { int i = 0, j = 0, j1 = 0, k = 0, accept = FALSE, nreject = *_it_rej, one = 1; int iknots = *_iknots, it = *_it, it_ext = *_it_ext, it_tot = *_it_tot; double err, dtnew, t_ext; double dt = *_dt, errold = *_errold; /* todo: make this user adjustable */ static const double minscale = 0.2, maxscale = 10.0, safe = 0.9; /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ do { if (accept) timesteps[0] = timesteps[1]; timesteps[1] = dt; /* save former results of last step if the method allows this (first same as last) */ /* Karline: improve by saving "accepted" FF, use this when rejected */ if (fsal && accept){ j1 = 1; for (i = 0; i < neq; i++) FF[i] = FF[i + neq * (stage - 1)]; } else { j1 = 0; } /****** Prepare Coefficients from Butcher table ******/ for (j = j1; j < stage; j++) { for(i = 0; i < neq; i++) Fj[i] = 0; k = 0; while(k < j) { for(i = 0; i < neq; i++) Fj[i] = Fj[i] + A[j + stage * k] * FF[i + neq * k] * dt; k++; } for (int i = 0; i < neq; i++) { tmp[i] = Fj[i] + y0[i]; } /****** Compute Derivatives ******/ /* pass option to avoid unnecessary copying in derivs */ derivs(Func, t + dt * cc[j], tmp, Parms, Rho, FF, out, j, neq, ipar, isDll, isForcing); } /*====================================================================*/ /* Estimation of new values */ /*====================================================================*/ /* use BLAS wrapper with reduced error checking */ blas_matprod1(FF, neq, stage, bb1, stage, one, dy1); blas_matprod1(FF, neq, stage, bb2, stage, one, dy2); it_tot++; /* count total number of time steps */ for (i = 0; i < neq; i++) { y1[i] = y0[i] + dt * dy1[i]; y2[i] = y0[i] + dt * dy2[i]; } /*====================================================================*/ /* stepsize adjustment */ /*====================================================================*/ err = maxerr(y0, y1, y2, atol, rtol, neq); dtnew = dt; if (err == 0) { /* use max scale if all tolerances are zero */ dtnew = fmin(dt * 10, hmax); errold = fmax(err, 1e-4); /* 1e-4 taken from Press et al. */ accept = TRUE; } else if (err < 1.0) { /* increase step size only if last one was accepted */ if (accept) dtnew = fmin(hmax, dt * fmin(safe * pow(err, -alpha) * pow(errold, beta), maxscale)); errold = fmax(err, 1e-4); /* 1e-4 taken from Press et al. */ accept = TRUE; } else if (err > 1.0) { nreject++; /* count total number of rejected steps */ accept = FALSE; dtnew = dt * fmax(safe * pow(err, -alpha), minscale); } if (dtnew < hmin) { accept = TRUE; if (verbose) Rprintf("warning, h < Hmin\n"); istate[0] = -2; dtnew = hmin; } /*====================================================================*/ /* Interpolation and Data Storage */ /*====================================================================*/ if (accept) { if (interpolate) { /*--------------------------------------------------------------------*/ /* case A1) "dense output type 1": built-in polynomial interpolation */ /* available for certain rk formulae, e.g. for rk45dp7 */ /*--------------------------------------------------------------------*/ if (densetype == 1) { denspar(FF, y0, y2, dt, dd, neq, stage, rr); t_ext = tt[it_ext]; while (t_ext <= t + dt) { densout(rr, t, t_ext, dt, tmp, neq); /* store outputs */ if (it_ext < nt) { yout[it_ext] = t_ext; for (i = 0; i < neq; i++) yout[it_ext + nt * (1 + i)] = tmp[i]; } if(it_ext < nt-1) t_ext = tt[++it_ext]; else break; } /*--------------------------------------------------------------------*/ /* case A2) dense output type 2: the Cash-Karp method */ /*--------------------------------------------------------------------*/ } else if (densetype == 2) { /* dense output method 2 = Cash-Karp */ derivs(Func, t + dt, y2, Parms, Rho, dy2, out, 0, neq, ipar, isDll, isForcing); t_ext = tt[it_ext]; while (t_ext <= t + dt) { densoutck(t, t_ext, dt, y0, FF, dy2, tmp, neq); /* store outputs */ if (it_ext < nt) { yout[it_ext] = t_ext; for (i = 0; i < neq; i++) yout[it_ext + nt * (1 + i)] = tmp[i]; } if(it_ext < nt-1) t_ext = tt[++it_ext]; else break; } /* FSAL (first same as last) for Cash-Karp */ for (i = 0; i < neq; i++) FF[i + neq * (stage - 1)] = dy2[i] ; /*--------------------------------------------------------------------*/ /* case B) Neville-Aitken-Interpolation for integrators */ /* without dense output */ /*--------------------------------------------------------------------*/ } else { /* (1) collect number "nknots" of knots in advance */ yknots[iknots] = t + dt; /* time is first column */ for (i = 0; i < neq; i++) yknots[iknots + nknots * (1 + i)] = y2[i]; if (iknots < (nknots - 1)) { iknots++; } else { /* (2) do polynomial interpolation */ t_ext = tt[it_ext]; while (t_ext <= t + dt) { neville(yknots, &yknots[nknots], t_ext, tmp, nknots, neq); /* (3) store outputs */ if (it_ext < nt) { yout[it_ext] = t_ext; for (i = 0; i < neq; i++) yout[it_ext + nt * (1 + i)] = tmp[i]; } if(it_ext < nt-1) t_ext = tt[++it_ext]; else break; } shiftBuffer(yknots, nknots, neq + 1); } } } else { /*--------------------------------------------------------------------*/ /* Case C) no interpolation at all (for step to step integration); */ /* results are stored after the call */ /*--------------------------------------------------------------------*/ } /*--------------------------------------------------------------------*/ /* next time step */ /*--------------------------------------------------------------------*/ t = t + dt; it++; for (i=0; i < neq; i++) y0[i] = y2[i]; } /* else rejected time step */ dt = fmin(dtnew, tmax - t); if (it_ext > nt) { Rprintf("error in RK solver rk_auto.c: output buffer overflow\n"); break; } if (it_tot > maxsteps) { istate[0] = -1; warning("Number of time steps %i exceeded maxsteps at t = %g\n", it, t); break; } /* tolerance to avoid rounding errors */ } while (t < (tmax - 100.0 * DBL_EPSILON * dt)); /* end of rk main loop */ /* return reference values */ *_iknots = iknots; *_it = it; *_it_ext = it_ext; *_it_rej = nreject; *_it_tot = it_tot; *_dt = dtnew; *_errold = errold; } deSolve/src/rk_fixed.c0000644000176000001440000001233213274246325014442 0ustar ripleyusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >=2 */ /* General RK Solver for methods with adaptive step size */ /* -- main loop == core function -- */ /*==========================================================================*/ #include "rk_util.h" void rk_fixed( /* integers */ int fsal, int neq, int stage, int isDll, int isForcing, int verbose, int nknots, int interpolate, int maxsteps, int nt, /* int pointers */ int* _iknots, int* _it, int* _it_ext, int* _it_tot, int* istate, int* ipar, /* double */ double t, double tmax, double hini, /* double pointers */ double* _dt, /* arrays */ double* tt, double* y0, double* y1, double* dy1, double* f, double* y, double* Fj, double* tmp, double* FF, double* rr, double* A, double* out, double* bb1, double* cc, double* yknots, double* yout, /* SEXPs */ SEXP Func, SEXP Parms, SEXP Rho ) { int i = 0, j = 0, one = 1; int iknots = *_iknots, it = *_it, it_ext = *_it_ext, it_tot = *_it_tot; double t_ext; double dt = *_dt; /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ //Rprintf("1: dt, hini = %g , %g\n", dt, hini); do { /* select time step (possibly irregular) */ if (fabs(hini) < (DBL_EPSILON * 100.0)) dt = tt[it] - tt[it-1]; else dt = fmin(fabs(hini), fabs(tmax - t)) * sign(hini); //Rprintf("dt, hini = %g , %g\n", dt, hini); timesteps[0] = timesteps[1]; timesteps[1] = dt; /****** Prepare Coefficients from Butcher table ******/ /* NOTE: the fixed-step solver needs coefficients as vector, not matrix! */ for (j = 0; j < stage; j++) { if (j == 0) for(i = 0; i < neq; i++) Fj[i] = 0; else for(i = 0; i < neq; i++) Fj[i] = A[j] * FF[i + neq * (j - 1)] * dt; for (int i = 0; i < neq; i++) { tmp[i] = Fj[i] + y0[i]; } /****** Compute Derivatives ******/ derivs(Func, t + dt * cc[j], tmp, Parms, Rho, FF, out, j, neq, ipar, isDll, isForcing); } /*====================================================================*/ /* Estimation of new values */ /*====================================================================*/ /* use BLAS with reduced error checking */ blas_matprod1(FF, neq, stage, bb1, stage, one, dy1); it_tot++; /* count total number of time steps */ for (i = 0; i < neq; i++) { y1[i] = y0[i] + dt * dy1[i]; } /*====================================================================*/ /* Interpolation and Data Storage */ /*====================================================================*/ if (interpolate) { /*------------------------------------------------------------------*/ /* Neville-Aitken-Interpolation */ /* the fixed step integrators have no dense output */ /*------------------------------------------------------------------*/ /* (1) collect number "nknots" of knots in advance */ yknots[iknots] = t + dt; /* time in first column */ for (i = 0; i < neq; i++) yknots[iknots + nknots * (1 + i)] = y1[i]; if (iknots < (nknots - 1)) { iknots++; } else { /* (2) do polynomial interpolation */ t_ext = tt[it_ext]; while (t_ext <= t + dt) { neville(yknots, &yknots[nknots], t_ext, tmp, nknots, neq); /* (3) store outputs */ if (it_ext < nt) { yout[it_ext] = t_ext; for (i = 0; i < neq; i++) yout[it_ext + nt * (1 + i)] = tmp[i]; } if(it_ext < nt-1) t_ext = tt[++it_ext]; else break; } shiftBuffer(yknots, nknots, neq + 1); } } else { /*--------------------------------------------------------------------*/ /* No interpolation mode(for step to step integration); */ /* results are stored after the call */ /*--------------------------------------------------------------------*/ } /*--------------------------------------------------------------------*/ /* next time step */ /*--------------------------------------------------------------------*/ t = t + dt; it++; for (i = 0; i < neq; i++) y0[i] = y1[i]; if (it_ext > nt) { Rprintf("error in RK solver rk_fixed.c: output buffer overflow\n"); break; } if (it_tot > maxsteps) { istate[0] = -1; warning("Number of time steps %i exceeded maxsteps at t = %g\n", it, t); break; } /* tolerance to avoid rounding errors */ } while (fabs(t - tmax) > 100.0 * DBL_EPSILON); /* end of rk main loop */ /* return reference values */ *_iknots = iknots; *_it = it; *_it_ext = it_ext; *_it_tot = it_tot; } deSolve/src/ex_ChemicalDAE.c0000644000176000001440000000344013136461013015350 0ustar ripleyusers/*---------------------------------------------------------------- The chemical model example of daspk but with the production rate a forcing function rather than a parameter... ----------------------------------------------------------------*/ #include /* -------- ChemicalDAE.c -> ChemicalDAE.dll ------ c compile in R with: system("g77 -shared -o ChemicalDAE.dll ChemicalDAE.c") c or with system("R CMD SHLIB ChemicalDAE.c") */ /* A trick to address the parameters and forcings by name */ static double parms[3]; static double forc[1]; #define K parms[0] #define ka parms[1] #define r parms[2] #define prod forc[0] /*---------------------------------------------------------------- Initialiser for parameters ----------------------------------------------------------------*/ void initparms(void (* daspkparms)(int *, double *)) { int N=3; daspkparms(&N, parms); } /*---------------------------------------------------------------- c Initialiser for forcings ----------------------------------------------------------------*/ void initforcs(void (* daspkforcs)(int *, double *)) { int N=1; daspkforcs(&N, forc); } /*---------------------------------------------------------------- Derivatives ----------------------------------------------------------------*/ void chemres (double *t, double *y, double *ydot, double *cj, double *delta, int *ires, double *out, int *ip) { double ra, rb; if (ip[0] <2) error("nout should be at least 2"); ra = ka* y[2]; /* forward rate */ rb = ka/K *y[0] * y[1]; /* backward rate */ /* residuals of rates of changes */ delta[2] = -ydot[2] - ra + rb + prod; delta[0] = -ydot[0] + ra - rb; delta[1] = -ydot[1] + ra - rb - r*y[1]; out[0] = y[0] + y[1] + y[2]; out[1] = prod; } deSolve/src/deSolve.h0000644000176000001440000001224513603407277014261 0ustar ripleyusers#ifndef R_R_H # include #endif #ifndef R_DEFINES_H # include #endif #ifndef R_INTERNALS_H_ # include #endif /*============================================================================ global R variables ============================================================================*/ #ifndef EXTERN # define EXTERN extern #endif EXTERN double *timesteps; /* see also: R_init_deSolve.c */ EXTERN SEXP YOUT, YOUT2, ISTATE, RWORK, IROOT; /* returned to R */ EXTERN SEXP Y, YPRIME , Rin; EXTERN int n_eq; /* use in daspk */ EXTERN long int nrowpd; /* output in DLL globals */ EXTERN int isOut, *ipar; EXTERN double *out; /* forcings */ EXTERN long int nforc; /* the number of forcings */ EXTERN double *tvec; EXTERN double *fvec; EXTERN int *ivec; EXTERN int fmethod; EXTERN int *findex; EXTERN double *intpol; EXTERN int *maxindex; EXTERN double *forcings; /* events */ EXTERN double tEvent; EXTERN int iEvent, nEvent, typeevent, rootevent, Rootsave; EXTERN double *troot, *valroot; EXTERN int *nrroot, *termroot; EXTERN double *timeevent, *valueevent; EXTERN int *svarevent, *methodevent; /* time delays */ EXTERN int interpolMethod; /* for time-delays : 1 = hermite; 2=dense */ /*============================================================================ type definitions for C functions ============================================================================*/ typedef void C_deriv_func_type(int*, double*, double*, double*, double*, int*); EXTERN C_deriv_func_type* DLL_deriv_func; typedef void C_res_func_type(double*, double*, double*, double*, double*, int*, double*, int*); EXTERN C_res_func_type* DLL_res_func; /* this is for use in compiled code */ typedef void init_func_type (void (*)(int*, double*)); /*============================================================================ solver R- global functions ============================================================================*/ EXTERN SEXP R_deriv_func; EXTERN SEXP R_jac_func; EXTERN SEXP R_jac_vec; EXTERN SEXP R_root_func; EXTERN SEXP R_event_func; EXTERN SEXP R_envir; /* DAE globals */ EXTERN SEXP R_res_func; EXTERN SEXP R_daejac_func; EXTERN SEXP R_psol_func; EXTERN SEXP R_mas_func; EXTERN SEXP de_gparms; SEXP getListElement(SEXP list, const char* str); SEXP getTimestep(); /*============================================================================ C- utilities, functions ============================================================================*/ void lock_solver(void); void unlock_solver(void); void returnearly (int, int, int); void terminate(int, int*, int, int, double *, int, int); /* declarations for initialisations */ // void initParms(SEXP Initfunc, SEXP Parms); void Initdeparms(int*, double*); void Initdeforc(int*, double*); void initOutR(int isDll, int *nout, int *ntot, int neq, SEXP nOut, SEXP Rpar, SEXP Ipar); void initOutC(int isDll, int *nout, int *ntot, int neq, SEXP nOut, SEXP Rpar, SEXP Ipar); /* sparsity of Jacobian */ void sparsity1D(SEXP Type, int* iwork, int neq, int liw); void sparsity2D(SEXP Type, int* iwork, int neq, int liw); void sparsity3D(SEXP Type, int* iwork, int neq, int liw); void sparsity2Dmap(SEXP Type, int* iwork, int neq, int liw); /* testing, since version 1.10.4*/ void sparsity3Dmap(SEXP Type, int* iwork, int neq, int liw); /* testing, since version 1.10.4*/ void interactmap (int *ij, int nnz, int *iwork, int *ipres, int ival); //void initglobals(int, int); //void initdaeglobals(int, int); /* the forcings and event functions */ void updatedeforc(double*); int initForcings(SEXP list); int initEvents(SEXP list, SEXP, int); void updateevent(double*, double*, int*); /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ DECLARATIONS for time lags +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ /*========================================== R-functions ==========================================*/ SEXP getPastValue (SEXP T, SEXP nr); SEXP getPastGradient(SEXP T, SEXP nr); /*========================================== C- utilities, functions ==========================================*/ /* Hermitian interpolation */ double Hermite (double t0, double t1, double y0, double y1, double dy0, double dy1, double t); double dHermite(double t0, double t1, double y0, double y1, double dy0, double dy1, double t); int initLags(SEXP elag, int solver, int nroot); /* history vectors */ void inithist(int max, int maxlags, int solver, int nroot); void updatehistini(double t, double *y, double *dY, double *rwork, int *iwork); void updatehist(double t, double *y, double *dy, double *rwork, int *iwork); int nexthist(int i); double interpolate(int i, int k, double t0, double t1, double t, double *Yh, int nq); /*========================================== Global variables for history arrays ==========================================*/ EXTERN int indexhist, indexlag, endreached, starthist; EXTERN double *histvar, *histdvar, *histtime, *histhh, *histsave; EXTERN int *histord; EXTERN int histsize, offset; EXTERN int initialisehist, lyh, lhh, lo; #undef EXTERN deSolve/src/rk_util.c0000644000176000001440000002512213274246436014324 0ustar ripleyusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >=2 */ /* Definitions and Utilities needed by Runge-Kutta Solvers */ /*==========================================================================*/ /* Load headers needed by the R interface */ #include #include /* for dgemm */ #include #include "deSolve.h" #ifdef HAVE_LONG_DOUBLE # define LDOUBLE long double #else # define LDOUBLE double #endif #include "externalptr.h" /*============================================================================*/ /* DLL specific functions */ /*============================================================================*/ void R_test_call(DllInfo *info) { /* Register routines, allocate resources. */ Rprintf("test_call DLL loaded\n"); } void R_unload_test_call(DllInfo *info) { /* Release resources. */ Rprintf("test_call DLL unloaded\n"); } /*============================================================================*/ /* Functions for processing complex R arguments */ /*============================================================================*/ /* -------- getvar from environment ------------------------------------------*/ SEXP getvar(SEXP name, SEXP Rho) { SEXP ans; if(!isString(name) || length(name) != 1) error("name is not a single string"); if(!isEnvironment(Rho)) error("Rho should be an environment"); ans = findVar(install(CHAR(STRING_ELT(name, 0))), Rho); return(ans); } SEXP getInputs(SEXP symbol, SEXP Rho) { if(!isEnvironment(Rho)) error("Rho should be an environment"); return(getvar(symbol, Rho)); } /*============================================================================*/ /* Arithmetic utilities */ /*============================================================================*/ /*----------------------------------------------------------------------------*/ /* Matrix Multiplication using the BLAS routine */ /* a reduced version without NA checking, this is ensured otherwise */ /*----------------------------------------------------------------------------*/ void blas_matprod1(double *x, int nrx, int ncx, double *y, int nry, int ncy, double *z) { const char *transa = "N", *transb = "N"; int i; double one = 1.0, zero = 0.0; if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) { F77_CALL(dgemm)(transa, transb, &nrx, &ncy, &ncx, &one, x, &nrx, y, &nry, &zero, z, &nrx); } else /* zero-extent operations should return zeroes */ for(i = 0; i < nrx*ncy; i++) z[i] = 0; } /* -- Simple Matrix Multiplication without BLAS ------------------------------ */ void matprod(int m, int n, int o, double* a, double* b, double* c) { int i, j, k; for (i = 0; i < m; i++) { for (j = 0; j < o; j++) { c[i + m * j] = 0; for (k = 0; k < n; k++) { c[i + m * j] += a[i + m * k] * b[k + n * j]; } } } } double maxdiff(double *x, double *y, int n) { double d = 0.0; for (int i = 0; i < n; i++) d = fmax(d, fabs(x[i] - y[i])); return(d); } double maxerr(double *y0, double *y1, double *y2, double *Atol, double *Rtol, int n) { double serr = 0, scal, delta; for (int i = 0; i < n; i++) { /* y2 is used to estimate next y-value */ scal = Atol[i] + fmax(fabs(y0[i]), fabs(y2[i])) * Rtol[i]; delta = fabs(y2[i] - y1[i]); if (scal > 0) serr += pow(delta/scal, 2.0); } return(sqrt(serr/n)); /* Euclidean norm */ } /*==========================================================================*/ /* CALL TO THE MODEL FUNCTION */ /*==========================================================================*/ void derivs(SEXP Func, double t, double* y, SEXP Parms, SEXP Rho, double *ydot, double *yout, int j, int neq, int *ipar, int isDll, int isForcing) { SEXP Val, rVal, R_fcall; SEXP R_t; SEXP R_y; int i = 0; int nout = ipar[0]; double *yy; double ytmp[neq]; if (isDll) { /*------------------------------------------------------------------------*/ /* Function is a DLL function */ /*------------------------------------------------------------------------*/ C_deriv_func_type *cderivs; if (isForcing) updatedeforc(&t); cderivs = (C_deriv_func_type *) R_ExternalPtrAddrFn_(Func); cderivs(&neq, &t, y, ytmp, yout, ipar); if (j >= 0) for (i = 0; i < neq; i++) ydot[i + neq * j] = ytmp[i]; } else { /*------------------------------------------------------------------------*/ /* Function is an R function */ /*------------------------------------------------------------------------*/ PROTECT(R_t = ScalarReal(t)); PROTECT(R_y = allocVector(REALSXP, neq)); yy = REAL(R_y); for (i=0; i< neq; i++) yy[i] = y[i]; PROTECT(R_fcall = lang4(Func, R_t, R_y, Parms)); PROTECT(Val = eval(R_fcall, Rho)); /* extract the states from first list element of "Val" */ if (j >= 0) for (i = 0; i < neq; i++) ydot[i + neq * j] = REAL(VECTOR_ELT(Val, 0))[i]; /* extract outputs from second and following list elements */ /* this is essentially an unlist for non-nested numeric lists */ if (j < 0) { int elt = 1, ii = 0, l; for (i = 0; i < nout; i++) { l = LENGTH(VECTOR_ELT(Val, elt)); if (ii == l) { ii = 0; elt++; } //yout[i] = REAL(VECTOR_ELT(Val, elt))[ii]; // thpe 2012-08-04: make sure the return value is double and not int PROTECT(rVal = coerceVector(VECTOR_ELT(Val, elt), REALSXP)); yout[i] = REAL(rVal)[ii]; UNPROTECT(1); ii++; } } UNPROTECT(4); } } /*============================================================================*/ /* Interpolation functions */ /*============================================================================*/ /*----------------------------------------------------------------------------*/ /* "dense output" */ /* is a specific polynomial interpolation that uses intermediate rk steps */ /*----------------------------------------------------------------------------*/ void denspar(double *FF, double *y0, double *y1, double dt, double *d, int neq, int stage, double *r) { double ydiff, bspl; int i, j; for (i = 0; i < neq; i++) { r[i] = y0[i]; ydiff = y1[i] - y0[i]; r[i + neq] = ydiff; bspl = dt * FF[i] - ydiff; r[i + 2 * neq] = bspl; r[i + 3 * neq] = ydiff - dt * FF[i + (stage - 1) * neq] - bspl; r[i + 4 * neq] = 0; for (j = 0; j < stage; j++) r[i + 4 * neq] = r[i + 4 * neq] + d[j] * FF[i + j * neq]; r[i + 4 * neq] = r[i + 4 * neq] * dt; } } void densout(double *r, double t0, double t, double dt, double* res, int neq) { double s = (t - t0) / dt; double s1 = 1.0 - s; for (int i = 0; i < neq; i++) res[i] = r[i] + s * (r[i + neq] + s1 * (r[i + 2 * neq] + s * (r[i + 3 * neq] + s1 * (r[i + 4 * neq])))); } /*----------------------------------------------------------------------------*/ /* dense output for the Cash-Karp method - does not work (yet) */ /*----------------------------------------------------------------------------*/ void densoutck(double t0, double t, double dt, double* y0, double* FF, double* dy, double* res, int neq) { double s, s2, s3, s4, b1, b3, b4, b5, b6, b7; s = (t - t0) / dt; s2 = s * s; s3 = s2 * s; s4 = s3 * s; b3 = 500./161. * s2 - 20000./4347.* s3 + 2750./1449.* s4; b4 = 125./132. * s2 - 625./594. * s3 + 125./396. * s4; b5 = 15./28. * s2 - 15./14. * s3 + 15./28. * s4; b6 = -6144./1771. * s2 + 2048./253. * s3 - 7680./1771.* s4; b7 = 3./2. * s2 - 4. * s3 + 5./2. * s4; b1 = s-b3-b4-b5-b6-b7; for (int i = 0; i < neq; i++) res[i] = y0[i] + b1 * dt * FF[i + 0 * neq] + b3 * dt * FF[i + 2 * neq] + b4 * dt * FF[i + 3 * neq] + b5 * dt * FF[i + 4 * neq] + b6 * dt * FF[i + 5 * neq] + b7 * dt * dy[i]; } /*----------------------------------------------------------------------------*/ /* Polynomial interpolation */ /* ksig: number of signals */ /* n: number of knots per signal */ /* x[0 .. n-1]: vector of x values */ /* y[0 .. n-1, 0 .. ksig]: array of y values */ /*----------------------------------------------------------------------------*/ void neville(double *xx, double *y, double tnew, double *ynew, int n, int ksig) { int i, j, k; double x[n]; double yy[n * ksig]; /* temporary workspace */ double tscal = xx[n-1] - xx[0]; double t = tnew / tscal; for (i = 0; i < n; i++) x[i] = xx[i] / tscal; for (i = 0; i < n * ksig; i++) yy[i] = y[i]; for (k = 0; k < ksig; k++) { for (j = 1; j < n; j++) for (i = n - 1; i >= j; i--) { yy[i + k * n] = ((t - x[i - j]) * yy[i + k * n] - (t - x[i]) * yy[i - 1 + k * n]) / (x[i] - x[i - j]); } ynew[k] = yy[n - 1 + k * n]; } } /*============================================================================*/ /* Specific utility functions */ /*============================================================================*/ void shiftBuffer (double *x, int n, int k) { /* n = rows, k = columns */ for (int i = 0; i < (n - 1); i++) for (int j = 0; j < k; j++) x[i + j * n] = x[i + 1 + j * n]; } void setIstate(SEXP R_yout, SEXP R_istate, int *istate, int it_tot, int stage, int fsal, int qerr, int nrej) { /* karline: nsteps + 1 for "initial condition evaluation" */ /* note that indices are 1 smaller in C than in R */ istate[11] = it_tot; /* number of steps */ istate[12] = it_tot * (stage - fsal) + 1; /* number of function evaluations */ if (fsal) /* first same as last */ istate[12] = istate[12] + nrej + 1; /* one more fct. eval if rejected*/ istate[13] = nrej; /* number of rejected steps */ istate[14] = qerr; /* order of the method */ setAttrib(R_yout, install("istate"), R_istate); } deSolve/src/dsparsk.f0000644000176000001440000010156513564604217014330 0ustar ripleyusersC The code in this file is was taken from daspk.tgz from C https://www.netlib.org/ode/ C Authors: Brown, Hindmarsh, Petzold C originating from SPARSKIT, version 1 by Yousef Saad C Adapted for use in R package deSolve by the deSolve authors. C c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c BASIC LINEAR ALGEBRA FOR SPARSE MATRICES. BLASSM MODULE c c----------------------------------------------------------------------c c aplb : computes C = A+B c c aplb1 : computes C = A+B [Sorted version: A, B, C sorted] c c aplsb : computes C = A + s B c c diamua : Computes C = Diag * A c c amudia : Computes C = A* Diag c c aplsca : Computes A:= A + s I (s = scalar) c c----------------------------------------------------------------------c subroutine diamua (nrow,job, a, ja, ia, diag, b, jb, ib) real(kind=8) a(*), b(*), diag(nrow), scal integer ja(*),jb(*), ia(nrow+1),ib(nrow+1) c----------------------------------------------------------------------- c performs the matrix by matrix product B = Diag * A (in place) c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A c c job = integer. job indicator. Job=0 means get array b only c job = 1 means get b, and the integer arrays ib, jb. c c a, c ja, c ia = Matrix A in compressed sparse row format. c c diag = diagonal matrix stored as a vector dig(1:n) c c on return: c---------- c c b, c jb, c ib = resulting matrix B in compressed sparse row sparse format. c c Notes: c------- c 1) The column dimension of A is not needed. c 2) algorithm in place (B can take the place of A). c in this case use job=0. c----------------------------------------------------------------- do 1 ii=1,nrow c c normalize each row c k1 = ia(ii) k2 = ia(ii+1)-1 scal = diag(ii) do 2 k=k1, k2 b(k) = a(k)*scal 2 continue 1 continue c if (job .eq. 0) return c do 3 ii=1, nrow+1 ib(ii) = ia(ii) 3 continue do 31 k=ia(1), ia(nrow+1) -1 jb(k) = ja(k) 31 continue return c----------end-of-diamua------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c BASIC MATRIX-VECTOR OPERATIONS - MATVEC MODULE c c----------------------------------------------------------------------c c amux : A times a vector. Compressed Sparse Row (CSR) format. c c----------------------------------------------------------------------c c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c C INPUT-OUTPUT MODULE c c----------------------------------------------------------------------c c prtmt : prints matrices in the Boeing/Harwell format. c c----------------------------------------------------------------------c c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c FORMAT CONVERSION MODULE c c----------------------------------------------------------------------c c csrdns : converts a row-stored sparse matrix into the dense format. c c coocsr : converts coordinate to to csr format c c coicsr : in-place conversion of coordinate to csr format c c csrcoo : converts compressed sparse row to coordinate. c c csrcsc : converts compressed sparse row format to compressed sparse c c column format (transposition) c c csrcsc2 : rectangular version of csrcsc c c csrdia : converts a compressed sparse row format into a diagonal c c format. c c csrbnd : converts a compressed sparse row format into a banded c c format (linpack style). c c----------------------------------------------------------------------c subroutine csrcsc (n,job,ipos,a,ja,ia,ao,jao,iao) integer ia(n+1),iao(n+1),ja(*),jao(*) real(kind=8) a(*),ao(*) c----------------------------------------------------------------------- c Compressed Sparse Row to Compressed Sparse Column c c (transposition operation) Not in place. c----------------------------------------------------------------------- c -- not in place -- c this subroutine transposes a matrix stored in a, ja, ia format. c --------------- c on entry: c---------- c n = dimension of A. c job = integer to indicate whether to fill the values (job.eq.1) of the c matrix ao or only the pattern., i.e.,ia, and ja (job .ne.1) c c ipos = starting position in ao, jao of the transposed matrix. c the iao array takes this into account (thus iao(1) is set to ipos.) c Note: this may be useful if one needs to append the data structure c of the transpose to that of A. In this case use for example c call csrcsc (n,1,ia(n+1),a,ja,ia,a,ja,ia(n+2)) c for any other normal usage, enter ipos=1. c a = real array of length nnz (nnz=number of nonzero elements in input c matrix) containing the nonzero elements. c ja = integer array of length nnz containing the column positions c of the corresponding elements in a. c ia = integer of size n+1. ia(k) contains the position in a, ja of c the beginning of the k-th row. c c on return: c ---------- c output arguments: c ao = real array of size nzz containing the "a" part of the transpose c jao = integer array of size nnz containing the column indices. c iao = integer array of size n+1 containing the "ia" index array of c the transpose. c c----------------------------------------------------------------------- call csrcsc2 (n,n,job,ipos,a,ja,ia,ao,jao,iao) end subroutine csrcsc2 (n,n2,job,ipos,a,ja,ia,ao,jao,iao) integer ia(n+1),iao(n2+1),ja(*),jao(*) real(kind=8) a(*),ao(*) c----------------------------------------------------------------------- c Compressed Sparse Row to Compressed Sparse Column c c (transposition operation) Not in place. c----------------------------------------------------------------------- c Rectangular version. n is number of rows of CSR matrix, c n2 (input) is number of columns of CSC matrix. c----------------------------------------------------------------------- c -- not in place -- c this subroutine transposes a matrix stored in a, ja, ia format. c --------------- c on entry: c---------- c n = number of rows of CSR matrix. c n2 = number of columns of CSC matrix. c job = integer to indicate whether to fill the values (job.eq.1) of the c matrix ao or only the pattern., i.e.,ia, and ja (job .ne.1) c c ipos = starting position in ao, jao of the transposed matrix. c the iao array takes this into account (thus iao(1) is set to ipos.) c Note: this may be useful if one needs to append the data structure c of the transpose to that of A. In this case use for example c call csrcsc2 (n,n,1,ia(n+1),a,ja,ia,a,ja,ia(n+2)) c for any other normal usage, enter ipos=1. c a = real array of length nnz (nnz=number of nonzero elements in input c matrix) containing the nonzero elements. c ja = integer array of length nnz containing the column positions c of the corresponding elements in a. c ia = integer of size n+1. ia(k) contains the position in a, ja of c the beginning of the k-th row. c c on return: c ---------- c output arguments: c ao = real array of size nzz containing the "a" part of the transpose c jao = integer array of size nnz containing the column indices. c iao = integer array of size n+1 containing the "ia" index array of c the transpose. c c----------------------------------------------------------------------- c----------------- compute lengths of rows of transp(A) ---------------- do 1 i=1,n2+1 iao(i) = 0 1 continue do 3 i=1, n do 2 k=ia(i), ia(i+1)-1 j = ja(k)+1 iao(j) = iao(j)+1 2 continue 3 continue c---------- compute pointers from lengths ------------------------------ iao(1) = ipos do 4 i=1,n2 iao(i+1) = iao(i) + iao(i+1) 4 continue c--------------- now do the actual copying ----------------------------- do 6 i=1,n do 62 k=ia(i),ia(i+1)-1 j = ja(k) next = iao(j) if (job .eq. 1) ao(next) = a(k) jao(next) = i iao(j) = next+1 62 continue 6 continue c-------------------------- reshift iao and leave ---------------------- do 7 i=n2,1,-1 iao(i+1) = iao(i) 7 continue iao(1) = ipos c--------------- end of csrcsc2 ---------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c UNARY SUBROUTINES MODULE c c----------------------------------------------------------------------c c rperm : permutes the rows of a matrix (B = P A) c c cperm : permutes the columns of a matrix (B = A Q) c c dperm : permutes both the rows and columns of a matrix (B = P A Q ) c c dvperm : permutes a real vector (in-place) c c ivperm : permutes an integer vector (in-place) c c diapos : returns the positions of the diagonal elements in A. c c getbwd : returns the bandwidth information on a matrix. c c infdia : obtains information on the diagonals of A. c c rnrms : computes the norms of the rows of A c c roscal : scales the rows of a matrix by their norms. c c----------------------------------------------------------------------c subroutine rperm (nrow,a,ja,ia,ao,jao,iao,perm,job) integer nrow,ja(*),ia(nrow+1),jao(*),iao(nrow+1),perm(nrow),job real(kind=8) a(*),ao(*) c----------------------------------------------------------------------- c this subroutine permutes the rows of a matrix in CSR format. c rperm computes B = P A where P is a permutation matrix. c the permutation P is defined through the array perm: for each j, c perm(j) represents the destination row number of row number j. c Youcef Saad -- recoded Jan 28, 1991. c----------------------------------------------------------------------- c on entry: c---------- c n = dimension of the matrix c a, ja, ia = input matrix in csr format c perm = integer array of length nrow containing the permutation arrays c for the rows: perm(i) is the destination of row i in the c permuted matrix. c ---> a(i,j) in the original matrix becomes a(perm(i),j) c in the output matrix. c c job = integer indicating the work to be done: c job = 1 permute a, ja, ia into ao, jao, iao c (including the copying of real values ao and c the array iao). c job .ne. 1 : ignore real values. c (in which case arrays a and ao are not needed nor c used). c c------------ c on return: c------------ c ao, jao, iao = input matrix in a, ja, ia format c note : c if (job.ne.1) then the arrays a and ao are not used. c----------------------------------------------------------------------c c Y. Saad, May 2, 1990 c c----------------------------------------------------------------------c logical values values = (job .eq. 1) c c determine pointers for output matix. c do 50 j=1,nrow i = perm(j) iao(i+1) = ia(j+1) - ia(j) 50 continue c c get pointers from lengths c iao(1) = 1 do 51 j=1,nrow iao(j+1)=iao(j+1)+iao(j) 51 continue c c copying c do 100 ii=1,nrow c c old row = ii -- new row = iperm(ii) -- ko = new pointer c ko = iao(perm(ii)) do 60 k=ia(ii), ia(ii+1)-1 jao(ko) = ja(k) if (values) ao(ko) = a(k) ko = ko+1 60 continue 100 continue c return c---------end-of-rperm ------------------------------------------------- c----------------------------------------------------------------------- end subroutine cperm (nrow,a,ja,ia,ao,jao,iao,perm,job) integer nrow,ja(*),ia(nrow+1),jao(*),iao(nrow+1),perm(*), job real(kind=8) a(*), ao(*) c----------------------------------------------------------------------- c this subroutine permutes the columns of a matrix a, ja, ia. c the result is written in the output matrix ao, jao, iao. c cperm computes B = A P, where P is a permutation matrix c that maps column j into column perm(j), i.e., on return c a(i,j) becomes a(i,perm(j)) in new matrix c Y. Saad, May 2, 1990 / modified Jan. 28, 1991. c----------------------------------------------------------------------- c on entry: c---------- c nrow = row dimension of the matrix c c a, ja, ia = input matrix in csr format. c c perm = integer array of length ncol (number of columns of A c containing the permutation array the columns: c a(i,j) in the original matrix becomes a(i,perm(j)) c in the output matrix. c c job = integer indicating the work to be done: c job = 1 permute a, ja, ia into ao, jao, iao c (including the copying of real values ao and c the array iao). c job .ne. 1 : ignore real values ao and ignore iao. c c------------ c on return: c------------ c ao, jao, iao = input matrix in a, ja, ia format (array ao not needed) c c Notes: c------- c 1. if job=1 then ao, iao are not used. c 2. This routine is in place: ja, jao can be the same. c 3. If the matrix is initially sorted (by increasing column number) c then ao,jao,iao may not be on return. c c----------------------------------------------------------------------c c local parameters: integer k, i, nnz c nnz = ia(nrow+1)-1 do 100 k=1,nnz jao(k) = perm(ja(k)) 100 continue c c done with ja array. return if no need to touch values. c if (job .ne. 1) return c c else get new pointers -- and copy values too. c do 1 i=1, nrow+1 iao(i) = ia(i) 1 continue c do 2 k=1, nnz ao(k) = a(k) 2 continue c return c---------end-of-cperm-------------------------------------------------- c----------------------------------------------------------------------- end subroutine diapos (n,ja,ia,idiag) integer ia(n+1), ja(*), idiag(n) c----------------------------------------------------------------------- c this subroutine returns the positions of the diagonal elements of a c sparse matrix a, ja, ia, in the array idiag. c----------------------------------------------------------------------- c on entry: c---------- c c n = integer. row dimension of the matrix a. c a,ja, c ia = matrix stored compressed sparse row format. a array skipped. c c on return: c----------- c idiag = integer array of length n. The i-th entry of idiag c points to the diagonal element a(i,i) in the arrays c a, ja. (i.e., a(idiag(i)) = element A(i,i) of matrix A) c if no diagonal element is found the entry is set to 0. c----------------------------------------------------------------------c c Y. Saad, March, 1990 c----------------------------------------------------------------------c do 1 i=1, n idiag(i) = 0 1 continue c c sweep through data structure. c do 6 i=1,n do 51 k= ia(i),ia(i+1) -1 if (ja(k) .eq. i) idiag(i) = k 51 continue 6 continue c----------- -end-of-diapos--------------------------------------------- c----------------------------------------------------------------------- return end subroutine getbwd(n,a,ja,ia,ml,mu) c----------------------------------------------------------------------- c gets the bandwidth of lower part and upper part of A. c does not assume that A is sorted. c----------------------------------------------------------------------- c on entry: c---------- c n = integer = the row dimension of the matrix c a, ja, c ia = matrix in compressed sparse row format. c c on return: c----------- c ml = integer. The bandwidth of the strict lower part of A c mu = integer. The bandwidth of the strict upper part of A c c Notes: c ===== ml and mu are allowed to be negative or return. This may be c useful since it will tell us whether a band is confined c in the strict upper/lower triangular part. c indeed the definitions of ml and mu are c c ml = max ( (i-j) s.t. a(i,j) .ne. 0 ) c mu = max ( (j-i) s.t. a(i,j) .ne. 0 ) c----------------------------------------------------------------------c c Y. Saad, Sep. 21 1989 c c----------------------------------------------------------------------c real(kind=8) a(*) integer ja(*),ia(n+1),ml,mu,ldist,i,k ml = - n mu = - n do 3 i=1,n do 31 k=ia(i),ia(i+1)-1 ldist = i-ja(k) ml = max(ml,ldist) mu = max(mu,-ldist) 31 continue 3 continue return c---------------end-of-getbwd ------------------------------------------ c----------------------------------------------------------------------- end subroutine infdia (n,ja,ia,ind,idiag) integer ia(*), ind(*), ja(*) c----------------------------------------------------------------------- c obtains information on the diagonals of A. c----------------------------------------------------------------------- c this subroutine finds the lengths of each of the 2*n-1 diagonals of A c it also outputs the number of nonzero diagonals found. c----------------------------------------------------------------------- c on entry: c---------- c n = dimension of the matrix a. c c a, ..... not needed here. c ja, c ia = matrix stored in csr format c c on return: c----------- c c idiag = integer. number of nonzero diagonals found. c c ind = integer array of length at least 2*n-1. The k-th entry in c ind contains the number of nonzero elements in the diagonal c number k, the numbering beeing from the lowermost diagonal c (bottom-left). In other words ind(k) = length of diagonal c whose offset wrt the main diagonal is = - n + k. c----------------------------------------------------------------------c c Y. Saad, Sep. 21 1989 c c----------------------------------------------------------------------c n2= n+n-1 do 1 i=1,n2 ind(i) = 0 1 continue do 3 i=1, n do 2 k=ia(i),ia(i+1)-1 j = ja(k) ind(n+j-i) = ind(n+j-i) +1 2 continue 3 continue c count the nonzero ones. idiag = 0 do 41 k=1, n2 if (ind(k) .ne. 0) idiag = idiag+1 41 continue return c done c------end-of-infdia --------------------------------------------------- c----------------------------------------------------------------------- end subroutine rnrms (nrow, nrm, a, ja, ia, diag) real(kind=8) a(*), diag(nrow), scal integer ja(*), ia(nrow+1) c----------------------------------------------------------------------- c gets the norms of each row of A. (choice of three norms) c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A c c nrm = integer. norm indicator. nrm = 1, means 1-norm, nrm =2 c means the 2-nrm, nrm = 0 means max norm c c a, c ja, c ia = Matrix A in compressed sparse row format. c c on return: c---------- c c diag = real vector of length nrow containing the norms c c----------------------------------------------------------------- do 1 ii=1,nrow c c compute the norm if each element. c scal = 0.0d0 k1 = ia(ii) k2 = ia(ii+1)-1 if (nrm .eq. 0) then do 2 k=k1, k2 scal = max(scal,abs(a(k) ) ) 2 continue elseif (nrm .eq. 1) then do 3 k=k1, k2 scal = scal + abs(a(k) ) 3 continue else do 4 k=k1, k2 scal = scal+a(k)**2 4 continue endif if (nrm .eq. 2) scal = sqrt(scal) diag(ii) = scal 1 continue return c----------------------------------------------------------------------- c-------------end-of-rnrms---------------------------------------------- end c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c ITERATIVE SOLVERS MODULE c c----------------------------------------------------------------------c c ILUT : Incomplete LU factorization with dual truncation strategy c c ILUTP : ILUT with column pivoting c c LUSOL : forward followed by backward triangular solve (Precond.) c c QSPLIT : quick split routine used by ilut to sort out the k largest c c elements in absolute value c c----------------------------------------------------------------------c subroutine qsplit(a,ind,n,ncut) real(kind=8) a(n) integer ind(n), n, ncut c----------------------------------------------------------------------- c does a quick-sort split of a real array. c on input a(1:n). is a real array c on output a(1:n) is permuted such that its elements satisfy: c c abs(a(i)) .ge. abs(a(ncut)) for i .lt. ncut and c abs(a(i)) .le. abs(a(ncut)) for i .gt. ncut c c ind(1:n) is an integer array which permuted in the same way as a(*). c----------------------------------------------------------------------- real(kind=8) tmp, abskey integer itmp, first, last c----- first = 1 last = n if (ncut .lt. first .or. ncut .gt. last) return c c outer loop -- while mid .ne. ncut do c 1 mid = first abskey = abs(a(mid)) do 2 j=first+1, last if (abs(a(j)) .gt. abskey) then mid = mid+1 c interchange tmp = a(mid) itmp = ind(mid) a(mid) = a(j) ind(mid) = ind(j) a(j) = tmp ind(j) = itmp endif 2 continue c c interchange c tmp = a(mid) a(mid) = a(first) a(first) = tmp c itmp = ind(mid) ind(mid) = ind(first) ind(first) = itmp c c test for while loop c if (mid .eq. ncut) return if (mid .gt. ncut) then last = mid-1 else first = mid+1 endif goto 1 c----------------end-of-qsplit------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c REORDERING ROUTINES -- LEVEL SET BASED ROUTINES c c----------------------------------------------------------------------c c dblstr : doubled stripe partitioner c BFS : Breadth-First search traversal algorithm c add_lvst : routine to add a level -- used by BFS c stripes : finds the level set structure c perphn : finds a pseudo-peripheral node and performs a BFS from it. c rversp : routine to reverse a given permutation (e.g., for RCMK) c maskdeg : integer function to compute the `masked' of a node c----------------------------------------------------------------------- subroutine BFS(n,ja,ia,nfirst,iperm,mask,maskval,riord,levels, * nlev) implicit none integer n,ja(*),ia(*),nfirst,iperm(n),mask(n),riord(*),levels(*), * nlev,maskval c----------------------------------------------------------------------- c finds the level-structure (breadth-first-search or CMK) ordering for a c given sparse matrix. Uses add_lvst. Allows an set of nodes to be c the initial level (instead of just one node). c-------------------------parameters------------------------------------ c on entry: c--------- c n = number of nodes in the graph c ja, ia = pattern of matrix in CSR format (the ja,ia arrays of csr data c structure) c nfirst = number of nodes in the first level that is input in riord c iperm = integer array indicating in which order to traverse the graph c in order to generate all connected components. c if iperm(1) .eq. 0 on entry then BFS will traverse the nodes c in the order 1,2,...,n. c c riord = (also an ouput argument). On entry riord contains the labels c of the nfirst nodes that constitute the first level. c c mask = array used to indicate whether or not a node should be c condidered in the graph. see maskval. c mask is also used as a marker of visited nodes. c c maskval= consider node i only when: mask(i) .eq. maskval c maskval must be .gt. 0. c thus, to consider all nodes, take mask(1:n) = 1. c maskval=1 (for example) c c on return c --------- c mask = on return mask is restored to its initial state. c riord = `reverse permutation array'. Contains the labels of the nodes c constituting all the levels found, from the first level to c the last. c levels = pointer array for the level structure. If lev is a level c number, and k1=levels(lev),k2=levels(lev+1)-1, then c all the nodes of level number lev are: c riord(k1),riord(k1+1),...,riord(k2) c nlev = number of levels found c----------------------------------------------------------------------- c integer j, ii, nod, istart, iend logical permut permut = (iperm(1) .ne. 0) c c start pointer structure to levels c nlev = 0 c c previous end c istart = 0 ii = 0 c c current end c iend = nfirst c c intialize masks to zero -- except nodes of first level -- c do 12 j=1, nfirst mask(riord(j)) = 0 12 continue c----------------------------------------------------------------------- continue c 1 nlev = nlev+1 levels(nlev) = istart + 1 call add_lvst (istart,iend,nlev,riord,ja,ia,mask,maskval) if (istart .lt. iend) goto 1 2 ii = ii+1 if (ii .le. n) then nod = ii if (permut) nod = iperm(nod) if (mask(nod) .eq. maskval) then c c start a new level c istart = iend iend = iend+1 riord(iend) = nod mask(nod) = 0 goto 1 else goto 2 endif endif c----------------------------------------------------------------------- levels(nlev+1) = iend+1 do j=1, iend mask(riord(j)) = maskval enddo c----------------------------------------------------------------------- return end subroutine add_lvst(istart,iend,nlev,riord,ja,ia,mask,maskval) integer nlev, nod, riord(*), ja(*), ia(*), mask(*) c------------------------------------------------------------- c adds one level set to the previous sets.. c span all nodes of previous mask c------------------------------------------------------------- nod = iend do 25 ir = istart+1,iend i = riord(ir) do 24 k=ia(i),ia(i+1)-1 j = ja(k) if (mask(j) .eq. maskval) then nod = nod+1 mask(j) = 0 riord(nod) = j endif 24 continue 25 continue istart = iend iend = nod return end subroutine stripes (nlev,riord,levels,ip,map,mapptr,ndom) implicit none integer nlev,riord(*),levels(nlev+1),ip,map(*), * mapptr(*), ndom c----------------------------------------------------------------------- c this is a post processor to BFS. stripes uses the output of BFS to c find a decomposition of the adjacency graph by stripes. It fills c the stripes level by level until a number of nodes .gt. ip is c is reached. c---------------------------parameters----------------------------------- c on entry: c -------- c nlev = number of levels as found by BFS c riord = reverse permutation array produced by BFS -- c levels = pointer array for the level structure as computed by BFS. If c lev is a level number, and k1=levels(lev),k2=levels(lev+1)-1, c then all the nodes of level number lev are: c riord(k1),riord(k1+1),...,riord(k2) c ip = number of desired partitions (subdomains) of about equal size. c c on return c --------- c ndom = number of subgraphs (subdomains) found c map = node per processor list. The nodes are listed contiguously c from proc 1 to nproc = mpx*mpy. c mapptr = pointer array for array map. list for proc. i starts at c mapptr(i) and ends at mapptr(i+1)-1 in array map. c----------------------------------------------------------------------- c local variables. c integer ib,ktr,ilev,k,nsiz,psiz ndom = 1 ib = 1 c to add: if (ip .le. 1) then ... nsiz = levels(nlev+1) - levels(1) psiz = (nsiz-ib)/max(1,(ip - ndom + 1)) + 1 mapptr(ndom) = ib ktr = 0 do 10 ilev = 1, nlev c c add all nodes of this level to domain c do 3 k=levels(ilev), levels(ilev+1)-1 map(ib) = riord(k) ib = ib+1 ktr = ktr + 1 if (ktr .ge. psiz .or. k .ge. nsiz) then ndom = ndom + 1 mapptr(ndom) = ib psiz = (nsiz-ib)/max(1,(ip - ndom + 1)) + 1 ktr = 0 endif c 3 continue 10 continue ndom = ndom-1 return end integer function maskdeg (ja,ia,nod,mask,maskval) implicit none integer ja(*),ia(*),nod,mask(*),maskval c----------------------------------------------------------------------- integer deg, k deg = 0 do k =ia(nod),ia(nod+1)-1 if (mask(ja(k)) .eq. maskval) deg = deg+1 enddo maskdeg = deg return end subroutine perphn(n,ja,ia,init,mask,maskval,nlev,riord,levels) implicit none integer n,ja(*),ia(*),init,mask(*),maskval, * nlev,riord(*),levels(*) c----------------------------------------------------------------------- c finds a peripheral node and does a BFS search from it. c----------------------------------------------------------------------- c see routine dblstr for description of parameters c input: c------- c ja, ia = list pointer array for the adjacency graph c mask = array used for masking nodes -- see maskval c maskval = value to be checked against for determing whether or c not a node is masked. If mask(k) .ne. maskval then c node k is not considered. c init = init node in the pseudo-peripheral node algorithm. c c output: c------- c init = actual pseudo-peripherial node found. c nlev = number of levels in the final BFS traversal. c riord = c levels = c----------------------------------------------------------------------- integer j,nlevp,deg,nfirst,mindeg,nod,maskdeg integer iperm(1) nlevp = 0 1 continue riord(1) = init nfirst = 1 iperm(1) = 0 c call BFS(n,ja,ia,nfirst,iperm,mask,maskval,riord,levels,nlev) if (nlev .gt. nlevp) then mindeg = n+1 do j=levels(nlev),levels(nlev+1)-1 nod = riord(j) deg = maskdeg(ja,ia,nod,mask,maskval) if (deg .lt. mindeg) then init = nod mindeg = deg endif enddo nlevp = nlev goto 1 endif return end c----------------------------------------------------------------------c c Non-SPARSKIT utility routine c----------------------------------------------------------------------c deSolve/src/ex_CCL4model.c0000644000176000001440000000775013136461013015047 0ustar ripleyusers/* c the CCl4 inhalation model -------- ex_ccl4model.c -> ex_ccl4model.dll ------ compile in R with: system("gcc -shared -o ex_ccl4model.dll ex_ccl4model.c") or with system("R CMD SHLIB ex_ccl4model.c") */ #include static double parms[21]; #define BW parms[0] #define QP parms[1] #define QC parms[2] #define VFC parms[3] #define VLC parms[4] #define VMC parms[5] #define QFC parms[6] #define QLC parms[7] #define QMC parms[8] #define PLA parms[9] #define PFA parms[10] #define PMA parms[11] #define PTA parms[12] #define PB parms[13] #define MW parms[14] #define VMAX parms[15] #define KM parms[16] #define CONC parms[17] #define KL parms[18] #define RATS parms[19] #define VCHC parms[20] double V[5], P[4], AI0, VTC, Q[4]; #define DOSE out[0] #define MASS out[1] #define CP out[2] /* c======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= 2c Initialise primary parameter common block c======================================================================= */ void initccl4(void (* odeparms)(int *, double *)) { void derived(); int N=21; odeparms(&N, parms); derived(); } /*======================================================================= In this "event", state variable 1 is increased with 1. DOES NOT WORK... ======================================================================= */ void eventfun(int *n, double *t, double *y) { y[0] = y[0] + 1; } /*======================================================================= c Calculate derived parameters from primary parameters c======================================================================= */ void derived () { // Fraction viscera (kg/(kg BW)) VTC = 0.91 - (VLC+VFC+VMC); // Net chamber volume V[0] = VCHC - RATS*BW; V[1] = VMC*BW; V[2] = VTC*BW; V[3] = VFC*BW; V[4] = VLC*BW; // Initial amt. in chamber (mg) AI0 = CONC*V[0]*MW/24450.; P[0] = PMA/PB; P[1] = PTA/PB; P[2] = PFA/PB; P[3] = PLA/PB; Q[2] = QFC*QC; Q[3] = QLC*QC; Q[0] = QMC*QC; Q[1] = QC - (Q[0]+Q[3]+Q[2]); } /*======================================================================= c The dynamic model c======================================================================= */ void derivsccl4 (int *neq, double *t, double *y, double *ydot, double *out, int *ip) { double vconc[5], tconc[5], CA, CX, RAM; int i; if (ip[0] < 3) error("nout should be at least 3"); /*c y = AI, AAM, AT, AF, AL CLT, AM where clt = the area under the concentration-time curve in the liver AM = total amount metabolised concentrations */ for (i =0; i<5; i++) { tconc[i] = y[i]/V[i]; } /* vconc(1) is conc in mixed venous blood */ vconc[0] = 0.0; for (i = 1; i<5; i++){ vconc[i] = tconc[i]/P[i-1]; vconc[0] = vconc[0] + vconc[i]*Q[i-1]/QC ; } /* CA is conc in arterial blood */ CA = (QC * vconc[0] + QP * tconc[0])/ (QC + QP/PB); /* Exhaled chemical */ CX = CA/PB; /* metabolisation rate */ RAM = VMAX*vconc[4]/(KM + vconc[4]); /* the rate of change */ ydot[0] = RATS*QP*(CX - tconc[0]) - KL*y[0]; for ( i = 1; i<5; i++) ydot[i] = Q[i-1]*(CA-vconc[i]); ydot[4] = ydot[4] - RAM; ydot[5] = tconc[4]; ydot[6] = RAM; /* the mass balance (MASS=AAM+AT+AF+AL+AM), should be constant */ DOSE = AI0 - y[0]; MASS = (y[1]+y[2]+y[3]+y[4]+y[6])*RATS; CP = tconc[0]*24450.0/MW; } deSolve/src/forcings.c0000644000176000001440000002252213274246442014463 0ustar ripleyusers/* deals with forcing functions and events; Karline Soetaert */ #include "deSolve.h" #include "externalptr.h" /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Forcing functions (compiled code) from deSolve version 1.5 Events (R- and compiled code) from deSolve version 1.6 **FORCING FUNCTIONS**, or external variables need to be interpolated at each time step. This is done in this part of C-code. "initForcings" creates forcing function vectors passed from an R-list "initforcings" puts a pointer to the vector that contains the forcing functions in the DLL. This is done by calling "Initdeforc"; here the C-globals are initialised . Each time-step, before entering the compiled code, the forcing function variables are interpolated to the current time (function ("updateforc"). **EVENTS** occur when the value of state variables change abruptly. This cannot be easily handled in the integrators, where state variables change via the derivatives only. Events are either specified in a data.frame, or via an event function, specified in R-code or in compiled code. For events, specified in R-code, function "C_event_func" provides the C-interface. "initEvents" creates initialises the events, based on information passed from an R-list. Each time-step, it is tested whether an event occurs ("updateevent") version 1.11: certain roots associated to eventa can terminate simulation +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ int finit = 0; /*=========================================================================== ----- Check for presence of forcing functions ----- function "initForcings" checks if forcing functions are present and if so, create the vectors that contain the times (Tvec), the forcing values (Fvec) the start position of each forcing function variable (Ivec), and the interpolation method (fmethod). =========================================================================== */ int initForcings(SEXP flist) { SEXP Tvec, Fvec, Ivec, initforc; int i, j, isForcing = 0; init_func_type *initforcings; initforc = getListElement(flist, "ModelForc"); if (!isNull(initforc)) { Tvec = getListElement(flist, "tmat"); Fvec = getListElement(flist, "fmat"); Ivec = getListElement(flist, "imat"); nforc = LENGTH(Ivec)-2; /* nforc, fvec, ivec = globals */ i = LENGTH(Fvec); fvec = (double *) R_alloc((int) i, sizeof(double)); for (j = 0; j < i; j++) fvec[j] = REAL(Fvec)[j]; tvec = (double *) R_alloc((int) i, sizeof(double)); for (j = 0; j < i; j++) tvec[j] = REAL(Tvec)[j]; i = LENGTH (Ivec)-1; /* last element: the interpolation method...*/ ivec = (int *) R_alloc(i, sizeof(int)); for (j = 0; j < i; j++) ivec[j] = INTEGER(Ivec)[j]; fmethod = INTEGER(Ivec)[i]; initforcings = (init_func_type *) R_ExternalPtrAddrFn_(initforc); initforcings(Initdeforc); isForcing = 1; } return(isForcing); } /*=========================================================================== ----- INITIALISATION called from compiled code ----- 1. Check the length of forcing functions in solver call and code in DLL 2. Initialise the forcing function vectors 3. set pointer to DLL; FORTRAN common block or C globals / =========================================================================== */ void Initdeforc(int *N, double *forc) { int i, ii; if ((*N) != nforc) { warning("Number of forcings passed to solver, %i; number in DLL, %i\n",nforc, *N); PROBLEM "Confusion over the length of forc" ERROR; } /* for each forcing function: index to current position of data, current value, interpolation factor, current forcing time, next forcing time,.. */ finit = 1; findex = (int *) R_alloc(nforc, sizeof(int)); intpol = (double *) R_alloc(nforc, sizeof(double)); maxindex = (int *) R_alloc(nforc, sizeof(int)); /* Input is in three vectors: tvec, fvec: time and value; ivec : index to each forcing in tvec and fvec */ for (i = 0; i tvec[ii+1]){ if (ii+2 > maxindex[i]) { /* this probably redundant...*/ zerograd=1; break; } ii = ii+1; } while (*time < tvec[ii]){ /* test here for ii < 1 ?...*/ ii = ii-1; } if (ii != findex[i]) { findex[i] = ii; if ((zerograd == 0) & (fmethod == 1)) { /* fmethod 1=linear */ intpol[i] = (fvec[ii+1]-fvec[ii])/(tvec[ii+1]-tvec[ii]); } else { intpol[i] = 0; } } forcings[i]=fvec[ii]+intpol[i]*(*time-tvec[ii]); } } /* ============================================================================ events: time, svar number, value, and method; in a list ==========================================================================*/ typedef void event_func_type(int*, double*, double*); event_func_type *event_func; static void C_event_func (int *n, double *t, double *y) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < *n; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); PROTECT(R_fcall = lang3(R_event_func,Time,Y)); PROTECT(ans = eval(R_fcall, R_envir)); for (i = 0; i < *n; i++) y[i] = REAL(ans)[i]; UNPROTECT(3); } int initEvents(SEXP elist, SEXP eventfunc, int nroot) { SEXP Time, SVar, Value, Method, Type, Root, maxRoot, Terminateroot; int i, j, isEvent = 0; Time = getListElement(elist, "Time"); Root = getListElement(elist, "Root"); if (!isNull(Root)) { /* event combined with root - allocate memory to save time of root*/ rootevent = INTEGER(Root)[0]; maxRoot = getListElement(elist, "Rootsave"); if (!isNull(maxRoot)) Rootsave = INTEGER(maxRoot)[0]; else Rootsave = 0; if (Rootsave > 0) { nrroot = (int *)R_alloc( (int)Rootsave, sizeof(int) ); for (i = 0; i < Rootsave; i++) nrroot[i] = 0; troot = (double *)R_alloc( (int)Rootsave, sizeof(double) ); for (i = 0; i < Rootsave; i++) troot[i] = 0.; valroot = (double *)R_alloc( (int)Rootsave*n_eq, sizeof(double) ); for (i = 0; i < Rootsave*n_eq; i++) valroot[i] = 0.; } /* to allow certain roots to stop simulation */ termroot = (int *)R_alloc( nroot, sizeof(int) ); for (i = 0; i < nroot; i++) termroot[i] = 0; Terminateroot = getListElement(elist, "Terminalroot"); for (i = 0; i < LENGTH(Terminateroot); i++) { j = INTEGER(Terminateroot)[i]-1; if (j > -1 && j < nroot) termroot[j] = 1; } } else rootevent = 0; if (!isNull(Time)) { isEvent = 1; Type = getListElement(elist,"Type"); typeevent = INTEGER(Type)[0]; i = LENGTH(Time); timeevent = (double *) R_alloc((int) i+1, sizeof(double)); for (j = 0; j < i; j++) timeevent[j] = REAL(Time)[j]; /* cap the event timer with an event that can't possibly be reached */ //timeevent[i] = timeevent[0] - 1; // J. Stott timeevent[i] = DOUBLE_XMIN; // thpe if (typeevent == 1) { /* specified in a data.frame */ SVar = getListElement(elist,"SVar"); Value = getListElement(elist,"Value"); Method = getListElement(elist,"Method"); valueevent = (double *) R_alloc((int) i, sizeof(double)); for (j = 0; j < i; j++) valueevent[j] = REAL(Value)[j]; svarevent = (int *) R_alloc(i, sizeof(int)); for (j = 0; j < i; j++) svarevent[j] = INTEGER(SVar)[j]-1; methodevent = (int *) R_alloc(i, sizeof(int)); for (j = 0; j < i; j++) methodevent[j] = INTEGER(Method)[j]; } else { /* a function: either R (typeevent=2) or compiled code (3)... */ if (typeevent == 3) { event_func = (event_func_type *) R_ExternalPtrAddrFn_(eventfunc); } else { event_func = C_event_func; R_event_func = eventfunc; } } tEvent = timeevent[0]; iEvent = 0; nEvent = i; } return(isEvent); } void updateevent(double *t, double *y, int *istate) { int svar, method; double value; if (tEvent == *t) { if (typeevent == 1) { /* specified in a data.frame */ do { svar = svarevent[iEvent]; method = methodevent[iEvent]; value = valueevent[iEvent]; if (method == 1) y[svar] = value; else if (method == 2) y[svar] = y[svar] + value; else if (method == 3) y[svar] = y[svar] * value; tEvent = timeevent[++iEvent]; } while (tEvent == *t); } else { /* a root event or specific times */ event_func(&n_eq, t, y); if (!rootevent) tEvent = timeevent[++iEvent]; /* karline: this was toggled off - why?*/ } *istate = 1; } } deSolve/src/call_zvode.c0000644000176000001440000002604213274246353014775 0ustar ripleyusers/* complex number vode */ #include #include #include "deSolve.h" #include "zvode.h" #include "externalptr.h" /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Ordinary differential equation solver for complex state variables, zvode. The C-wrappers that provide the interface between FORTRAN codes and R-code are: C_zderiv_func: interface with R-code "func", passes derivatives C_zjac_func : interface with R-code "jacfunc", passes jacobian (except lsodes) C_zderiv_func_forc provides the interface between the function specified in a DLL and the integrator, in case there are forcing functions. Events and roots are not implemented for zvode changes since 1.4 karline: version 1.5: added forcing functions in DLL improving names +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ SEXP R_zderiv_func; SEXP R_zjac_func; SEXP R_vode_envir; /* definition of the call to the FORTRAN function dvode - in file zvode.f*/ void F77_NAME(zvode)(void (*)(int *, double *, Rcomplex *, Rcomplex *, Rcomplex *, int *), int *, Rcomplex *, double *, double *, int *, double *, double *, int *, int *, int *, Rcomplex *, int*, double *, int *,int *, int *, void (*)(int *, double *, Rcomplex *, int *, int *, Rcomplex *, int *, Rcomplex*, int*), int *, Rcomplex *, int *); /* interface between FORTRAN function call and R function Fortran code calls cvode_derivs(N, t, y, ydot, yout, iout) R code called as R_zderiv_func(time, y) and returns ydot Note: passing of parameter values and "..." is done in R-function zvode*/ static void C_zderiv_func (int *neq, double *t, Rcomplex *y, Rcomplex *ydot, Rcomplex *yout, int *iout) { int i; SEXP R_fcall, Time, ans; int nprot = 0; for (i = 0; i < *neq; i++) COMPLEX(cY)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); nprot++; PROTECT(R_fcall = lang3(R_zderiv_func,Time,cY)); nprot++; PROTECT(ans = eval(R_fcall, R_vode_envir)); nprot++; for (i = 0; i < *neq; i++) ydot[i] = COMPLEX(VECTOR_ELT(ans,0))[i]; UNPROTECT(nprot); } /* interface between FORTRAN call to jacobian and R function */ static void C_zjac_func (int *neq, double *t, Rcomplex *y, int *ml, int *mu, Rcomplex *pd, int *nrowpd, Rcomplex *yout, int *iout) { int i; SEXP R_fcall, Time, ans; int nprot = 0; for (i = 0; i < *neq; i++) COMPLEX(cY)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); nprot++; PROTECT(R_fcall = lang3(R_zjac_func,Time,cY)); nprot++; PROTECT(ans = eval(R_fcall, R_vode_envir)); nprot++; for (i = 0; i < *neq * *nrowpd; i++) pd[i ] = COMPLEX(ans)[i ]; UNPROTECT(nprot); } /* wrapper above the derivate function that first estimates the values of the forcing functions */ static void C_zderiv_func_forc (int *neq, double *t, Rcomplex *y, Rcomplex *ydot, Rcomplex *yout, int *iout) { updatedeforc(t); DLL_cderiv_func(neq, t, y, ydot, yout, iout); } /* give name to data types */ typedef void C_zjac_func_type(int *, double *, Rcomplex *, int *, int *, Rcomplex *, int *, Rcomplex *, int *); /* MAIN C-FUNCTION, CALLED FROM R-code */ SEXP call_zvode(SEXP y, SEXP times, SEXP derivfunc, SEXP parms, SEXP rtol, SEXP atol, SEXP rho, SEXP tcrit, SEXP jacfunc, SEXP initfunc, SEXP iTask, SEXP rWork, SEXP iWork, SEXP jT, SEXP nOut, SEXP lZw, SEXP lRw, SEXP lIw, SEXP Rpar, SEXP Ipar, SEXP flist) { /******************************************************************************/ /****** DECLARATION SECTION ******/ /******************************************************************************/ int i, j, k, nt, latol, lrtol, lrw, liw, lzw; double tin, tout, *Atol, *Rtol, ss; int neq, itol, itask, istate, iopt, jt, //mflag, is, isDll, isForcing; Rcomplex *xytmp, *dy = NULL, *zwork; int *iwork, it, ntot, nout; double *rwork; C_zderiv_func_type *zderiv_func; C_zjac_func_type *zjac_func = NULL; /******************************************************************************/ /****** STATEMENTS ******/ /******************************************************************************/ lock_solver(); /* prevent nested call of solvers that have global variables */ /* #### initialisation #### */ int nprot = 0; jt = INTEGER(jT)[0]; neq = LENGTH(y); nt = LENGTH(times); nout = INTEGER(nOut)[0]; /* The output: zout and ipar are used to pass output variables (number set by nout) followed by other input (e.g. forcing functions) provided by R-arguments rpar, ipar ipar[0]: number of output variables, ipar[1]: length of rpar, ipar[2]: length of ipar */ /* is function a dll ?*/ if (inherits(derivfunc, "NativeSymbol")) { isDll = 1; } else { isDll = 0; } /* initialise output for Complex variables ... */ initOutComplex(isDll, &nout, &ntot, neq, nOut, Rpar, Ipar); /* copies of all variables that will be changed in the FORTRAN subroutine */ xytmp = (Rcomplex *) R_alloc(neq, sizeof(Rcomplex)); for (j = 0; j < neq; j++) xytmp[j] = COMPLEX(y)[j]; latol = LENGTH(atol); Atol = (double *) R_alloc((int) latol, sizeof(double)); for (j = 0; j < latol; j++) Atol[j] = REAL(atol)[j]; lrtol = LENGTH(rtol); Rtol = (double *) R_alloc((int) lrtol, sizeof(double)); for (j = 0; j < lrtol; j++) Rtol[j] = REAL(rtol)[j]; liw = INTEGER(lIw)[0]; iwork = (int *) R_alloc(liw, sizeof(int)); for (j = 0; j < 30; j++) iwork[j] = INTEGER(iWork)[j]; lrw = INTEGER(lRw)[0]; rwork = (double *) R_alloc(lrw, sizeof(double)); for (j = 0; j < 20; j++) rwork[j] = REAL(rWork)[j]; /* global variable */ //timesteps = (double *) R_alloc(2, sizeof(double)); for (j=0; j<2; j++) timesteps[j] = 0.; lzw = INTEGER(lZw)[0]; zwork = (Rcomplex *) R_alloc(lzw, sizeof(Rcomplex)); /* initialise global R-variables... */ PROTECT(cY = allocVector(CPLXSXP , neq) ); nprot++; PROTECT(YOUT = allocMatrix(CPLXSXP,ntot+1,nt)); nprot++; /**************************************************************************/ /****** Initialization of Parameters and Forcings (DLL functions) ******/ /**************************************************************************/ //initParms(initfunc, parms); if (initfunc != NA_STRING) { if (inherits(initfunc, "NativeSymbol")) { init_func_type *initializer; PROTECT(de_gparms = parms); nprot++; initializer = (init_func_type *) R_ExternalPtrAddrFn_(initfunc); initializer(Initdeparms); } } // end inline initParms isForcing = initForcings(flist); /* pointers to functions zderiv_func and zjac_func, passed to the FORTRAN subroutine */ if (isDll == 1) { /* DLL address passed to FORTRAN */ zderiv_func = (C_zderiv_func_type *) R_ExternalPtrAddrFn_(derivfunc); /* no need to communicate with R - but output variables set here */ if (isOut) { dy = (Rcomplex *) R_alloc(neq, sizeof(Rcomplex)); /* for (j = 0; j < neq; j++) dy[j] = i0; */ } /* here overruling zderiv_func if forcing */ if (isForcing) { DLL_cderiv_func = (C_zderiv_func_type *) R_ExternalPtrAddrFn_(derivfunc); zderiv_func = (C_zderiv_func_type *) C_zderiv_func_forc; } } else { /* interface function between FORTRAN and R passed to FORTRAN*/ zderiv_func = (C_zderiv_func_type *) C_zderiv_func; /* needed to communicate with R */ R_zderiv_func = derivfunc; R_vode_envir = rho; } if (!isNull(jacfunc)) { if (isDll == 1) { zjac_func = (C_zjac_func_type *) R_ExternalPtrAddrFn_(jacfunc); } else { R_zjac_func = jacfunc; zjac_func = C_zjac_func; } } /* tolerance specifications */ if (latol == 1 && lrtol == 1 ) itol = 1; if (latol > 1 && lrtol == 1 ) itol = 2; if (latol == 1 && lrtol > 1 ) itol = 3; if (latol > 1 && lrtol > 1 ) itol = 4; itask = INTEGER(iTask)[0]; istate = 1; iopt = 0; ss = 0.; is = 0; for (i = 5; i < 8 ; i++) ss = ss+rwork[i]; for (i = 5; i < 10; i++) is = is+iwork[i]; if (ss > 0 || is > 0) iopt = 1; /* non-standard input */ /* #### initial time step #### */ /* COMPLEX(YOUT)[0] = COMPLEX(times)[0];*/ for (j = 0; j < neq; j++) { COMPLEX(YOUT)[j+1] = COMPLEX(y)[j]; } /* function in DLL and output */ if (isOut == 1) { tin = REAL(times)[0]; zderiv_func (&neq, &tin, xytmp, dy, zout, ipar) ; for (j = 0; j < nout; j++) COMPLEX(YOUT)[j + neq + 1] = zout[j]; } /* #### main time loop #### */ for (it = 0; it < nt-1; it++) { tin = REAL(times)[it]; tout = REAL(times)[it+1]; F77_CALL(zvode) (zderiv_func, &neq, xytmp, &tin, &tout, &itol, Rtol, Atol, &itask, &istate, &iopt, zwork, &lzw, rwork, &lrw, iwork, &liw, zjac_func, &jt, zout, ipar); /* in case size of timesteps is called for */ timesteps [0] = rwork[10]; timesteps [1] = rwork[11]; if (istate == -1) { warning("an excessive amount of work (> mxstep ) was done, but integration was not successful - increase maxsteps ?"); } else if (istate == -2) { warning("Excessive precision requested. scale up `rtol' and `atol' e.g by the factor %g\n",10.0); } else if (istate == -4) { warning("repeated error test failures on a step, but integration was successful - singularity ?"); } else if (istate == -5) { warning("repeated convergence test failures on a step, but integration was successful - inaccurate Jacobian matrix?"); } else if (istate == -6) { warning("Error term became zero for some i: pure relative error control (ATOL(i)=0.0) for a variable which is now vanished"); } if (istate == -3) { error("illegal input detected before taking any integration steps - see written message"); } else { /* REAL(YOUT)[(it+1)*(ntot+1)] = tin;*/ for (j = 0; j < neq; j++) COMPLEX(YOUT)[(it+1)*(ntot + 1) + j + 1] = xytmp[j]; if (isOut == 1) { zderiv_func (&neq, &tin, xytmp, dy, zout, ipar) ; for (j = 0; j < nout; j++) COMPLEX(YOUT)[(it+1)*(ntot + 1) + j + neq + 1] = zout[j]; } } /* #### an error occurred #### */ if (istate < 0 || tin < tout) { warning("Returning early from dvode Results are accurate, as far as they go\n"); /* redimension YOUT */ PROTECT(YOUT2 = allocMatrix(CPLXSXP,ntot+1,(it+2))); nprot++; for (k = 0; k < it+2; k++) for (j = 0; j < ntot+1; j++) COMPLEX(YOUT2)[k*(ntot+1) + j] = COMPLEX(YOUT)[k*(ntot+1) + j]; break; } } /* end main time loop */ /* #### returning output #### */ PROTECT(ISTATE = allocVector(INTSXP, 23)); nprot++; PROTECT(RWORK = allocVector(REALSXP, 4)); nprot++; terminate(istate, iwork, 23, 0, rwork, 4, 10); unlock_solver(); UNPROTECT(nprot); if (istate > 0) return(YOUT); else return(YOUT2); } deSolve/src/ddaspk.f0000644000176000001440000074570613572134421014134 0ustar ripleyusersC The code in this file is was taken from daspk.tgz from C https://www.netlib.org/ode/ C Original authors: Linda R. Petzold, Peter N. Brown, C Alan C. Hindmarsh, and Clement W. Ulrich C Adapted for use in R package deSolve by the deSolve authors. C C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C karline: changed INFO, to also pass the index of the variables C error scaling ~ index of variables SUBROUTINE DDASPK (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL) C C***BEGIN PROLOGUE DDASPK C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 910624 C***REVISION DATE 920929 (CJ in RES call, RES counter fix.) C***REVISION DATE 921215 (Warnings on poor iteration performance) C***REVISION DATE 921216 (NRMAX as optional input) C***REVISION DATE 930315 (Name change: DDINI to DDINIT) C***REVISION DATE 940822 (Replaced initial condition calculation) C***REVISION DATE 941101 (Added linesearch in I.C. calculations) C***REVISION DATE 941220 (Misc. corrections throughout) C***REVISION DATE 950125 (Added DINVWT routine) C***REVISION DATE 950714 (Misc. corrections throughout) C***REVISION DATE 950802 (Default NRMAX = 5, based on tests.) C***REVISION DATE 950808 (Optional error test added.) C***REVISION DATE 950814 (Added I.C. constraints and INFO(14)) C***REVISION DATE 950828 (Various minor corrections.) C***REVISION DATE 951006 (Corrected WT scaling in DFNRMK.) C***REVISION DATE 960129 (Corrected RL bug in DLINSD, DLINSK.) C***REVISION DATE 960301 (Added NONNEG to SAVE statement.) C***CATEGORY NO. I1A2 C***KEYWORDS DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS, C IMPLICIT DIFFERENTIAL SYSTEMS, KRYLOV ITERATION C***AUTHORS Linda R. Petzold, Peter N. Brown, Alan C. Hindmarsh, and C Clement W. Ulrich C Center for Computational Sciences & Engineering, L-316 C Lawrence Livermore National Laboratory C P.O. Box 808, C Livermore, CA 94551 C***PURPOSE This code solves a system of differential/algebraic C equations of the form C G(t,y,y') = 0 , C using a combination of Backward Differentiation Formula C (BDF) methods and a choice of two linear system solution C methods: direct (dense or band) or Krylov (iterative). C This version is in double precision. C----------------------------------------------------------------------- C***DESCRIPTION C C *Usage: C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) C INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR(*) C DOUBLE PRECISION T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), C RWORK(LRW), RPAR(*) C EXTERNAL RES, JAC, PSOL C C CALL DDASPK (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, C * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL) C C Quantities which may be altered by the code are: C T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, IDID, RWORK(*), IWORK(*) C C C *Arguments: C C RES:EXT This is the name of a subroutine which you C provide to define the residual function G(t,y,y') C of the differential/algebraic system. C C NEQ:IN This is the number of equations in the system. C C T:INOUT This is the current value of the independent C variable. C C Y(*):INOUT This array contains the solution components at T. C C YPRIME(*):INOUT This array contains the derivatives of the solution C components at T. C C TOUT:IN This is a point at which a solution is desired. C C INFO(N):IN This is an integer array used to communicate details C of how the solution is to be carried out, such as C tolerance type, matrix structure, step size and C order limits, and choice of nonlinear system method. C N must be at least 20. C C RTOL,ATOL:INOUT These quantities represent absolute and relative C error tolerances (on local error) which you provide C to indicate how accurately you wish the solution to C be computed. You may choose them to be both scalars C or else both arrays of length NEQ. C C IDID:OUT This integer scalar is an indicator reporting what C the code did. You must monitor this variable to C decide what action to take next. C C RWORK:WORK A real work array of length LRW which provides the C code with needed storage space. C C LRW:IN The length of RWORK. C C IWORK:WORK An integer work array of length LIW which provides C the code with needed storage space. C C LIW:IN The length of IWORK. C C RPAR,IPAR:IN These are real and integer parameter arrays which C you can use for communication between your calling C program and the RES, JAC, and PSOL subroutines. C C JAC:EXT This is the name of a subroutine which you may C provide (optionally) for calculating Jacobian C (partial derivative) data involved in solving linear C systems within DDASPK. C C PSOL:EXT This is the name of a subroutine which you must C provide for solving linear systems if you selected C a Krylov method. The purpose of PSOL is to solve C linear systems involving a left preconditioner P. C C *Overview C C The DDASPK solver uses the backward differentiation formulas of C orders one through five to solve a system of the form G(t,y,y') = 0 C for y = Y and y' = YPRIME. Values for Y and YPRIME at the initial C time must be given as input. These values should be consistent, C that is, if T, Y, YPRIME are the given initial values, they should C satisfy G(T,Y,YPRIME) = 0. However, if consistent values are not C known, in many cases you can have DDASPK solve for them -- see INFO(11). C (This and other options are described in more detail below.) C C Normally, DDASPK solves the system from T to TOUT. It is easy to C continue the solution to get results at additional TOUT. This is C the interval mode of operation. Intermediate results can also be C obtained easily by specifying INFO(3). C C On each step taken by DDASPK, a sequence of nonlinear algebraic C systems arises. These are solved by one of two types of C methods: C * a Newton iteration with a direct method for the linear C systems involved (INFO(12) = 0), or C * a Newton iteration with a preconditioned Krylov iterative C method for the linear systems involved (INFO(12) = 1). C C The direct method choices are dense and band matrix solvers, C with either a user-supplied or an internal difference quotient C Jacobian matrix, as specified by INFO(5) and INFO(6). C In the band case, INFO(6) = 1, you must supply half-bandwidths C in IWORK(1) and IWORK(2). C C The Krylov method is the Generalized Minimum Residual (GMRES) C method, in either complete or incomplete form, and with C scaling and preconditioning. The method is implemented C in an algorithm called SPIGMR. Certain options in the Krylov C method case are specified by INFO(13) and INFO(15). C C If the Krylov method is chosen, you may supply a pair of routines, C JAC and PSOL, to apply preconditioning to the linear system. C If the system is A*x = b, the matrix is A = dG/dY + CJ*dG/dYPRIME C (of order NEQ). This system can then be preconditioned in the form C (P-inverse)*A*x = (P-inverse)*b, with left preconditioner P. C (DDASPK does not allow right preconditioning.) C Then the Krylov method is applied to this altered, but equivalent, C linear system, hopefully with much better performance than without C preconditioning. (In addition, a diagonal scaling matrix based on C the tolerances is also introduced into the altered system.) C C The JAC routine evaluates any data needed for solving systems C with coefficient matrix P, and PSOL carries out that solution. C In any case, in order to improve convergence, you should try to C make P approximate the matrix A as much as possible, while keeping C the system P*x = b reasonably easy and inexpensive to solve for x, C given a vector b. C C C *Description C C------INPUT - WHAT TO DO ON THE FIRST CALL TO DDASPK------------------- C C C The first call of the code is defined to be the start of each new C problem. Read through the descriptions of all the following items, C provide sufficient storage space for designated arrays, set C appropriate variables for the initialization of the problem, and C give information about how you want the problem to be solved. C C C RES -- Provide a subroutine of the form C C SUBROUTINE RES (T, Y, YPRIME, CJ, DELTA, IRES, RPAR, IPAR) C C to define the system of differential/algebraic C equations which is to be solved. For the given values C of T, Y and YPRIME, the subroutine should return C the residual of the differential/algebraic system C DELTA = G(T,Y,YPRIME) C DELTA is a vector of length NEQ which is output from RES. C C Subroutine RES must not alter T, Y, YPRIME, or CJ. C You must declare the name RES in an EXTERNAL C statement in your program that calls DDASPK. C You must dimension Y, YPRIME, and DELTA in RES. C C The input argument CJ can be ignored, or used to rescale C constraint equations in the system (see Ref. 2, p. 145). C Note: In this respect, DDASPK is not downward-compatible C with DDASSL, which does not have the RES argument CJ. C C IRES is an integer flag which is always equal to zero C on input. Subroutine RES should alter IRES only if it C encounters an illegal value of Y or a stop condition. C Set IRES = -1 if an input value is illegal, and DDASPK C will try to solve the problem without getting IRES = -1. C If IRES = -2, DDASPK will return control to the calling C program with IDID = -11. C C RPAR and IPAR are real and integer parameter arrays which C you can use for communication between your calling program C and subroutine RES. They are not altered by DDASPK. If you C do not need RPAR or IPAR, ignore these parameters by treat- C ing them as dummy arguments. If you do choose to use them, C dimension them in your calling program and in RES as arrays C of appropriate length. C C NEQ -- Set it to the number of equations in the system (NEQ .GE. 1). C C T -- Set it to the initial point of the integration. (T must be C a variable.) C C Y(*) -- Set this array to the initial values of the NEQ solution C components at the initial point. You must dimension Y of C length at least NEQ in your calling program. C C YPRIME(*) -- Set this array to the initial values of the NEQ first C derivatives of the solution components at the initial C point. You must dimension YPRIME at least NEQ in your C calling program. C C TOUT - Set it to the first point at which a solution is desired. C You cannot take TOUT = T. Integration either forward in T C (TOUT .GT. T) or backward in T (TOUT .LT. T) is permitted. C C The code advances the solution from T to TOUT using step C sizes which are automatically selected so as to achieve the C desired accuracy. If you wish, the code will return with the C solution and its derivative at intermediate steps (the C intermediate-output mode) so that you can monitor them, C but you still must provide TOUT in accord with the basic C aim of the code. C C The first step taken by the code is a critical one because C it must reflect how fast the solution changes near the C initial point. The code automatically selects an initial C step size which is practically always suitable for the C problem. By using the fact that the code will not step past C TOUT in the first step, you could, if necessary, restrict the C length of the initial step. C C For some problems it may not be permissible to integrate C past a point TSTOP, because a discontinuity occurs there C or the solution or its derivative is not defined beyond C TSTOP. When you have declared a TSTOP point (see INFO(4) C and RWORK(1)), you have told the code not to integrate past C TSTOP. In this case any tout beyond TSTOP is invalid input. C C INFO(*) - Use the INFO array to give the code more details about C how you want your problem solved. This array should be C dimensioned of length 20, though DDASPK uses only the C first 15 entries. You must respond to all of the following C items, which are arranged as questions. The simplest use C of DDASPK corresponds to setting all entries of INFO to 0. C C INFO(1) - This parameter enables the code to initialize itself. C You must set it to indicate the start of every new C problem. C C **** Is this the first call for this problem ... C yes - set INFO(1) = 0 C no - not applicable here. C See below for continuation calls. **** C C INFO(2) - How much accuracy you want of your solution C is specified by the error tolerances RTOL and ATOL. C The simplest use is to take them both to be scalars. C To obtain more flexibility, they can both be arrays. C The code must be told your choice. C C **** Are both error tolerances RTOL, ATOL scalars ... C yes - set INFO(2) = 0 C and input scalars for both RTOL and ATOL C no - set INFO(2) = 1 C and input arrays for both RTOL and ATOL **** C C INFO(3) - The code integrates from T in the direction of TOUT C by steps. If you wish, it will return the computed C solution and derivative at the next intermediate step C (the intermediate-output mode) or TOUT, whichever comes C first. This is a good way to proceed if you want to C see the behavior of the solution. If you must have C solutions at a great many specific TOUT points, this C code will compute them efficiently. C C **** Do you want the solution only at C TOUT (and not at the next intermediate step) ... C yes - set INFO(3) = 0 C no - set INFO(3) = 1 **** C C INFO(4) - To handle solutions at a great many specific C values TOUT efficiently, this code may integrate past C TOUT and interpolate to obtain the result at TOUT. C Sometimes it is not possible to integrate beyond some C point TSTOP because the equation changes there or it is C not defined past TSTOP. Then you must tell the code C this stop condition. C C **** Can the integration be carried out without any C restrictions on the independent variable T ... C yes - set INFO(4) = 0 C no - set INFO(4) = 1 C and define the stopping point TSTOP by C setting RWORK(1) = TSTOP **** C C INFO(5) - used only when INFO(12) = 0 (direct methods). C To solve differential/algebraic systems you may wish C to use a matrix of partial derivatives of the C system of differential equations. If you do not C provide a subroutine to evaluate it analytically (see C description of the item JAC in the call list), it will C be approximated by numerical differencing in this code. C Although it is less trouble for you to have the code C compute partial derivatives by numerical differencing, C the solution will be more reliable if you provide the C derivatives via JAC. Usually numerical differencing is C more costly than evaluating derivatives in JAC, but C sometimes it is not - this depends on your problem. C C **** Do you want the code to evaluate the partial deriv- C atives automatically by numerical differences ... C yes - set INFO(5) = 0 C no - set INFO(5) = 1 C and provide subroutine JAC for evaluating the C matrix of partial derivatives **** C C INFO(6) - used only when INFO(12) = 0 (direct methods). C DDASPK will perform much better if the matrix of C partial derivatives, dG/dY + CJ*dG/dYPRIME (here CJ is C a scalar determined by DDASPK), is banded and the code C is told this. In this case, the storage needed will be C greatly reduced, numerical differencing will be performed C much cheaper, and a number of important algorithms will C execute much faster. The differential equation is said C to have half-bandwidths ML (lower) and MU (upper) if C equation i involves only unknowns Y(j) with C i-ML .le. j .le. i+MU . C For all i=1,2,...,NEQ. Thus, ML and MU are the widths C of the lower and upper parts of the band, respectively, C with the main diagonal being excluded. If you do not C indicate that the equation has a banded matrix of partial C derivatives the code works with a full matrix of NEQ**2 C elements (stored in the conventional way). Computations C with banded matrices cost less time and storage than with C full matrices if 2*ML+MU .lt. NEQ. If you tell the C code that the matrix of partial derivatives has a banded C structure and you want to provide subroutine JAC to C compute the partial derivatives, then you must be careful C to store the elements of the matrix in the special form C indicated in the description of JAC. C C **** Do you want to solve the problem using a full (dense) C matrix (and not a special banded structure) ... C yes - set INFO(6) = 0 C no - set INFO(6) = 1 C and provide the lower (ML) and upper (MU) C bandwidths by setting C IWORK(1)=ML C IWORK(2)=MU **** C C INFO(7) - You can specify a maximum (absolute value of) C stepsize, so that the code will avoid passing over very C large regions. C C **** Do you want the code to decide on its own the maximum C stepsize ... C yes - set INFO(7) = 0 C no - set INFO(7) = 1 C and define HMAX by setting C RWORK(2) = HMAX **** C C INFO(8) - Differential/algebraic problems may occasionally C suffer from severe scaling difficulties on the first C step. If you know a great deal about the scaling of C your problem, you can help to alleviate this problem C by specifying an initial stepsize H0. C C **** Do you want the code to define its own initial C stepsize ... C yes - set INFO(8) = 0 C no - set INFO(8) = 1 C and define H0 by setting C RWORK(3) = H0 **** C C INFO(9) - If storage is a severe problem, you can save some C storage by restricting the maximum method order MAXORD. C The default value is 5. For each order decrease below 5, C the code requires NEQ fewer locations, but it is likely C to be slower. In any case, you must have C 1 .le. MAXORD .le. 5. C **** Do you want the maximum order to default to 5 ... C yes - set INFO(9) = 0 C no - set INFO(9) = 1 C and define MAXORD by setting C IWORK(3) = MAXORD **** C C INFO(10) - If you know that certain components of the C solutions to your equations are always nonnegative C (or nonpositive), it may help to set this C parameter. There are three options that are C available: C 1. To have constraint checking only in the initial C condition calculation. C 2. To enforce nonnegativity in Y during the integration. C 3. To enforce both options 1 and 2. C C When selecting option 2 or 3, it is probably best to try the C code without using this option first, and only use C this option if that does not work very well. C C **** Do you want the code to solve the problem without C invoking any special inequality constraints ... C yes - set INFO(10) = 0 C no - set INFO(10) = 1 to have option 1 enforced C no - set INFO(10) = 2 to have option 2 enforced C no - set INFO(10) = 3 to have option 3 enforced **** C C If you have specified INFO(10) = 1 or 3, then you C will also need to identify how each component of Y C in the initial condition calculation is constrained. C You must set: C IWORK(40+I) = +1 if Y(I) must be .GE. 0, C IWORK(40+I) = +2 if Y(I) must be .GT. 0, C IWORK(40+I) = -1 if Y(I) must be .LE. 0, while C IWORK(40+I) = -2 if Y(I) must be .LT. 0, while C IWORK(40+I) = 0 if Y(I) is not constrained. C C INFO(11) - DDASPK normally requires the initial T, Y, and C YPRIME to be consistent. That is, you must have C G(T,Y,YPRIME) = 0 at the initial T. If you do not know C the initial conditions precisely, in some cases C DDASPK may be able to compute it. C C Denoting the differential variables in Y by Y_d C and the algebraic variables by Y_a, DDASPK can solve C one of two initialization problems: C 1. Given Y_d, calculate Y_a and Y'_d, or C 2. Given Y', calculate Y. C In either case, initial values for the given C components are input, and initial guesses for C the unknown components must also be provided as input. C C **** Are the initial T, Y, YPRIME consistent ... C C yes - set INFO(11) = 0 C no - set INFO(11) = 1 to calculate option 1 above, C or set INFO(11) = 2 to calculate option 2 **** C C If you have specified INFO(11) = 1, then you C will also need to identify which are the C differential and which are the algebraic C components (algebraic components are components C whose derivatives do not appear explicitly C in the function G(T,Y,YPRIME)). You must set: C IWORK(LID+I) = +1 if Y(I) is a differential variable C IWORK(LID+I) = -1 if Y(I) is an algebraic variable, C where LID = 40 if INFO(10) = 0 or 2 and LID = 40+NEQ C if INFO(10) = 1 or 3. C C INFO(12) - Except for the addition of the RES argument CJ, C DDASPK by default is downward-compatible with DDASSL, C which uses only direct (dense or band) methods to solve C the linear systems involved. You must set INFO(12) to C indicate whether you want the direct methods or the C Krylov iterative method. C **** Do you want DDASPK to use standard direct methods C (dense or band) or the Krylov (iterative) method ... C direct methods - set INFO(12) = 0. C Krylov method - set INFO(12) = 1, C and check the settings of INFO(13) and INFO(15). C C INFO(13) - used when INFO(12) = 1 (Krylov methods). C DDASPK uses scalars MAXL, KMP, NRMAX, and EPLI for the C iterative solution of linear systems. INFO(13) allows C you to override the default values of these parameters. C These parameters and their defaults are as follows: C MAXL = maximum number of iterations in the SPIGMR C algorithm (MAXL .le. NEQ). The default is C MAXL = MIN(5,NEQ). C KMP = number of vectors on which orthogonalization is C done in the SPIGMR algorithm. The default is C KMP = MAXL, which corresponds to complete GMRES C iteration, as opposed to the incomplete form. C NRMAX = maximum number of restarts of the SPIGMR C algorithm per nonlinear iteration. The default is C NRMAX = 5. C EPLI = convergence test constant in SPIGMR algorithm. C The default is EPLI = 0.05. C Note that the length of RWORK depends on both MAXL C and KMP. See the definition of LRW below. C **** Are MAXL, KMP, and EPLI to be given their C default values ... C yes - set INFO(13) = 0 C no - set INFO(13) = 1, C and set all of the following: C IWORK(24) = MAXL (1 .le. MAXL .le. NEQ) C IWORK(25) = KMP (1 .le. KMP .le. MAXL) C IWORK(26) = NRMAX (NRMAX .ge. 0) C RWORK(10) = EPLI (0 .lt. EPLI .lt. 1.0) **** C C INFO(14) - used with INFO(11) > 0 (initial condition C calculation is requested). In this case, you may C request control to be returned to the calling program C immediately after the initial condition calculation, C before proceeding to the integration of the system C (e.g. to examine the computed Y and YPRIME). C If this is done, and if the initialization succeeded C (IDID = 4), you should reset INFO(11) to 0 for the C next call, to prevent the solver from repeating the C initialization (and to avoid an infinite loop). C **** Do you want to proceed to the integration after C the initial condition calculation is done ... C yes - set INFO(14) = 0 C no - set INFO(14) = 1 **** C C INFO(15) - used when INFO(12) = 1 (Krylov methods). C When using preconditioning in the Krylov method, C you must supply a subroutine, PSOL, which solves the C associated linear systems using P. C The usage of DDASPK is simpler if PSOL can carry out C the solution without any prior calculation of data. C However, if some partial derivative data is to be C calculated in advance and used repeatedly in PSOL, C then you must supply a JAC routine to do this, C and set INFO(15) to indicate that JAC is to be called C for this purpose. For example, P might be an C approximation to a part of the matrix A which can be C calculated and LU-factored for repeated solutions of C the preconditioner system. The arrays WP and IWP C (described under JAC and PSOL) can be used to C communicate data between JAC and PSOL. C **** Does PSOL operate with no prior preparation ... C yes - set INFO(15) = 0 (no JAC routine) C no - set INFO(15) = 1 C and supply a JAC routine to evaluate and C preprocess any required Jacobian data. **** C C INFO(16) - option to exclude algebraic variables from C the error test. C **** Do you wish to control errors locally on C all the variables... C yes - set INFO(16) = 0 C no - set INFO(16) = 1 C If you have specified INFO(16) = 1, then you C will also need to identify which are the C differential and which are the algebraic C components (algebraic components are components C whose derivatives do not appear explicitly C in the function G(T,Y,YPRIME)). You must set: C IWORK(LID+I) = +1 if Y(I) is a differential C variable, and C IWORK(LID+I) = -1 if Y(I) is an algebraic C variable, C where LID = 40 if INFO(10) = 0 or 2 and C LID = 40 + NEQ if INFO(10) = 1 or 3. C C INFO(17) - used when INFO(11) > 0 (DDASPK is to do an C initial condition calculation). C DDASPK uses several heuristic control quantities in the C initial condition calculation. They have default values, C but can also be set by the user using INFO(17). C These parameters and their defaults are as follows: C MXNIT = maximum number of Newton iterations C per Jacobian or preconditioner evaluation. C The default is: C MXNIT = 5 in the direct case (INFO(12) = 0), and C MXNIT = 15 in the Krylov case (INFO(12) = 1). C MXNJ = maximum number of Jacobian or preconditioner C evaluations. The default is: C MXNJ = 6 in the direct case (INFO(12) = 0), and C MXNJ = 2 in the Krylov case (INFO(12) = 1). C MXNH = maximum number of values of the artificial C stepsize parameter H to be tried if INFO(11) = 1. C The default is MXNH = 5. C NOTE: the maximum number of Newton iterations C allowed in all is MXNIT*MXNJ*MXNH if INFO(11) = 1, C and MXNIT*MXNJ if INFO(11) = 2. C LSOFF = flag to turn off the linesearch algorithm C (LSOFF = 0 means linesearch is on, LSOFF = 1 means C it is turned off). The default is LSOFF = 0. C STPTOL = minimum scaled step in linesearch algorithm. C The default is STPTOL = (unit roundoff)**(2/3). C EPINIT = swing factor in the Newton iteration convergence C test. The test is applied to the residual vector, C premultiplied by the approximate Jacobian (in the C direct case) or the preconditioner (in the Krylov C case). For convergence, the weighted RMS norm of C this vector (scaled by the error weights) must be C less than EPINIT*EPCON, where EPCON = .33 is the C analogous test constant used in the time steps. C The default is EPINIT = .01. C **** Are the initial condition heuristic controls to be C given their default values... C yes - set INFO(17) = 0 C no - set INFO(17) = 1, C and set all of the following: C IWORK(32) = MXNIT (.GT. 0) C IWORK(33) = MXNJ (.GT. 0) C IWORK(34) = MXNH (.GT. 0) C IWORK(35) = LSOFF ( = 0 or 1) C RWORK(14) = STPTOL (.GT. 0.0) C RWORK(15) = EPINIT (.GT. 0.0) **** C C INFO(18) - option to get extra printing in initial condition C calculation. C **** Do you wish to have extra printing... C no - set INFO(18) = 0 C yes - set INFO(18) = 1 for minimal printing, or C set INFO(18) = 2 for full printing. C If you have specified INFO(18) .ge. 1, data C will be printed with the error handler routines. C To print to a non-default unit number L, include C the line CALL XSETUN(L) in your program. **** C C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) C error tolerances to tell the code how accurately you C want the solution to be computed. They must be defined C as variables because the code may change them. C you have two choices -- C Both RTOL and ATOL are scalars (INFO(2) = 0), or C both RTOL and ATOL are vectors (INFO(2) = 1). C In either case all components must be non-negative. C C The tolerances are used by the code in a local error C test at each step which requires roughly that C abs(local error in Y(i)) .le. EWT(i) , C where EWT(i) = RTOL*abs(Y(i)) + ATOL is an error weight C quantity, for each vector component. C (More specifically, a root-mean-square norm is used to C measure the size of vectors, and the error test uses the C magnitude of the solution at the beginning of the step.) C C The true (global) error is the difference between the C true solution of the initial value problem and the C computed approximation. Practically all present day C codes, including this one, control the local error at C each step and do not even attempt to control the global C error directly. C C Usually, but not always, the true accuracy of C the computed Y is comparable to the error tolerances. C This code will usually, but not always, deliver a more C accurate solution if you reduce the tolerances and C integrate again. By comparing two such solutions you C can get a fairly reliable idea of the true error in the C solution at the larger tolerances. C C Setting ATOL = 0. results in a pure relative error test C on that component. Setting RTOL = 0. results in a pure C absolute error test on that component. A mixed test C with non-zero RTOL and ATOL corresponds roughly to a C relative error test when the solution component is C much bigger than ATOL and to an absolute error test C when the solution component is smaller than the C threshold ATOL. C C The code will not attempt to compute a solution at an C accuracy unreasonable for the machine being used. It C will advise you if you ask for too much accuracy and C inform you as to the maximum accuracy it believes C possible. C C RWORK(*) -- a real work array, which should be dimensioned in your C calling program with a length equal to the value of C LRW (or greater). C C LRW -- Set it to the declared length of the RWORK array. The C minimum length depends on the options you have selected, C given by a base value plus additional storage as described C below. C C If INFO(12) = 0 (standard direct method), the base value is C base = 50 + max(MAXORD+4,7)*NEQ. C The default value is MAXORD = 5 (see INFO(9)). With the C default MAXORD, base = 50 + 9*NEQ. C Additional storage must be added to the base value for C any or all of the following options: C if INFO(6) = 0 (dense matrix), add NEQ**2 C if INFO(6) = 1 (banded matrix), then C if INFO(5) = 0, add (2*ML+MU+1)*NEQ + 2*(NEQ/(ML+MU+1)+1), C if INFO(5) = 1, add (2*ML+MU+1)*NEQ, C if INFO(16) = 1, add NEQ. C C If INFO(12) = 1 (Krylov method), the base value is C base = 50 + (MAXORD+5)*NEQ + (MAXL+3+MIN0(1,MAXL-KMP))*NEQ + C + (MAXL+3)*MAXL + 1 + LENWP. C See PSOL for description of LENWP. The default values are: C MAXORD = 5 (see INFO(9)), MAXL = min(5,NEQ) and KMP = MAXL C (see INFO(13)). C With the default values for MAXORD, MAXL and KMP, C base = 91 + 18*NEQ + LENWP. C Additional storage must be added to the base value for C any or all of the following options: C if INFO(16) = 1, add NEQ. C C C IWORK(*) -- an integer work array, which should be dimensioned in C your calling program with a length equal to the value C of LIW (or greater). C C LIW -- Set it to the declared length of the IWORK array. The C minimum length depends on the options you have selected, C given by a base value plus additional storage as described C below. C C If INFO(12) = 0 (standard direct method), the base value is C base = 40 + NEQ. C IF INFO(10) = 1 or 3, add NEQ to the base value. C If INFO(11) = 1 or INFO(16) =1, add NEQ to the base value. C C If INFO(12) = 1 (Krylov method), the base value is C base = 40 + LENIWP. C See PSOL for description of LENIWP. C IF INFO(10) = 1 or 3, add NEQ to the base value. C If INFO(11) = 1 or INFO(16) = 1, add NEQ to the base value. C C C RPAR, IPAR -- These are arrays of double precision and integer type, C respectively, which are available for you to use C for communication between your program that calls C DDASPK and the RES subroutine (and the JAC and PSOL C subroutines). They are not altered by DDASPK. C If you do not need RPAR or IPAR, ignore these C parameters by treating them as dummy arguments. C If you do choose to use them, dimension them in C your calling program and in RES (and in JAC and PSOL) C as arrays of appropriate length. C C JAC -- This is the name of a routine that you may supply C (optionally) that relates to the Jacobian matrix of the C nonlinear system that the code must solve at each T step. C The role of JAC (and its call sequence) depends on whether C a direct (INFO(12) = 0) or Krylov (INFO(12) = 1) method C is selected. C C **** INFO(12) = 0 (direct methods): C If you are letting the code generate partial derivatives C numerically (INFO(5) = 0), then JAC can be absent C (or perhaps a dummy routine to satisfy the loader). C Otherwise you must supply a JAC routine to compute C the matrix A = dG/dY + CJ*dG/dYPRIME. It must have C the form C C SUBROUTINE JAC (T, Y, YPRIME, PD, CJ, RPAR, IPAR) C C The JAC routine must dimension Y, YPRIME, and PD (and RPAR C and IPAR if used). CJ is a scalar which is input to JAC. C For the given values of T, Y, and YPRIME, the JAC routine C must evaluate the nonzero elements of the matrix A, and C store these values in the array PD. The elements of PD are C set to zero before each call to JAC, so that only nonzero C elements need to be defined. C The way you store the elements into the PD array depends C on the structure of the matrix indicated by INFO(6). C *** INFO(6) = 0 (full or dense matrix) *** C Give PD a first dimension of NEQ. When you evaluate the C nonzero partial derivatives of equation i (i.e. of G(i)) C with respect to component j (of Y and YPRIME), you must C store the element in PD according to C PD(i,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). C *** INFO(6) = 1 (banded matrix with half-bandwidths ML, MU C as described under INFO(6)) *** C Give PD a first dimension of 2*ML+MU+1. When you C evaluate the nonzero partial derivatives of equation i C (i.e. of G(i)) with respect to component j (of Y and C YPRIME), you must store the element in PD according to C IROW = i - j + ML + MU + 1 C PD(IROW,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). C C **** INFO(12) = 1 (Krylov method): C If you are not calculating Jacobian data in advance for use C in PSOL (INFO(15) = 0), JAC can be absent (or perhaps a C dummy routine to satisfy the loader). Otherwise, you may C supply a JAC routine to compute and preprocess any parts of C of the Jacobian matrix A = dG/dY + CJ*dG/dYPRIME that are C involved in the preconditioner matrix P. C It is to have the form C C SUBROUTINE JAC (RES, IRES, NEQ, T, Y, YPRIME, REWT, SAVR, C WK, H, CJ, WP, IWP, IER, RPAR, IPAR) C C The JAC routine must dimension Y, YPRIME, REWT, SAVR, WK, C and (if used) WP, IWP, RPAR, and IPAR. C The Y, YPRIME, and SAVR arrays contain the current values C of Y, YPRIME, and the residual G, respectively. C The array WK is work space of length NEQ. C H is the step size. CJ is a scalar, input to JAC, that is C normally proportional to 1/H. REWT is an array of C reciprocal error weights, 1/EWT(i), where EWT(i) is C RTOL*abs(Y(i)) + ATOL (unless you supplied routine DDAWTS C instead), for use in JAC if needed. For example, if JAC C computes difference quotient approximations to partial C derivatives, the REWT array may be useful in setting the C increments used. The JAC routine should do any C factorization operations called for, in preparation for C solving linear systems in PSOL. The matrix P should C be an approximation to the Jacobian, C A = dG/dY + CJ*dG/dYPRIME. C C WP and IWP are real and integer work arrays which you may C use for communication between your JAC routine and your C PSOL routine. These may be used to store elements of the C preconditioner P, or related matrix data (such as factored C forms). They are not altered by DDASPK. C If you do not need WP or IWP, ignore these parameters by C treating them as dummy arguments. If you do use them, C dimension them appropriately in your JAC and PSOL routines. C See the PSOL description for instructions on setting C the lengths of WP and IWP. C C On return, JAC should set the error flag IER as follows.. C IER = 0 if JAC was successful, C IER .ne. 0 if JAC was unsuccessful (e.g. if Y or YPRIME C was illegal, or a singular matrix is found). C (If IER .ne. 0, a smaller stepsize will be tried.) C IER = 0 on entry to JAC, so need be reset only on a failure. C If RES is used within JAC, then a nonzero value of IRES will C override any nonzero value of IER (see the RES description). C C Regardless of the method type, subroutine JAC must not C alter T, Y(*), YPRIME(*), H, CJ, or REWT(*). C You must declare the name JAC in an EXTERNAL statement in C your program that calls DDASPK. C C PSOL -- This is the name of a routine you must supply if you have C selected a Krylov method (INFO(12) = 1) with preconditioning. C In the direct case (INFO(12) = 0), PSOL can be absent C (a dummy routine may have to be supplied to satisfy the C loader). Otherwise, you must provide a PSOL routine to C solve linear systems arising from preconditioning. C When supplied with INFO(12) = 1, the PSOL routine is to C have the form C C SUBROUTINE PSOL (NEQ, T, Y, YPRIME, SAVR, WK, CJ, WGHT, C WP, IWP, B, EPLIN, IER, RPAR, IPAR) C C The PSOL routine must solve linear systems of the form C P*x = b where P is the left preconditioner matrix. C C The right-hand side vector b is in the B array on input, and C PSOL must return the solution vector x in B. C The Y, YPRIME, and SAVR arrays contain the current values C of Y, YPRIME, and the residual G, respectively. C C Work space required by JAC and/or PSOL, and space for data to C be communicated from JAC to PSOL is made available in the form C of arrays WP and IWP, which are parts of the RWORK and IWORK C arrays, respectively. The lengths of these real and integer C work spaces WP and IWP must be supplied in LENWP and LENIWP, C respectively, as follows.. C IWORK(27) = LENWP = length of real work space WP C IWORK(28) = LENIWP = length of integer work space IWP. C C WK is a work array of length NEQ for use by PSOL. C CJ is a scalar, input to PSOL, that is normally proportional C to 1/H (H = stepsize). If the old value of CJ C (at the time of the last JAC call) is needed, it must have C been saved by JAC in WP. C C WGHT is an array of weights, to be used if PSOL uses an C iterative method and performs a convergence test. (In terms C of the argument REWT to JAC, WGHT is REWT/sqrt(NEQ).) C If PSOL uses an iterative method, it should use EPLIN C (a heuristic parameter) as the bound on the weighted norm of C the residual for the computed solution. Specifically, the C residual vector R should satisfy C SQRT (SUM ( (R(i)*WGHT(i))**2 ) ) .le. EPLIN C C PSOL must not alter NEQ, T, Y, YPRIME, SAVR, CJ, WGHT, EPLIN. C C On return, PSOL should set the error flag IER as follows.. C IER = 0 if PSOL was successful, C IER .lt. 0 if an unrecoverable error occurred, meaning C control will be passed to the calling routine, C IER .gt. 0 if a recoverable error occurred, meaning that C the step will be retried with the same step size C but with a call to JAC to update necessary data, C unless the Jacobian data is current, in which case C the step will be retried with a smaller step size. C IER = 0 on entry to PSOL so need be reset only on a failure. C C You must declare the name PSOL in an EXTERNAL statement in C your program that calls DDASPK. C C C OPTIONALLY REPLACEABLE SUBROUTINE: C C DDASPK uses a weighted root-mean-square norm to measure the C size of various error vectors. The weights used in this norm C are set in the following subroutine: C C SUBROUTINE DDAWTS (NEQ, IWT, RTOL, ATOL, Y, EWT, RPAR, IPAR) C DIMENSION RTOL(*), ATOL(*), Y(*), EWT(*), RPAR(*), IPAR(*) C C A DDAWTS routine has been included with DDASPK which sets the C weights according to C EWT(I) = RTOL*ABS(Y(I)) + ATOL C in the case of scalar tolerances (IWT = 0) or C EWT(I) = RTOL(I)*ABS(Y(I)) + ATOL(I) C in the case of array tolerances (IWT = 1). (IWT is INFO(2).) C In some special cases, it may be appropriate for you to define C your own error weights by writing a subroutine DDAWTS to be C called instead of the version supplied. However, this should C be attempted only after careful thought and consideration. C If you supply this routine, you may use the tolerances and Y C as appropriate, but do not overwrite these variables. You C may also use RPAR and IPAR to communicate data as appropriate. C ***Note: Aside from the values of the weights, the choice of C norm used in DDASPK (weighted root-mean-square) is not subject C to replacement by the user. In this respect, DDASPK is not C downward-compatible with the original DDASSL solver (in which C the norm routine was optionally user-replaceable). C C C------OUTPUT - AFTER ANY RETURN FROM DDASPK---------------------------- C C The principal aim of the code is to return a computed solution at C T = TOUT, although it is also possible to obtain intermediate C results along the way. To find out whether the code achieved its C goal or if the integration process was interrupted before the task C was completed, you must check the IDID parameter. C C C T -- The output value of T is the point to which the solution C was successfully advanced. C C Y(*) -- contains the computed solution approximation at T. C C YPRIME(*) -- contains the computed derivative approximation at T. C C IDID -- reports what the code did, described as follows: C C *** TASK COMPLETED *** C Reported by positive values of IDID C C IDID = 1 -- a step was successfully taken in the C intermediate-output mode. The code has not C yet reached TOUT. C C IDID = 2 -- the integration to TSTOP was successfully C completed (T = TSTOP) by stepping exactly to TSTOP. C C IDID = 3 -- the integration to TOUT was successfully C completed (T = TOUT) by stepping past TOUT. C Y(*) and YPRIME(*) are obtained by interpolation. C C IDID = 4 -- the initial condition calculation, with C INFO(11) > 0, was successful, and INFO(14) = 1. C No integration steps were taken, and the solution C is not considered to have been started. C C *** TASK INTERRUPTED *** C Reported by negative values of IDID C C IDID = -1 -- a large amount of work has been expended C (about 500 steps). C C IDID = -2 -- the error tolerances are too stringent. C C IDID = -3 -- the local error test cannot be satisfied C because you specified a zero component in ATOL C and the corresponding computed solution component C is zero. Thus, a pure relative error test is C impossible for this component. C C IDID = -5 -- there were repeated failures in the evaluation C or processing of the preconditioner (in JAC). C C IDID = -6 -- DDASPK had repeated error test failures on the C last attempted step. C C IDID = -7 -- the nonlinear system solver in the time integration C could not converge. C C IDID = -8 -- the matrix of partial derivatives appears C to be singular (direct method). C C IDID = -9 -- the nonlinear system solver in the time integration C failed to achieve convergence, and there were repeated C error test failures in this step. C C IDID =-10 -- the nonlinear system solver in the time integration C failed to achieve convergence because IRES was equal C to -1. C C IDID =-11 -- IRES = -2 was encountered and control is C being returned to the calling program. C C IDID =-12 -- DDASPK failed to compute the initial Y, YPRIME. C C IDID =-13 -- unrecoverable error encountered inside user's C PSOL routine, and control is being returned to C the calling program. C C IDID =-14 -- the Krylov linear system solver could not C achieve convergence. C C IDID =-15,..,-32 -- Not applicable for this code. C C *** TASK TERMINATED *** C reported by the value of IDID=-33 C C IDID = -33 -- the code has encountered trouble from which C it cannot recover. A message is printed C explaining the trouble and control is returned C to the calling program. For example, this occurs C when invalid input is detected. C C RTOL, ATOL -- these quantities remain unchanged except when C IDID = -2. In this case, the error tolerances have been C increased by the code to values which are estimated to C be appropriate for continuing the integration. However, C the reported solution at T was obtained using the input C values of RTOL and ATOL. C C RWORK, IWORK -- contain information which is usually of no interest C to the user but necessary for subsequent calls. C However, you may be interested in the performance data C listed below. These quantities are accessed in RWORK C and IWORK but have internal mnemonic names, as follows.. C C RWORK(3)--contains H, the step size h to be attempted C on the next step. C C RWORK(4)--contains TN, the current value of the C independent variable, i.e. the farthest point C integration has reached. This will differ C from T if interpolation has been performed C (IDID = 3). C C RWORK(7)--contains HOLD, the stepsize used on the last C successful step. If INFO(11) = INFO(14) = 1, C this contains the value of H used in the C initial condition calculation. C C IWORK(7)--contains K, the order of the method to be C attempted on the next step. C C IWORK(8)--contains KOLD, the order of the method used C on the last step. C C IWORK(11)--contains NST, the number of steps (in T) C taken so far. C C IWORK(12)--contains NRE, the number of calls to RES C so far. C C IWORK(13)--contains NJE, the number of calls to JAC so C far (Jacobian or preconditioner evaluations). C C IWORK(14)--contains NETF, the total number of error test C failures so far. C C IWORK(15)--contains NCFN, the total number of nonlinear C convergence failures so far (includes counts C of singular iteration matrix or singular C preconditioners). C C IWORK(16)--contains NCFL, the number of convergence C failures of the linear iteration so far. C C IWORK(17)--contains LENIW, the length of IWORK actually C required. This is defined on normal returns C and on an illegal input return for C insufficient storage. C C IWORK(18)--contains LENRW, the length of RWORK actually C required. This is defined on normal returns C and on an illegal input return for C insufficient storage. C C IWORK(19)--contains NNI, the total number of nonlinear C iterations so far (each of which calls a C linear solver). C C IWORK(20)--contains NLI, the total number of linear C (Krylov) iterations so far. C C IWORK(21)--contains NPS, the number of PSOL calls so C far, for preconditioning solve operations or C for solutions with the user-supplied method. C C Note: The various counters in IWORK do not include C counts during a call made with INFO(11) > 0 and C INFO(14) = 1. C C C------INPUT - WHAT TO DO TO CONTINUE THE INTEGRATION ----------------- C (CALLS AFTER THE FIRST) C C This code is organized so that subsequent calls to continue the C integration involve little (if any) additional effort on your C part. You must monitor the IDID parameter in order to determine C what to do next. C C Recalling that the principal task of the code is to integrate C from T to TOUT (the interval mode), usually all you will need C to do is specify a new TOUT upon reaching the current TOUT. C C Do not alter any quantity not specifically permitted below. In C particular do not alter NEQ, T, Y(*), YPRIME(*), RWORK(*), C IWORK(*), or the differential equation in subroutine RES. Any C such alteration constitutes a new problem and must be treated C as such, i.e. you must start afresh. C C You cannot change from array to scalar error control or vice C versa (INFO(2)), but you can change the size of the entries of C RTOL or ATOL. Increasing a tolerance makes the equation easier C to integrate. Decreasing a tolerance will make the equation C harder to integrate and should generally be avoided. C C You can switch from the intermediate-output mode to the C interval mode (INFO(3)) or vice versa at any time. C C If it has been necessary to prevent the integration from going C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the C code will not integrate to any TOUT beyond the currently C specified TSTOP. Once TSTOP has been reached, you must change C the value of TSTOP or set INFO(4) = 0. You may change INFO(4) C or TSTOP at any time but you must supply the value of TSTOP in C RWORK(1) whenever you set INFO(4) = 1. C C Do not change INFO(5), INFO(6), INFO(12-17) or their associated C IWORK/RWORK locations unless you are going to restart the code. C C *** FOLLOWING A COMPLETED TASK *** C C If.. C IDID = 1, call the code again to continue the integration C another step in the direction of TOUT. C C IDID = 2 or 3, define a new TOUT and call the code again. C TOUT must be different from T. You cannot change C the direction of integration without restarting. C C IDID = 4, reset INFO(11) = 0 and call the code again to begin C the integration. (If you leave INFO(11) > 0 and C INFO(14) = 1, you may generate an infinite loop.) C In this situation, the next call to DASPK is C considered to be the first call for the problem, C in that all initializations are done. C C *** FOLLOWING AN INTERRUPTED TASK *** C C To show the code that you realize the task was interrupted and C that you want to continue, you must take appropriate action and C set INFO(1) = 1. C C If.. C IDID = -1, the code has taken about 500 steps. If you want to C continue, set INFO(1) = 1 and call the code again. C An additional 500 steps will be allowed. C C C IDID = -2, the error tolerances RTOL, ATOL have been increased C to values the code estimates appropriate for C continuing. You may want to change them yourself. C If you are sure you want to continue with relaxed C error tolerances, set INFO(1) = 1 and call the code C again. C C IDID = -3, a solution component is zero and you set the C corresponding component of ATOL to zero. If you C are sure you want to continue, you must first alter C the error criterion to use positive values of ATOL C for those components corresponding to zero solution C components, then set INFO(1) = 1 and call the code C again. C C IDID = -4 --- cannot occur with this code. C C IDID = -5, your JAC routine failed with the Krylov method. Check C for errors in JAC and restart the integration. C C IDID = -6, repeated error test failures occurred on the last C attempted step in DDASPK. A singularity in the C solution may be present. If you are absolutely C certain you want to continue, you should restart C the integration. (Provide initial values of Y and C YPRIME which are consistent.) C C IDID = -7, repeated convergence test failures occurred on the last C attempted step in DDASPK. An inaccurate or ill- C conditioned Jacobian or preconditioner may be the C problem. If you are absolutely certain you want C to continue, you should restart the integration. C C C IDID = -8, the matrix of partial derivatives is singular, with C the use of direct methods. Some of your equations C may be redundant. DDASPK cannot solve the problem C as stated. It is possible that the redundant C equations could be removed, and then DDASPK could C solve the problem. It is also possible that a C solution to your problem either does not exist C or is not unique. C C IDID = -9, DDASPK had multiple convergence test failures, preceded C by multiple error test failures, on the last C attempted step. It is possible that your problem is C ill-posed and cannot be solved using this code. Or, C there may be a discontinuity or a singularity in the C solution. If you are absolutely certain you want to C continue, you should restart the integration. C C IDID = -10, DDASPK had multiple convergence test failures C because IRES was equal to -1. If you are C absolutely certain you want to continue, you C should restart the integration. C C IDID = -11, there was an unrecoverable error (IRES = -2) from RES C inside the nonlinear system solver. Determine the C cause before trying again. C C IDID = -12, DDASPK failed to compute the initial Y and YPRIME C vectors. This could happen because the initial C approximation to Y or YPRIME was not very good, or C because no consistent values of these vectors exist. C The problem could also be caused by an inaccurate or C singular iteration matrix, or a poor preconditioner. C C IDID = -13, there was an unrecoverable error encountered inside C your PSOL routine. Determine the cause before C trying again. C C IDID = -14, the Krylov linear system solver failed to achieve C convergence. This may be due to ill-conditioning C in the iteration matrix, or a singularity in the C preconditioner (if one is being used). C Another possibility is that there is a better C choice of Krylov parameters (see INFO(13)). C Possibly the failure is caused by redundant equations C in the system, or by inconsistent equations. C In that case, reformulate the system to make it C consistent and non-redundant. C C IDID = -15,..,-32 --- Cannot occur with this code. C C *** FOLLOWING A TERMINATED TASK *** C C If IDID = -33, you cannot continue the solution of this problem. C An attempt to do so will result in your run being C terminated. C C --------------------------------------------------------------------- C C***REFERENCES C 1. L. R. Petzold, A Description of DASSL: A Differential/Algebraic C System Solver, in Scientific Computing, R. S. Stepleman et al. C (Eds.), North-Holland, Amsterdam, 1983, pp. 65-68. C 2. K. E. Brenan, S. L. Campbell, and L. R. Petzold, Numerical C Solution of Initial-Value Problems in Differential-Algebraic C Equations, Elsevier, New York, 1989. C 3. P. N. Brown and A. C. Hindmarsh, Reduced Storage Matrix Methods C in Stiff ODE Systems, J. Applied Mathematics and Computation, C 31 (1989), pp. 40-91. C 4. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Using Krylov C Methods in the Solution of Large-Scale Differential-Algebraic C Systems, SIAM J. Sci. Comp., 15 (1994), pp. 1467-1488. C 5. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Consistent C Initial Condition Calculation for Differential-Algebraic C Systems, LLNL Report UCRL-JC-122175, August 1995; submitted to C SIAM J. Sci. Comp. C C***ROUTINES CALLED C C The following are all the subordinate routines used by DDASPK. C C DDASIC computes consistent initial conditions. C DYYPNW updates Y and YPRIME in linesearch for initial condition C calculation. C DDSTP carries out one step of the integration. C DCNSTR/DCNST0 check the current solution for constraint violations. C DDAWTS sets error weight quantities. C DINVWT tests and inverts the error weights. C DDATRP performs interpolation to get an output solution. C DDWNRM computes the weighted root-mean-square norm of a vector. C D1MACH provides the unit roundoff of the computer. C XERRWD/XSETF/XSETUN/IXSAV is a package to handle error messages. C DDASID nonlinear equation driver to initialize Y and YPRIME using C direct linear system solver methods. Interfaces to Newton C solver (direct case). C DNSID solves the nonlinear system for unknown initial values by C modified Newton iteration and direct linear system methods. C DLINSD carries out linesearch algorithm for initial condition C calculation (direct case). C DFNRMD calculates weighted norm of preconditioned residual in C initial condition calculation (direct case). C DNEDD nonlinear equation driver for direct linear system solver C methods. Interfaces to Newton solver (direct case). C DMATD assembles the iteration matrix (direct case). C DNSD solves the associated nonlinear system by modified C Newton iteration and direct linear system methods. C DSLVD interfaces to linear system solver (direct case). C DDASIK nonlinear equation driver to initialize Y and YPRIME using C Krylov iterative linear system methods. Interfaces to C Newton solver (Krylov case). C DNSIK solves the nonlinear system for unknown initial values by C Newton iteration and Krylov iterative linear system methods. C DLINSK carries out linesearch algorithm for initial condition C calculation (Krylov case). C DFNRMK calculates weighted norm of preconditioned residual in C initial condition calculation (Krylov case). C DNEDK nonlinear equation driver for iterative linear system solver C methods. Interfaces to Newton solver (Krylov case). C DNSK solves the associated nonlinear system by Inexact Newton C iteration and (linear) Krylov iteration. C DSLVK interfaces to linear system solver (Krylov case). C DSPIGM solves a linear system by SPIGMR algorithm. C DATV computes matrix-vector product in Krylov algorithm. C DORTH performs orthogonalization of Krylov basis vectors. C DHEQR performs QR factorization of Hessenberg matrix. C DHELS finds least-squares solution of Hessenberg linear system. C DGEFA, DGESL, DGBFA, DGBSL are LINPACK routines for solving C linear systems (dense or band direct methods). C DAXPY, DCOPY, DDOT, DNRM2, DSCAL are Basic Linear Algebra (BLAS) C routines. C C The routines called directly by DDASPK are: C DCNST0, DDAWTS, DINVWT, D1MACH, DDWNRM, DDASIC, DDATRP, DDSTP, C XERRWD C C***END PROLOGUE DDASPK C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) LOGICAL DONE, LAVL, LCFN, LCFL, LWARN DIMENSION Y(*),YPRIME(*) DIMENSION INFO(25) ! Karline: increased from 20 -> 25 INTEGER NIND(3) ! added DIMENSION RWORK(LRW),IWORK(LIW) DIMENSION RTOL(*),ATOL(*) DIMENSION RPAR(*),IPAR(*) EXTERNAL RES, JAC, PSOL, DDASID, DDASIK, DNEDD, DNEDK C C Set pointers into IWORK. C PARAMETER (LML=1, LMU=2, LMTYPE=4, * LIWM=1, LMXORD=3, LJCALC=5, LPHASE=6, LK=7, LKOLD=8, * LNS=9, LNSTL=10, LNST=11, LNRE=12, LNJE=13, LETF=14, LNCFN=15, * LNCFL=16, LNIW=17, LNRW=18, LNNI=19, LNLI=20, LNPS=21, * LNPD=22, LMITER=23, LMAXL=24, LKMP=25, LNRMAX=26, LLNWP=27, * LLNIWP=28, LLOCWP=29, LLCIWP=30, LKPRIN=31, * LMXNIT=32, LMXNJ=33, LMXNH=34, LLSOFF=35, LICNS=41) C C Set pointers into RWORK. C PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, LCJ=5, LCJOLD=6, * LHOLD=7, LS=8, LROUND=9, LEPLI=10, LSQRN=11, LRSQRN=12, * LEPCON=13, LSTOL=14, LEPIN=15, * LALPHA=21, LBETA=27, LGAMMA=33, LPSI=39, LSIGMA=45, LDELTA=51) C SAVE LID, LENID, NONNEG C C C***FIRST EXECUTABLE STATEMENT DDASPK C C C Karline: the index of each variable DO I = 1, 3 NIND(I) = INFO(20+I) ENDDO C Karline: initialised some variables to avoid compiler warnings - should have no effect LENRW = 0 LENIW = 0 LENPD = 0 C Karline IF(INFO(1).NE.0) GO TO 100 C C----------------------------------------------------------------------- C This block is executed for the initial call only. C It contains checking of inputs and initializations. C----------------------------------------------------------------------- C C First check INFO array to make sure all elements of INFO C Are within the proper range. (INFO(1) is checked later, because C it must be tested on every call.) ITEMP holds the location C within INFO which may be out of range. C DO 10 I=2,9 ITEMP = I IF (INFO(I) .NE. 0 .AND. INFO(I) .NE. 1) GO TO 701 10 CONTINUE ITEMP = 10 IF(INFO(10).LT.0 .OR. INFO(10).GT.3) GO TO 701 ITEMP = 11 IF(INFO(11).LT.0 .OR. INFO(11).GT.2) GO TO 701 DO 15 I=12,17 ITEMP = I IF (INFO(I) .NE. 0 .AND. INFO(I) .NE. 1) GO TO 701 15 CONTINUE ITEMP = 18 IF(INFO(18).LT.0 .OR. INFO(18).GT.2) GO TO 701 C C Check NEQ to see if it is positive. C IF (NEQ .LE. 0) GO TO 702 C C Check and compute maximum order. C MXORD=5 IF (INFO(9) .NE. 0) THEN MXORD=IWORK(LMXORD) IF (MXORD .LT. 1 .OR. MXORD .GT. 5) GO TO 703 ENDIF IWORK(LMXORD)=MXORD C C Set and/or check inputs for constraint checking (INFO(10) .NE. 0). C Set values for ICNFLG, NONNEG, and pointer LID. C ICNFLG = 0 NONNEG = 0 LID = LICNS IF (INFO(10) .EQ. 0) GO TO 20 IF (INFO(10) .EQ. 1) THEN ICNFLG = 1 NONNEG = 0 LID = LICNS + NEQ ELSEIF (INFO(10) .EQ. 2) THEN ICNFLG = 0 NONNEG = 1 ELSE ICNFLG = 1 NONNEG = 1 LID = LICNS + NEQ ENDIF C 20 CONTINUE C C Set and/or check inputs for Krylov solver (INFO(12) .NE. 0). C If indicated, set default values for MAXL, KMP, NRMAX, and EPLI. C Otherwise, verify inputs required for iterative solver. C IF (INFO(12) .EQ. 0) GO TO 25 C IWORK(LMITER) = INFO(12) IF (INFO(13) .EQ. 0) THEN IWORK(LMAXL) = MIN(5,NEQ) IWORK(LKMP) = IWORK(LMAXL) IWORK(LNRMAX) = 5 RWORK(LEPLI) = 0.05D0 ELSE IF(IWORK(LMAXL) .LT. 1 .OR. IWORK(LMAXL) .GT. NEQ) GO TO 720 IF(IWORK(LKMP) .LT. 1 .OR. IWORK(LKMP) .GT. IWORK(LMAXL)) 1 GO TO 721 IF(IWORK(LNRMAX) .LT. 0) GO TO 722 IF(RWORK(LEPLI).LE.0.0D0 .OR. RWORK(LEPLI).GE.1.0D0)GO TO 723 ENDIF C 25 CONTINUE C C Set and/or check controls for the initial condition calculation C (INFO(11) .GT. 0). If indicated, set default values. C Otherwise, verify inputs required for iterative solver. C IF (INFO(11) .EQ. 0) GO TO 30 IF (INFO(17) .EQ. 0) THEN IWORK(LMXNIT) = 5 IF (INFO(12) .GT. 0) IWORK(LMXNIT) = 15 IWORK(LMXNJ) = 6 IF (INFO(12) .GT. 0) IWORK(LMXNJ) = 2 IWORK(LMXNH) = 5 IWORK(LLSOFF) = 0 RWORK(LEPIN) = 0.01D0 ELSE IF (IWORK(LMXNIT) .LE. 0) GO TO 725 IF (IWORK(LMXNJ) .LE. 0) GO TO 725 IF (IWORK(LMXNH) .LE. 0) GO TO 725 LSOFF = IWORK(LLSOFF) IF (LSOFF .LT. 0 .OR. LSOFF .GT. 1) GO TO 725 IF (RWORK(LEPIN) .LE. 0.0D0) GO TO 725 ENDIF C 30 CONTINUE C C Below is the computation and checking of the work array lengths C LENIW and LENRW, using direct methods (INFO(12) = 0) or C the Krylov methods (INFO(12) = 1). C LENIC = 0 IF (INFO(10) .EQ. 1 .OR. INFO(10) .EQ. 3) LENIC = NEQ LENID = 0 IF (INFO(11) .EQ. 1 .OR. INFO(16) .EQ. 1) LENID = NEQ IF (INFO(12) .EQ. 0) THEN C C Compute MTYPE, etc. Check ML and MU. C NCPHI = MAX(MXORD + 1, 4) IF(INFO(6).EQ.0) THEN LENPD = NEQ**2 LENRW = 50 + (NCPHI+3)*NEQ + LENPD IF(INFO(5).EQ.0) THEN IWORK(LMTYPE)=2 ELSE IWORK(LMTYPE)=1 ENDIF ELSE IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717 IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718 LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ IF(INFO(5).EQ.0) THEN IWORK(LMTYPE)=5 MBAND=IWORK(LML)+IWORK(LMU)+1 MSAVE=(NEQ/MBAND)+1 LENRW = 50 + (NCPHI+3)*NEQ + LENPD + 2*MSAVE ELSE IWORK(LMTYPE)=4 LENRW = 50 + (NCPHI+3)*NEQ + LENPD ENDIF ENDIF C C Compute LENIW, LENWP, LENIWP. C LENIW = 40 + LENIC + LENID + NEQ LENWP = 0 LENIWP = 0 C ELSE IF (INFO(12) .EQ. 1) THEN MAXL = IWORK(LMAXL) LENWP = IWORK(LLNWP) LENIWP = IWORK(LLNIWP) LENPD = (MAXL+3+MIN0(1,MAXL-IWORK(LKMP)))*NEQ 1 + (MAXL+3)*MAXL + 1 + LENWP LENRW = 50 + (IWORK(LMXORD)+5)*NEQ + LENPD LENIW = 40 + LENIC + LENID + LENIWP C ENDIF IF(INFO(16) .NE. 0) LENRW = LENRW + NEQ C C Check lengths of RWORK and IWORK. C IWORK(LNIW)=LENIW IWORK(LNRW)=LENRW IWORK(LNPD)=LENPD IWORK(LLOCWP) = LENPD-LENWP+1 IF(LRW.LT.LENRW)GO TO 704 IF(LIW.LT.LENIW)GO TO 705 C C Check ICNSTR for legality. C IF (LENIC .GT. 0) THEN DO 40 I = 1,NEQ ICI = IWORK(LICNS-1+I) IF (ICI .LT. -2 .OR. ICI .GT. 2) GO TO 726 40 CONTINUE ENDIF C C Check Y for consistency with constraints. C IF (LENIC .GT. 0) THEN CALL DCNST0(NEQ,Y,IWORK(LICNS),IRET) IF (IRET .NE. 0) GO TO 727 ENDIF C C Check ID for legality. C IF (LENID .GT. 0) THEN DO 50 I = 1,NEQ IDI = IWORK(LID-1+I) IF (IDI .NE. 1 .AND. IDI .NE. -1) GO TO 724 50 CONTINUE ENDIF C C Check to see that TOUT is different from T. C IF(TOUT .EQ. T)GO TO 719 C C Check HMAX. C IF(INFO(7) .NE. 0) THEN HMAX = RWORK(LHMAX) IF (HMAX .LE. 0.0D0) GO TO 710 ENDIF C C Initialize counters and other flags. C IWORK(LNST)=0 IWORK(LNRE)=0 IWORK(LNJE)=0 IWORK(LETF)=0 IWORK(LNCFN)=0 IWORK(LNNI)=0 IWORK(LNLI)=0 IWORK(LNPS)=0 IWORK(LNCFL)=0 IWORK(LKPRIN)=INFO(18) IDID=1 GO TO 200 C C----------------------------------------------------------------------- C This block is for continuation calls only. C Here we check INFO(1), and if the last step was interrupted, C we check whether appropriate action was taken. C----------------------------------------------------------------------- C 100 CONTINUE IF(INFO(1).EQ.1)GO TO 110 ITEMP = 1 IF(INFO(1).NE.-1)GO TO 701 C C If we are here, the last step was interrupted by an error C condition from DDSTP, and appropriate action was not taken. C This is a fatal error. C call rprintf( 1 'daspk-- warning.. the last step terminated with a negative') call rprintfi1( 2 'value of idid and no appropriate action was taken %i' & // char(0),idid) call rexit('- run terminated') RETURN 110 CONTINUE C C----------------------------------------------------------------------- C This block is executed on all calls. C C Counters are saved for later checks of performance. C Then the error tolerance parameters are checked, and the C work array pointers are set. C----------------------------------------------------------------------- C 200 CONTINUE C C Save counters for use later. C IWORK(LNSTL)=IWORK(LNST) NLI0 = IWORK(LNLI) NNI0 = IWORK(LNNI) NCFN0 = IWORK(LNCFN) NCFL0 = IWORK(LNCFL) NWARN = 0 C C Check RTOL and ATOL. C NZFLG = 0 RTOLI = RTOL(1) ATOLI = ATOL(1) DO 210 I=1,NEQ IF (INFO(2) .EQ. 1) RTOLI = RTOL(I) IF (INFO(2) .EQ. 1) ATOLI = ATOL(I) IF (RTOLI .GT. 0.0D0 .OR. ATOLI .GT. 0.0D0) NZFLG = 1 IF (RTOLI .LT. 0.0D0) GO TO 706 IF (ATOLI .LT. 0.0D0) GO TO 707 210 CONTINUE IF (NZFLG .EQ. 0) GO TO 708 C C Set pointers to RWORK and IWORK segments. C For direct methods, SAVR is not used. C IWORK(LLCIWP) = LID + LENID LSAVR = LDELTA IF (INFO(12) .NE. 0) LSAVR = LDELTA + NEQ LE = LSAVR + NEQ LWT = LE + NEQ LVT = LWT IF (INFO(16) .NE. 0) LVT = LWT + NEQ LPHI = LVT + NEQ LWM = LPHI + (IWORK(LMXORD)+1)*NEQ IF (INFO(1) .EQ. 1) GO TO 400 C C----------------------------------------------------------------------- C This block is executed on the initial call only. C Set the initial step size, the error weight vector, and PHI. C Compute unknown initial components of Y and YPRIME, if requested. C----------------------------------------------------------------------- C CONTINUE TN=T IDID=1 C C Set error weight array WT and altered weight array VT. C CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) C KARLINE IF(NIND(1) < NEQ)CALL SCALE(NEQ, NIND, RWORK(LWT), 1.d-1) !H not known yet CALL DINVWT(NEQ,RWORK(LWT),IER) IF (IER .NE. 0) GO TO 713 IF (INFO(16) .NE. 0) THEN DO 305 I = 1, NEQ RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) 305 CONTINUE ENDIF C C Compute unit roundoff and HMIN. C UROUND = D1MACH(4) RWORK(LROUND) = UROUND HMIN = 4.0D0*UROUND*MAX(ABS(T),ABS(TOUT)) C C Set/check STPTOL control for initial condition calculation. C IF (INFO(11) .NE. 0) THEN IF( INFO(17) .EQ. 0) THEN RWORK(LSTOL) = UROUND**.6667D0 ELSE IF (RWORK(LSTOL) .LE. 0.0D0) GO TO 725 ENDIF ENDIF C C Compute EPCON and square root of NEQ and its reciprocal, used C inside iterative solver. C RWORK(LEPCON) = 0.33D0 FLOATN = NEQ RWORK(LSQRN) = SQRT(FLOATN) RWORK(LRSQRN) = 1.D0/RWORK(LSQRN) C C Check initial interval to see that it is long enough. C TDIST = ABS(TOUT - T) IF(TDIST .LT. HMIN) GO TO 714 C C Check H0, if this was input. C IF (INFO(8) .EQ. 0) GO TO 310 H0 = RWORK(LH) IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 711 IF (H0 .EQ. 0.0D0) GO TO 712 GO TO 320 310 CONTINUE C C Compute initial stepsize, to be used by either C DDSTP or DDASIC, depending on INFO(11). C H0 = 0.001D0*TDIST YPNORM = DDWNRM(NEQ,YPRIME,RWORK(LVT),RPAR,IPAR) IF (YPNORM .GT. 0.5D0/H0) H0 = 0.5D0/YPNORM H0 = SIGN(H0,TOUT-T) C C Adjust H0 if necessary to meet HMAX bound. C 320 IF (INFO(7) .EQ. 0) GO TO 330 RH = ABS(H0)/RWORK(LHMAX) IF (RH .GT. 1.0D0) H0 = H0/RH C C Check against TSTOP, if applicable. C 330 IF (INFO(4) .EQ. 0) GO TO 340 TSTOP = RWORK(LTSTOP) IF ((TSTOP - T)*H0 .LT. 0.0D0) GO TO 715 IF ((T + H0 - TSTOP)*H0 .GT. 0.0D0) H0 = TSTOP - T IF ((TSTOP - TOUT)*H0 .LT. 0.0D0) GO TO 709 C 340 IF (INFO(11) .EQ. 0) GO TO 370 C C Compute unknown components of initial Y and YPRIME, depending C on INFO(11) and INFO(12). INFO(12) represents the nonlinear C solver type (direct/Krylov). Pass the name of the specific C nonlinear solver, depending on INFO(12). The location of the work C arrays SAVR, YIC, YPIC, PWK also differ in the two cases. C NWT = 1 EPCONI = RWORK(LEPIN)*RWORK(LEPCON) 350 IF (INFO(12) .EQ. 0) THEN LYIC = LPHI + 2*NEQ LYPIC = LYIC + NEQ LPWK = LYPIC CALL DDASIC(TN,Y,YPRIME,NEQ,INFO(11),IWORK(LID), * RES,JAC,PSOL,H0,RWORK(LWT),NWT,IDID,RPAR,IPAR, * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), * RWORK(LYIC),RWORK(LYPIC),RWORK(LPWK),RWORK(LWM),IWORK(LIWM), * HMIN,RWORK(LROUND),RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), * EPCONI,RWORK(LSTOL),INFO(15),ICNFLG,IWORK(LICNS),DDASID) ELSE IF (INFO(12) .EQ. 1) THEN LYIC = LWM LYPIC = LYIC + NEQ LPWK = LYPIC + NEQ CALL DDASIC(TN,Y,YPRIME,NEQ,INFO(11),IWORK(LID), * RES,JAC,PSOL,H0,RWORK(LWT),NWT,IDID,RPAR,IPAR, * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), * RWORK(LYIC),RWORK(LYPIC),RWORK(LPWK),RWORK(LWM),IWORK(LIWM), * HMIN,RWORK(LROUND),RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), * EPCONI,RWORK(LSTOL),INFO(15),ICNFLG,IWORK(LICNS),DDASIK) ENDIF C IF (IDID .LT. 0) GO TO 600 C C DDASIC was successful. If this was the first call to DDASIC, C update the WT array (with the current Y) and call it again. C IF (NWT .EQ. 2) GO TO 355 NWT = 2 CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) C KARLINE IF(NIND(1) < NEQ) CALL SCALE(NEQ, NIND, RWORK(LWT), H0) CALL DINVWT(NEQ,RWORK(LWT),IER) IF (IER .NE. 0) GO TO 713 GO TO 350 C C If INFO(14) = 1, return now with IDID = 4. C 355 IF (INFO(14) .EQ. 1) THEN IDID = 4 H = H0 IF (INFO(11) .EQ. 1) RWORK(LHOLD) = H0 GO TO 590 ENDIF C C Update the WT and VT arrays one more time, with the new Y. C CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) C KARLINE IF(NIND(1) < NEQ) CALL SCALE(NEQ, NIND, RWORK(LWT), H0) CALL DINVWT(NEQ,RWORK(LWT),IER) IF (IER .NE. 0) GO TO 713 IF (INFO(16) .NE. 0) THEN DO 357 I = 1, NEQ RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) 357 CONTINUE ENDIF C C Reset the initial stepsize to be used by DDSTP. C Use H0, if this was input. Otherwise, recompute H0, C and adjust it if necessary to meet HMAX bound. C IF (INFO(8) .NE. 0) THEN H0 = RWORK(LH) GO TO 360 ENDIF C H0 = 0.001D0*TDIST YPNORM = DDWNRM(NEQ,YPRIME,RWORK(LVT),RPAR,IPAR) IF (YPNORM .GT. 0.5D0/H0) H0 = 0.5D0/YPNORM H0 = SIGN(H0,TOUT-T) C 360 IF (INFO(7) .NE. 0) THEN RH = ABS(H0)/RWORK(LHMAX) IF (RH .GT. 1.0D0) H0 = H0/RH ENDIF C C Check against TSTOP, if applicable. C IF (INFO(4) .NE. 0) THEN TSTOP = RWORK(LTSTOP) IF ((T + H0 - TSTOP)*H0 .GT. 0.0D0) H0 = TSTOP - T ENDIF C C Load H and RWORK(LH) with H0. C 370 H = H0 RWORK(LH) = H C C Load Y and H*YPRIME into PHI(*,1) and PHI(*,2). C ITEMP = LPHI + NEQ DO 380 I = 1,NEQ RWORK(LPHI + I - 1) = Y(I) RWORK(ITEMP + I - 1) = H*YPRIME(I) 380 CONTINUE C GO TO 500 C C----------------------------------------------------------------------- C This block is for continuation calls only. C Its purpose is to check stop conditions before taking a step. C Adjust H if necessary to meet HMAX bound. C----------------------------------------------------------------------- C 400 CONTINUE UROUND=RWORK(LROUND) DONE = .FALSE. TN=RWORK(LTN) H=RWORK(LH) IF(INFO(7) .EQ. 0) GO TO 410 RH = ABS(H)/RWORK(LHMAX) IF(RH .GT. 1.0D0) H = H/RH 410 CONTINUE IF(T .EQ. TOUT) GO TO 719 IF((T - TOUT)*H .GT. 0.0D0) GO TO 711 IF(INFO(4) .EQ. 1) GO TO 430 IF(INFO(3) .EQ. 1) GO TO 420 IF((TN-TOUT)*H.LT.0.0D0)GO TO 490 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID = 3 DONE = .TRUE. GO TO 490 420 IF((TN-T)*H .LE. 0.0D0) GO TO 490 IF((TN - TOUT)*H .GT. 0.0D0) GO TO 425 CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TN IDID = 1 DONE = .TRUE. GO TO 490 425 CONTINUE CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TOUT IDID = 3 DONE = .TRUE. GO TO 490 430 IF(INFO(3) .EQ. 1) GO TO 440 TSTOP=RWORK(LTSTOP) IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715 IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709 IF((TN-TOUT)*H.LT.0.0D0)GO TO 450 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID = 3 DONE = .TRUE. GO TO 490 440 TSTOP = RWORK(LTSTOP) IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715 IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709 IF((TN-T)*H .LE. 0.0D0) GO TO 450 IF((TN - TOUT)*H .GT. 0.0D0) GO TO 445 CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TN IDID = 1 DONE = .TRUE. GO TO 490 445 CONTINUE CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TOUT IDID = 3 DONE = .TRUE. GO TO 490 450 CONTINUE C C Check whether we are within roundoff of TSTOP. C IF(ABS(TN-TSTOP).GT.100.0D0*UROUND* * (ABS(TN)+ABS(H)))GO TO 460 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP DONE = .TRUE. GO TO 490 460 TNEXT=TN+H IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490 H=TSTOP-TN RWORK(LH)=H C 490 IF (DONE) GO TO 590 C C----------------------------------------------------------------------- C The next block contains the call to the one-step integrator DDSTP. C This is a looping point for the integration steps. C Check for too many steps. C Check for poor Newton/Krylov performance. C Update WT. Check for too much accuracy requested. C Compute minimum stepsize. C----------------------------------------------------------------------- C 500 CONTINUE C C Check for too many steps. C IF((IWORK(LNST)-IWORK(LNSTL)).LT.500) GO TO 505 IDID=-1 GO TO 527 C C Check for poor Newton/Krylov performance. C 505 IF (INFO(12) .EQ. 0) GO TO 510 NSTD = IWORK(LNST) - IWORK(LNSTL) NNID = IWORK(LNNI) - NNI0 IF (NSTD .LT. 10 .OR. NNID .EQ. 0) GO TO 510 AVLIN = REAL(IWORK(LNLI) - NLI0)/REAL(NNID) RCFN = REAL(IWORK(LNCFN) - NCFN0)/REAL(NSTD) RCFL = REAL(IWORK(LNCFL) - NCFL0)/REAL(NNID) FMAXL = IWORK(LMAXL) LAVL = AVLIN .GT. FMAXL LCFN = RCFN .GT. 0.9D0 LCFL = RCFL .GT. 0.9D0 LWARN = LAVL .OR. LCFN .OR. LCFL IF (.NOT.LWARN) GO TO 510 NWARN = NWARN + 1 IF (NWARN .GT. 10) GO TO 510 IF (LAVL) THEN call rprintf( 1 'daspk-- warning.. Poor iterative algorithm performance' & // char(0)) call rprintfd2( 2 ' at T = R1. Average no. of linear iterations = R2' & // ' %g, %g' // char(0), TN, AVLIN) ENDIF IF (LCFN) THEN call rprintf( 1 'daspk-- warning.. Poor iterative algorithm performance ' & // char(0)) call rprintfd2( 2 ' at T = R1. Nonlinear convergence failure rate = R2' & // '%g, %g' // char(0), TN, RCFN) ENDIF IF (LCFL) THEN call rprintf( 1 'daspk-- warning.. Poor iterative algorithm performance ' & // char(0)) call rprintfd2( 2 ' at T = R1. Linear convergence failure rate = R2 ' & // char(0), TN, RCFL) ENDIF C C Update WT and VT, if this is not the first call. C 510 CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI),RWORK(LWT), * RPAR,IPAR) IF(NIND(1) < NEQ) CALL SCALE(NEQ, NIND, RWORK(LWT), H) CALL DINVWT(NEQ,RWORK(LWT),IER) IF (IER .NE. 0) THEN IDID = -3 GO TO 527 ENDIF IF (INFO(16) .NE. 0) THEN DO 515 I = 1, NEQ RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) 515 CONTINUE ENDIF C C Test for too much accuracy requested. C R = DDWNRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)*100.0D0*UROUND IF (R .LE. 1.0D0) GO TO 525 C C Multiply RTOL and ATOL by R and return. C IF(INFO(2).EQ.1)GO TO 523 RTOL(1)=R*RTOL(1) ATOL(1)=R*ATOL(1) IDID=-2 GO TO 527 523 DO 524 I=1,NEQ RTOL(I)=R*RTOL(I) ATOL(I)=R*ATOL(I) 524 CONTINUE IDID=-2 GO TO 527 525 CONTINUE C C Compute minimum stepsize. C HMIN=4.0D0*UROUND*MAX(ABS(TN),ABS(TOUT)) C C Test H vs. HMAX IF (INFO(7) .NE. 0) THEN RH = ABS(H)/RWORK(LHMAX) IF (RH .GT. 1.0D0) H = H/RH ENDIF C C Call the one-step integrator. C Note that INFO(12) represents the nonlinear solver type. C Pass the required nonlinear solver, depending upon INFO(12). C IF (INFO(12) .EQ. 0) THEN CALL DDSTP(TN,Y,YPRIME,NEQ, * RES,JAC,PSOL,H,RWORK(LWT),RWORK(LVT),INFO(1),IDID,RPAR,IPAR, * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), * RWORK(LWM),IWORK(LIWM), * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), * RWORK(LPSI),RWORK(LSIGMA), * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),RWORK(LS),HMIN, * RWORK(LROUND), RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), * RWORK(LEPCON), IWORK(LPHASE),IWORK(LJCALC),INFO(15), * IWORK(LK), IWORK(LKOLD),IWORK(LNS),NONNEG,INFO(12), * DNEDD) ELSE IF (INFO(12) .EQ. 1) THEN CALL DDSTP(TN,Y,YPRIME,NEQ, * RES,JAC,PSOL,H,RWORK(LWT),RWORK(LVT),INFO(1),IDID,RPAR,IPAR, * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), * RWORK(LWM),IWORK(LIWM), * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), * RWORK(LPSI),RWORK(LSIGMA), * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),RWORK(LS),HMIN, * RWORK(LROUND), RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), * RWORK(LEPCON), IWORK(LPHASE),IWORK(LJCALC),INFO(15), * IWORK(LK), IWORK(LKOLD),IWORK(LNS),NONNEG,INFO(12), * DNEDK) ENDIF C 527 IF(IDID.LT.0)GO TO 600 C C----------------------------------------------------------------------- C This block handles the case of a successful return from DDSTP C (IDID=1). Test for stop conditions. C----------------------------------------------------------------------- C IF(INFO(4).NE.0)GO TO 540 IF(INFO(3).NE.0)GO TO 530 IF((TN-TOUT)*H.LT.0.0D0)GO TO 500 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=3 T=TOUT GO TO 580 530 IF((TN-TOUT)*H.GE.0.0D0)GO TO 535 T=TN IDID=1 GO TO 580 535 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=3 T=TOUT GO TO 580 540 IF(INFO(3).NE.0)GO TO 550 IF((TN-TOUT)*H.LT.0.0D0)GO TO 542 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID=3 GO TO 580 542 IF(ABS(TN-TSTOP).LE.100.0D0*UROUND* * (ABS(TN)+ABS(H)))GO TO 545 TNEXT=TN+H IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 500 H=TSTOP-TN GO TO 500 545 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP GO TO 580 550 IF((TN-TOUT)*H.GE.0.0D0)GO TO 555 IF(ABS(TN-TSTOP).LE.100.0D0*UROUND*(ABS(TN)+ABS(H)))GO TO 552 T=TN IDID=1 GO TO 580 552 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP GO TO 580 555 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID=3 580 CONTINUE C C----------------------------------------------------------------------- C All successful returns from DDASPK are made from this block. C----------------------------------------------------------------------- C 590 CONTINUE RWORK(LTN)=TN RWORK(LH)=H RETURN C C----------------------------------------------------------------------- C This block handles all unsuccessful returns other than for C illegal input. C----------------------------------------------------------------------- C 600 CONTINUE ITEMP = -IDID IF (ITEMP .EQ. 1) THEN GOTO 610 ELSE IF (ITEMP .EQ. 2) THEN GOTO 620 ELSE IF (ITEMP .EQ. 3) THEN GOTO 630 ELSE IF (ITEMP .EQ. 4) THEN GOTO 700 ELSE IF (ITEMP .EQ. 5) THEN GOTO 655 ELSE IF (ITEMP .EQ. 6) THEN GOTO 640 ELSE IF (ITEMP .EQ. 7) THEN GOTO 650 ELSE IF (ITEMP .EQ. 8) THEN GOTO 660 ELSE IF (ITEMP .EQ. 9) THEN GOTO 670 ELSE IF (ITEMP .EQ. 10) THEN GOTO 675 ELSE IF (ITEMP .EQ. 11) THEN GOTO 680 ELSE IF (ITEMP .EQ. 12) THEN GOTO 685 ELSE IF (ITEMP .EQ. 13) THEN GOTO 690 ELSE IF (ITEMP .EQ. 14) THEN GOTO 695 ENDIF C GO TO (610,620,630,700,655,640,650,660,670,675, C * 680,685,690,695), ITEMP C C The maximum number of steps was taken before C reaching tout. C! Karline toggled this off, version > 1.10.3 unless lots of printing requested 610 IF(IWORK(LKPRIN) .GE. 2) THEN call rprintf( 1 'daspk-- warning.. At current T (=R1) max number steps' & // char(0)) call rprintfd1( 2 ' on this call before reaching tout %g' // char(0), TN) ENDIF GO TO 700 C C Too much accuracy for machine precision. C 620 call rprintf( 1 'daspk-- warning.. At T(=R1) too much accuracy requested' & // char(0)) call rprintf( 2 ' for precision of machine. rtol and atol were' // char(0)) call rprintfd1( 3 ' increased to appropriate values %g' & // char(0), TN ) GO TO 700 C C WT(I) .LE. 0.0D0 for some I (not at start of problem). C 630 call rprintf( 1 'daspk-- warning.. At T(=R1) some element of WT ' // char(0)) call rprintfd1( 2 ' has become less or equal than 0 %g' // char(0), TN ) GO TO 700 C C Error test failed repeatedly or with H=HMIN. C 640 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2)' & //char(0)) call rprintfd2( 2 ' error test failed repeatedly or with abs(H)=Hmin' & // ' %g, %g' // char(0), TN, H ) GO TO 700 C C Nonlinear solver failed to converge repeatedly or with H=HMIN. C 650 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2) the' & // char(0)) call rprintf( 2 ' nonlinear solver failed to converge ' // char(0)) call rprintfd2( 3 ' repeatedly of with abs (H) = HMIN &g, %g' & // char(0), TN, H) GO TO 700 C C The preconditioner had repeated failures. C 655 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2) the' & // char(0)) call rprintfd2( 2 ' preconditioner had repeated failures %g, %g' & // char(0), TN, H ) GO TO 700 C C The iteration matrix is singular. C 660 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2) the' & // char(0)) call rprintfd2( 2 ' iteration matrix is singular %g, %g' & // char(0), TN, H) GO TO 700 C C Nonlinear system failure preceded by error test failures. C 670 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2) the' & // char(0)) call rprintf( 2 ' nonlinear solver could not converge ' // char(0)) call rprintfd2( 3 ' Also the error test failed repeatedly %g, %g' & // char(0), TN, H ) GO TO 700 C C Nonlinear system failure because IRES = -1. C 675 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2) the' & // char(0)) call rprintf( 2 ' nonlinear system solver could not converge' & // char(0)) call rprintfd2( 3 ' because ires was equal to -1 %g, %g' & // char(0), TN, H) GO TO 700 C C Failure because IRES = -2. C 680 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2)' // char(0)) call rprintfd2( 2 ' ires was equal to -2 &g, %g' // char(0), TN, H ) GO TO 700 C C Failed to compute initial YPRIME. C 685 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2) the' & // char(0)) call rprintfd2( 2 ' initial yprime could not be computed %g, %g' & // char(0), TN, H0 ) GO TO 700 C C Failure because IER was negative from PSOL. C 690 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2)' // char(0)) call rprintfd2( 2 ' IER was negative from psol %g, %g' // char(0), TN, H) GO TO 700 C C Failure because the linear system solver could not converge. C 695 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2) the' & // char(0)) call rprintfd2( 2 ' linear system solver could not converge %g, %g' & // char(0), TN,H ) GO TO 700 C C 700 CONTINUE INFO(1)=-1 T=TN RWORK(LTN)=TN RWORK(LH)=H RETURN C C----------------------------------------------------------------------- C This block handles all error returns due to illegal input, C as detected before calling DDSTP. C First the error message routine is called. If this happens C twice in succession, execution is terminated. C----------------------------------------------------------------------- C 701 call rprintfi1( 1 'daspk-- element (= %i) of info vector is not valid' & // char(0),ITEMP) GO TO 750 702 call rprintfi1( 1 'daspk-- neq (= %i) < 0' // char(0), NEQ) GO TO 750 703 call rprintfi1( 1 'daspk-- maxord (= %i) not in range' // char(0), MXORD) GO TO 750 704 call rprintfi2( 1 'daspk-- rwork length needed, LENRW(= %i) exceeds LRW(= %i)' & // char(0), LENRW, LRW) GO TO 750 705 call rprintfi2( 1 'daspk-- iwork length needed, LENIW(= %i) exceeds LIW(= %i)' & // char(0), LENIW, LIW) GO TO 750 706 call rprintf( 1 'daspk-- some element of rtol is < 0' // char(0)) GO TO 750 707 call rprintf( 1 'daspk-- some element of atol is < 0' // char(0)) GO TO 750 708 call rprintf( 1 'daspk-- all elements of rtol and atol are 0' // char(0)) GO TO 750 709 call rprintfd2( 1 'daspk-- INFO(4)=1 and TSTOP (= %g) behind TOUT (= %g)' & // char(0),TSTOP,TOUT) GO TO 750 710 call rprintfd1( 1 'daspk-- HMAX (= %g) < 0' // char(0), HMAX) GO TO 750 711 call rprintfd2( 1 'daspk-- TOUT (= %g) behind T (= %g)' // char(0), TOUT, T) GO TO 750 712 call rprintf( 1 'daspk-- INFO(8)=1 and H0=0' // char(0)) GO TO 750 713 call rprintf( 1 'daspk-- some element of WT <= 0 ' // char(0)) GO TO 750 714 call rprintfd2( 1 'daspk-- TOUT (= %g) too close to T (= %g)' & // ' to start integration ' // char(0), TOUT, T) GO TO 750 715 call rprintfd2( 1 'daspk-- INFO(4)=1 and TSTOP (= %g) behind T (= %g)' & // char(0), TSTOP, T) GO TO 750 717 call rprintfi1( 1 'daspk-- ML (= %i) illegal - either < 0 or > neq' & // char(0),IWORK(LML)) GO TO 750 718 call rprintfi1( 1 'daspk-- MU (= %i) illegal - either < 0 or > neq' & // char(0),IWORK(LMU)) GO TO 750 719 call rprintfd2( 1 'daspk-- TOUT (= %g) is equal to T (= %g)' & // char(0),TOUT,T) GO TO 750 720 call rprintfi1( 1 'daspk-- MAXL (= %i) illegal - either < 1 or > neq' & // char(0), IWORK(LMAXL)) GO TO 750 721 call rprintfi1( 1 'daspk-- KMP (= %i) illegal - either < 1 or > MAXL' & // char(0), IWORK(LKMP)) GO TO 750 722 call rprintfi1( 1 'daspk-- NRMAX (= %i) illegal - < 0 ' & // char(0),IWORK(LNRMAX)) GO TO 750 723 call rprintfd1( 1 'daspk-- EPLI (= %g) illegal - either <= 0 or >= 1' & // char(0),RWORK(LEPLI)) GO TO 750 724 call rprintf( 1 'daspk-- illegal IWORK value for INFO(11) not equal to 0' & // char(0)) GO TO 750 725 call rprintf( 1 'daspk-- one of the inputs for INFO(17) = 1 is illegal' & // char(0)) GO TO 750 726 call rprintf( 1 'daspk-- illegal IWORK value for INFO(10) not equal to 0' & // char(0)) GO TO 750 727 call rprintfi1( 1 'daspk-- Y(I) and IWORK(40+I) (I= %i) inconsistent' & // char(0), IRET ) GO TO 750 750 IF(INFO(1).EQ.-1) GO TO 760 INFO(1)=-1 IDID=-33 RETURN 760 call rprintf( 1 'daspk-- repeated occurrences of illegal input' // char(0)) call rprintf( 1 'daspk-- run terminated; apparent infinite loop' // char(0)) RETURN C C------END OF SUBROUTINE DDASPK----------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DDASIC (X, Y, YPRIME, NEQ, ICOPT, ID, RES, JAC, PSOL, * H, WT, NIC, IDID, RPAR, IPAR, PHI, SAVR, DELTA, E, YIC, YPIC, * PWK, WM, IWM, HMIN, UROUND, EPLI, SQRTN, RSQRTN, EPCONI, * STPTOL, JFLG, ICNFLG, ICNSTR, NLSIC) C C***BEGIN PROLOGUE DDASIC C***REFER TO DDASPK C***DATE WRITTEN 940628 (YYMMDD) C***REVISION DATE 941206 (YYMMDD) C***REVISION DATE 950714 (YYMMDD) C C----------------------------------------------------------------------- C***DESCRIPTION C C DDASIC is a driver routine to compute consistent initial values C for Y and YPRIME. There are two different options: C Denoting the differential variables in Y by Y_d, and C the algebraic variables by Y_a, the problem solved is either: C 1. Given Y_d, calculate Y_a and Y_d', or C 2. Given Y', calculate Y. C In either case, initial values for the given components C are input, and initial guesses for the unknown components C must also be provided as input. C C The external routine NLSIC solves the resulting nonlinear system. C C The parameters represent C C X -- Independent variable. C Y -- Solution vector at X. C YPRIME -- Derivative of solution vector. C NEQ -- Number of equations to be integrated. C ICOPT -- Flag indicating initial condition option chosen. C ICOPT = 1 for option 1 above. C ICOPT = 2 for option 2. C ID -- Array of dimension NEQ, which must be initialized C if option 1 is chosen. C ID(i) = +1 if Y_i is a differential variable, C ID(i) = -1 if Y_i is an algebraic variable. C RES -- External user-supplied subroutine to evaluate the C residual. See RES description in DDASPK prologue. C JAC -- External user-supplied routine to update Jacobian C or preconditioner information in the nonlinear solver C (optional). See JAC description in DDASPK prologue. C PSOL -- External user-supplied routine to solve C a linear system using preconditioning. C See PSOL in DDASPK prologue. C H -- Scaling factor in iteration matrix. DDASIC may C reduce H to achieve convergence. C WT -- Vector of weights for error criterion. C NIC -- Input number of initial condition calculation call C (= 1 or 2). C IDID -- Completion code. See IDID in DDASPK prologue. C RPAR,IPAR -- Real and integer parameter arrays that C are used for communication between the C calling program and external user routines. C They are not altered by DNSK C PHI -- Work space for DDASIC of length at least 2*NEQ. C SAVR -- Work vector for DDASIC of length NEQ. C DELTA -- Work vector for DDASIC of length NEQ. C E -- Work vector for DDASIC of length NEQ. C YIC,YPIC -- Work vectors for DDASIC, each of length NEQ. C PWK -- Work vector for DDASIC of length NEQ. C WM,IWM -- Real and integer arrays storing C information required by the linear solver. C EPCONI -- Test constant for Newton iteration convergence. C ICNFLG -- Flag showing whether constraints on Y are to apply. C ICNSTR -- Integer array of length NEQ with constraint types. C C The other parameters are for use internally by DDASIC. C C----------------------------------------------------------------------- C***ROUTINES CALLED C DCOPY, NLSIC C C***END PROLOGUE DDASIC C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),ID(*),WT(*),PHI(NEQ,*) DIMENSION SAVR(*),DELTA(*),E(*),YIC(*),YPIC(*),PWK(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*), ICNSTR(*) EXTERNAL RES, JAC, PSOL, NLSIC C PARAMETER (LCFN=15) PARAMETER (LMXNH=34) C C The following parameters are data-loaded here: C RHCUT = factor by which H is reduced on retry of Newton solve. C RATEMX = maximum convergence rate for which Newton iteration C is considered converging. C SAVE RHCUT, RATEMX DATA RHCUT/0.1D0/, RATEMX/0.8D0/ C C C----------------------------------------------------------------------- C BLOCK 1. C Initializations. C JSKIP is a flag set to 1 when NIC = 2 and NH = 1, to signal that C the initial call to the JAC routine is to be skipped then. C Save Y and YPRIME in PHI. Initialize IDID, NH, and CJ. C----------------------------------------------------------------------- C MXNH = IWM(LMXNH) IDID = 1 NH = 1 JSKIP = 0 IF (NIC .EQ. 2) JSKIP = 1 CALL DCOPY (NEQ, Y, 1, PHI(1,1), 1) CALL DCOPY (NEQ, YPRIME, 1, PHI(1,2), 1) C IF (ICOPT .EQ. 2) THEN CJ = 0.0D0 ELSE CJ = 1.0D0/H ENDIF C C----------------------------------------------------------------------- C BLOCK 2 C Call the nonlinear system solver to obtain C consistent initial values for Y and YPRIME. C----------------------------------------------------------------------- C 200 CONTINUE CALL NLSIC(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JAC,PSOL,H,WT,JSKIP, * RPAR,IPAR,SAVR,DELTA,E,YIC,YPIC,PWK,WM,IWM,CJ,UROUND, * EPLI,SQRTN,RSQRTN,EPCONI,RATEMX,STPTOL,JFLG,ICNFLG,ICNSTR, * IERNLS) C IF (IERNLS .EQ. 0) RETURN C C----------------------------------------------------------------------- C BLOCK 3 C The nonlinear solver was unsuccessful. Increment NCFN. C Return with IDID = -12 if either C IERNLS = -1: error is considered unrecoverable, C ICOPT = 2: we are doing initialization problem type 2, or C NH = MXNH: the maximum number of H values has been tried. C Otherwise (problem 1 with IERNLS .GE. 1), reduce H and try again. C If IERNLS > 1, restore Y and YPRIME to their original values. C----------------------------------------------------------------------- C IWM(LCFN) = IWM(LCFN) + 1 JSKIP = 0 C IF (IERNLS .EQ. -1) GO TO 350 IF (ICOPT .EQ. 2) GO TO 350 IF (NH .EQ. MXNH) GO TO 350 C NH = NH + 1 H = H*RHCUT CJ = 1.0D0/H C IF (IERNLS .EQ. 1) GO TO 200 C CALL DCOPY (NEQ, PHI(1,1), 1, Y, 1) CALL DCOPY (NEQ, PHI(1,2), 1, YPRIME, 1) GO TO 200 C 350 IDID = -12 RETURN C C------END OF SUBROUTINE DDASIC----------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DYYPNW (NEQ, Y, YPRIME, CJ, RL, P, ICOPT, ID, * YNEW, YPNEW) C C***BEGIN PROLOGUE DYYPNW C***REFER TO DLINSK C***DATE WRITTEN 940830 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DYYPNW calculates the new (Y,YPRIME) pair needed in the C linesearch algorithm based on the current lambda value. It is C called by DLINSK and DLINSD. Based on the ICOPT and ID values, C the corresponding entry in Y or YPRIME is updated. C C In addition to the parameters described in the calling programs, C the parameters represent C C P -- Array of length NEQ that contains the current C approximate Newton step. C RL -- Scalar containing the current lambda value. C YNEW -- Array of length NEQ containing the updated Y vector. C YPNEW -- Array of length NEQ containing the updated YPRIME C vector. C----------------------------------------------------------------------- C C***ROUTINES CALLED (NONE) C C***END PROLOGUE DYYPNW C C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION Y(*), YPRIME(*), YNEW(*), YPNEW(*), ID(*), P(*) C IF (ICOPT .EQ. 1) THEN DO 10 I=1,NEQ IF(ID(I) .LT. 0) THEN YNEW(I) = Y(I) - RL*P(I) YPNEW(I) = YPRIME(I) ELSE YNEW(I) = Y(I) YPNEW(I) = YPRIME(I) - RL*CJ*P(I) ENDIF 10 CONTINUE ELSE DO 20 I = 1,NEQ YNEW(I) = Y(I) - RL*P(I) YPNEW(I) = YPRIME(I) 20 CONTINUE ENDIF RETURN C----------------------- END OF SUBROUTINE DYYPNW ---------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DDSTP(X,Y,YPRIME,NEQ,RES,JAC,PSOL,H,WT,VT, * JSTART,IDID,RPAR,IPAR,PHI,SAVR,DELTA,E,WM,IWM, * ALPHA,BETA,GAMMA,PSI,SIGMA,CJ,CJOLD,HOLD,S,HMIN,UROUND, * EPLI,SQRTN,RSQRTN,EPCON,IPHASE,JCALC,JFLG,K,KOLD,NS,NONNEG, * NTYPE,NLS) C C***BEGIN PROLOGUE DDSTP C***REFER TO DDASPK C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***REVISION DATE 940909 (YYMMDD) (Reset PSI(1), PHI(*,2) at 690) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DDSTP solves a system of differential/algebraic equations of C the form G(X,Y,YPRIME) = 0, for one step (normally from X to X+H). C C The methods used are modified divided difference, fixed leading C coefficient forms of backward differentiation formulas. C The code adjusts the stepsize and order to control the local error C per step. C C C The parameters represent C X -- Independent variable. C Y -- Solution vector at X. C YPRIME -- Derivative of solution vector C after successful step. C NEQ -- Number of equations to be integrated. C RES -- External user-supplied subroutine C to evaluate the residual. See RES description C in DDASPK prologue. C JAC -- External user-supplied routine to update C Jacobian or preconditioner information in the C nonlinear solver. See JAC description in DDASPK C prologue. C PSOL -- External user-supplied routine to solve C a linear system using preconditioning. C (This is optional). See PSOL in DDASPK prologue. C H -- Appropriate step size for next step. C Normally determined by the code. C WT -- Vector of weights for error criterion used in Newton test. C VT -- Masked vector of weights used in error test. C JSTART -- Integer variable set 0 for C first step, 1 otherwise. C IDID -- Completion code returned from the nonlinear solver. C See IDID description in DDASPK prologue. C RPAR,IPAR -- Real and integer parameter arrays that C are used for communication between the C calling program and external user routines. C They are not altered by DNSK C PHI -- Array of divided differences used by C DDSTP. The length is NEQ*(K+1), where C K is the maximum order. C SAVR -- Work vector for DDSTP of length NEQ. C DELTA,E -- Work vectors for DDSTP of length NEQ. C WM,IWM -- Real and integer arrays storing C information required by the linear solver. C C The other parameters are information C which is needed internally by DDSTP to C continue from step to step. C C----------------------------------------------------------------------- C***ROUTINES CALLED C NLS, DDWNRM, DDATRP C C***END PROLOGUE DDSTP C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),WT(*),VT(*) DIMENSION PHI(NEQ,*),SAVR(*),DELTA(*),E(*) DIMENSION WM(*),IWM(*) DIMENSION PSI(*),ALPHA(*),BETA(*),GAMMA(*),SIGMA(*) DIMENSION RPAR(*),IPAR(*) EXTERNAL RES, JAC, PSOL, NLS C PARAMETER (LMXORD=3) PARAMETER (LNST=11, LETF=14, LCFN=15) C C C----------------------------------------------------------------------- C BLOCK 1. C Initialize. On the first call, set C the order to 1 and initialize C other variables. C----------------------------------------------------------------------- C C Initializations for all calls C TERKM1 = 0.D0 ! KARLINE: INITIALISED TO AVOID WARNING KNEW = 1 ! INITIALISED ERKM1 = 1.D0 ! INITIALISED EST = 0.D0 ! INITIALISED - should have no effect XOLD=X NCF=0 NEF=0 IF(JSTART .NE. 0) GO TO 120 C C If this is the first step, perform C other initializations C K=1 KOLD=0 HOLD=0.0D0 PSI(1)=H CJ = 1.D0/H IPHASE = 0 NS=0 120 CONTINUE C C C C C C----------------------------------------------------------------------- C BLOCK 2 C Compute coefficients of formulas for C this step. C----------------------------------------------------------------------- 200 CONTINUE KP1=K+1 KP2=K+2 KM1=K-1 IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0 NS=MIN0(NS+1,KOLD+2) NSP1=NS+1 IF(KP1 .LT. NS)GO TO 230 C BETA(1)=1.0D0 ALPHA(1)=1.0D0 TEMP1=H GAMMA(1)=0.0D0 SIGMA(1)=1.0D0 DO 210 I=2,KP1 TEMP2=PSI(I-1) PSI(I-1)=TEMP1 BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2 TEMP1=TEMP2+H ALPHA(I)=H/TEMP1 SIGMA(I)=(I-1)*SIGMA(I-1)*ALPHA(I) GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H 210 CONTINUE PSI(KP1)=TEMP1 230 CONTINUE C C Compute ALPHAS, ALPHA0 C ALPHAS = 0.0D0 ALPHA0 = 0.0D0 DO 240 I = 1,K ALPHAS = ALPHAS - 1.0D0/I ALPHA0 = ALPHA0 - ALPHA(I) 240 CONTINUE C C Compute leading coefficient CJ C CJLAST = CJ CJ = -ALPHAS/H C C Compute variable stepsize error coefficient CK C CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0) CK = MAX(CK,ALPHA(KP1)) C C Change PHI to PHI STAR C IF(KP1 .LT. NSP1) GO TO 280 DO 270 J=NSP1,KP1 DO 260 I=1,NEQ PHI(I,J)=BETA(J)*PHI(I,J) 260 CONTINUE 270 CONTINUE 280 CONTINUE C C Update time C X=X+H C C Initialize IDID to 1 C IDID = 1 C C C C C C----------------------------------------------------------------------- C BLOCK 3 C Call the nonlinear system solver to obtain the solution and C derivative. C----------------------------------------------------------------------- C CALL NLS(X,Y,YPRIME,NEQ, * RES,JAC,PSOL,H,WT,JSTART,IDID,RPAR,IPAR,PHI,GAMMA, * SAVR,DELTA,E,WM,IWM,CJ,CJOLD,CJLAST,S, * UROUND,EPLI,SQRTN,RSQRTN,EPCON,JCALC,JFLG,KP1, * NONNEG,NTYPE,IERNLS) C IF(IERNLS .NE. 0)GO TO 600 C C C C C C----------------------------------------------------------------------- C BLOCK 4 C Estimate the errors at orders K,K-1,K-2 C as if constant stepsize was used. Estimate C the local error at order K and test C whether the current step is successful. C----------------------------------------------------------------------- C C Estimate errors at orders K,K-1,K-2 C ENORM = DDWNRM(NEQ,E,VT,RPAR,IPAR) ERK = SIGMA(K+1)*ENORM TERK = (K+1)*ERK EST = ERK KNEW=K IF(K .EQ. 1)GO TO 430 DO 405 I = 1,NEQ DELTA(I) = PHI(I,KP1) + E(I) 405 CONTINUE ERKM1=SIGMA(K)*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) TERKM1 = K*ERKM1 IF(K .GT. 2)GO TO 410 IF(TERKM1 .LE. 0.5*TERK)GO TO 420 GO TO 430 410 CONTINUE DO 415 I = 1,NEQ DELTA(I) = PHI(I,K) + DELTA(I) 415 CONTINUE ERKM2=SIGMA(K-1)*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) TERKM2 = (K-1)*ERKM2 IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430 C C Lower the order C 420 CONTINUE KNEW=K-1 EST = ERKM1 C C C Calculate the local error for the current step C to see if the step was successful C 430 CONTINUE ERR = CK * ENORM IF(ERR .GT. 1.0D0)GO TO 600 C C C C C C----------------------------------------------------------------------- C BLOCK 5 C The step is successful. Determine C the best order and stepsize for C the next step. Update the differences C for the next step. C----------------------------------------------------------------------- IDID=1 IWM(LNST)=IWM(LNST)+1 KDIFF=K-KOLD KOLD=K HOLD=H C C C Estimate the error at order K+1 unless C already decided to lower order, or C already using maximum order, or C stepsize not constant, or C order raised in previous step C IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1 IF(IPHASE .EQ. 0)GO TO 545 IF(KNEW.EQ.KM1)GO TO 540 IF(K.EQ.IWM(LMXORD)) GO TO 550 IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550 DO 510 I=1,NEQ DELTA(I)=E(I)-PHI(I,KP2) 510 CONTINUE ERKP1 = (1.0D0/(K+2))*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) TERKP1 = (K+2)*ERKP1 IF(K.GT.1)GO TO 520 IF(TERKP1.GE.0.5D0*TERK)GO TO 550 GO TO 530 520 IF(TERKM1.LE.MIN(TERK,TERKP1))GO TO 540 IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550 C C Raise order C 530 K=KP1 EST = ERKP1 GO TO 550 C C Lower order C 540 K=KM1 EST = ERKM1 GO TO 550 C C If IPHASE = 0, increase order by one and multiply stepsize by C factor two C 545 K = KP1 HNEW = H*2.0D0 H = HNEW GO TO 575 C C C Determine the appropriate stepsize for C the next step. C 550 HNEW=H TEMP2=K+1 R=(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) IF(R .LT. 2.0D0) GO TO 555 HNEW = 2.0D0*H GO TO 560 555 IF(R .GT. 1.0D0) GO TO 560 R = MAX(0.5D0,MIN(0.9D0,R)) HNEW = H*R 560 H=HNEW C C C Update differences for next step C 575 CONTINUE IF(KOLD.EQ.IWM(LMXORD))GO TO 585 DO 580 I=1,NEQ PHI(I,KP2)=E(I) 580 CONTINUE 585 CONTINUE DO 590 I=1,NEQ PHI(I,KP1)=PHI(I,KP1)+E(I) 590 CONTINUE DO 596 J1=2,KP1 J=KP1-J1+1 DO 595 I=1,NEQ PHI(I,J)=PHI(I,J)+PHI(I,J+1) 595 CONTINUE 596 CONTINUE JSTART = 1 RETURN C C C C C C----------------------------------------------------------------------- C BLOCK 6 C The step is unsuccessful. Restore X,PSI,PHI C Determine appropriate stepsize for C continuing the integration, or exit with C an error flag if there have been many C failures. C----------------------------------------------------------------------- 600 IPHASE = 1 C C Restore X,PHI,PSI C X=XOLD IF(KP1.LT.NSP1)GO TO 630 DO 620 J=NSP1,KP1 TEMP1=1.0D0/BETA(J) DO 610 I=1,NEQ PHI(I,J)=TEMP1*PHI(I,J) 610 CONTINUE 620 CONTINUE 630 CONTINUE DO 640 I=2,KP1 PSI(I-1)=PSI(I)-H 640 CONTINUE C C C Test whether failure is due to nonlinear solver C or error test C IF(IERNLS .EQ. 0)GO TO 660 IWM(LCFN)=IWM(LCFN)+1 C C C The nonlinear solver failed to converge. C Determine the cause of the failure and take appropriate action. C If IERNLS .LT. 0, then return. Otherwise, reduce the stepsize C and try again, unless too many failures have occurred. C IF (IERNLS .LT. 0) GO TO 675 NCF = NCF + 1 R = 0.25D0 H = H*R IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690 IF (IDID .EQ. 1) IDID = -7 IF (NEF .GE. 3) IDID = -9 GO TO 675 C C C The nonlinear solver converged, and the cause C of the failure was the error estimate C exceeding the tolerance. C 660 NEF=NEF+1 IWM(LETF)=IWM(LETF)+1 IF (NEF .GT. 1) GO TO 665 C C On first error test failure, keep current order or lower C order by one. Compute new stepsize based on differences C of the solution. C K = KNEW TEMP2 = K + 1 R = 0.90D0*(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) R = MAX(0.25D0,MIN(0.9D0,R)) H = H*R IF (ABS(H) .GE. HMIN) GO TO 690 IDID = -6 GO TO 675 C C On second error test failure, use the current order or C decrease order by one. Reduce the stepsize by a factor of C one quarter. C 665 IF (NEF .GT. 2) GO TO 670 K = KNEW R = 0.25D0 H = R*H IF (ABS(H) .GE. HMIN) GO TO 690 IDID = -6 GO TO 675 C C On third and subsequent error test failures, set the order to C one, and reduce the stepsize by a factor of one quarter. C 670 K = 1 R = 0.25D0 H = R*H IF (ABS(H) .GE. HMIN) GO TO 690 IDID = -6 GO TO 675 C C C C C For all crashes, restore Y to its last value, C interpolate to find YPRIME at last X, and return. C C Before returning, verify that the user has not set C IDID to a nonnegative value. If the user has set IDID C to a nonnegative value, then reset IDID to be -7, indicating C a failure in the nonlinear system solver. C 675 CONTINUE CALL DDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI) JSTART = 1 IF (IDID .GE. 0) IDID = -7 RETURN C C C Go back and try this step again. C If this is the first step, reset PSI(1) and rescale PHI(*,2). C 690 IF (KOLD .EQ. 0) THEN PSI(1) = H DO 695 I = 1,NEQ PHI(I,2) = R*PHI(I,2) 695 CONTINUE ENDIF GO TO 200 C C------END OF SUBROUTINE DDSTP------------------------------------------ END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) C C***BEGIN PROLOGUE DCNSTR C***DATE WRITTEN 950808 (YYMMDD) C***REVISION DATE 950814 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C This subroutine checks for constraint violations in the proposed C new approximate solution YNEW. C If a constraint violation occurs, then a new step length, TAU, C is calculated, and this value is to be given to the linesearch routine C to calculate a new approximate solution YNEW. C C On entry: C C NEQ -- size of the nonlinear system, and the length of arrays C Y, YNEW and ICNSTR. C C Y -- real array containing the current approximate y. C C YNEW -- real array containing the new approximate y. C C ICNSTR -- INTEGER array of length NEQ containing flags indicating C which entries in YNEW are to be constrained. C if ICNSTR(I) = 2, then YNEW(I) must be .GT. 0, C if ICNSTR(I) = 1, then YNEW(I) must be .GE. 0, C if ICNSTR(I) = -1, then YNEW(I) must be .LE. 0, while C if ICNSTR(I) = -2, then YNEW(I) must be .LT. 0, while C if ICNSTR(I) = 0, then YNEW(I) is not constrained. C C RLX -- real scalar restricting update, if ICNSTR(I) = 2 or -2, C to ABS( (YNEW-Y)/Y ) < FAC2*RLX in component I. C C TAU -- the current size of the step length for the linesearch. C C On return C C TAU -- the adjusted size of the step length if a constraint C violation occurred (otherwise, it is unchanged). it is C the step length to give to the linesearch routine. C C IRET -- output flag. C IRET=0 means that YNEW satisfied all constraints. C IRET=1 means that YNEW failed to satisfy all the C constraints, and a new linesearch step C must be computed. C C IVAR -- index of variable causing constraint to be violated. C C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(NEQ), YNEW(NEQ), ICNSTR(NEQ) SAVE FAC, FAC2, ZERO DATA FAC /0.6D0/, FAC2 /0.9D0/, ZERO/0.0D0/ C----------------------------------------------------------------------- C Check constraints for proposed new step YNEW. If a constraint has C been violated, then calculate a new step length, TAU, to be C used in the linesearch routine. C----------------------------------------------------------------------- IRET = 0 RDYMX = ZERO IVAR = 0 DO 100 I = 1,NEQ C IF (ICNSTR(I) .EQ. 2) THEN RDY = ABS( (YNEW(I)-Y(I))/Y(I) ) IF (RDY .GT. RDYMX) THEN RDYMX = RDY IVAR = I ENDIF IF (YNEW(I) .LE. ZERO) THEN TAU = FAC*TAU IVAR = I IRET = 1 RETURN ENDIF C ELSEIF (ICNSTR(I) .EQ. 1) THEN IF (YNEW(I) .LT. ZERO) THEN TAU = FAC*TAU IVAR = I IRET = 1 RETURN ENDIF C ELSEIF (ICNSTR(I) .EQ. -1) THEN IF (YNEW(I) .GT. ZERO) THEN TAU = FAC*TAU IVAR = I IRET = 1 RETURN ENDIF C ELSEIF (ICNSTR(I) .EQ. -2) THEN RDY = ABS( (YNEW(I)-Y(I))/Y(I) ) IF (RDY .GT. RDYMX) THEN RDYMX = RDY IVAR = I ENDIF IF (YNEW(I) .GE. ZERO) THEN TAU = FAC*TAU IVAR = I IRET = 1 RETURN ENDIF C ENDIF 100 CONTINUE IF(RDYMX .GE. RLX) THEN TAU = FAC2*TAU*RLX/RDYMX IRET = 1 ENDIF C RETURN C----------------------- END OF SUBROUTINE DCNSTR ---------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DCNST0 (NEQ, Y, ICNSTR, IRET) C C***BEGIN PROLOGUE DCNST0 C***DATE WRITTEN 950808 (YYMMDD) C***REVISION DATE 950808 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C This subroutine checks for constraint violations in the initial C approximate solution u. C C On entry C C NEQ -- size of the nonlinear system, and the length of arrays C Y and ICNSTR. C C Y -- real array containing the initial approximate root. C C ICNSTR -- INTEGER array of length NEQ containing flags indicating C which entries in Y are to be constrained. C if ICNSTR(I) = 2, then Y(I) must be .GT. 0, C if ICNSTR(I) = 1, then Y(I) must be .GE. 0, C if ICNSTR(I) = -1, then Y(I) must be .LE. 0, while C if ICNSTR(I) = -2, then Y(I) must be .LT. 0, while C if ICNSTR(I) = 0, then Y(I) is not constrained. C C On return C C IRET -- output flag. C IRET=0 means that u satisfied all constraints. C IRET.NE.0 means that Y(IRET) failed to satisfy its C constraint. C C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(NEQ), ICNSTR(NEQ) SAVE ZERO DATA ZERO/0.D0/ C----------------------------------------------------------------------- C Check constraints for initial Y. If a constraint has been violated, C set IRET = I to signal an error return to calling routine. C----------------------------------------------------------------------- IRET = 0 DO 100 I = 1,NEQ IF (ICNSTR(I) .EQ. 2) THEN IF (Y(I) .LE. ZERO) THEN IRET = I RETURN ENDIF ELSEIF (ICNSTR(I) .EQ. 1) THEN IF (Y(I) .LT. ZERO) THEN IRET = I RETURN ENDIF ELSEIF (ICNSTR(I) .EQ. -1) THEN IF (Y(I) .GT. ZERO) THEN IRET = I RETURN ENDIF ELSEIF (ICNSTR(I) .EQ. -2) THEN IF (Y(I) .GE. ZERO) THEN IRET = I RETURN ENDIF ENDIF 100 CONTINUE RETURN C----------------------- END OF SUBROUTINE DCNST0 ---------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DDAWTS(NEQ,IWT,RTOL,ATOL,Y,WT,RPAR,IPAR) C C***BEGIN PROLOGUE DDAWTS C***REFER TO DDASPK C***ROUTINES CALLED (NONE) C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***END PROLOGUE DDAWTS C----------------------------------------------------------------------- C This subroutine sets the error weight vector, C WT, according to WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I), C I = 1 to NEQ. C RTOL and ATOL are scalars if IWT = 0, C and vectors if IWT = 1. C----------------------------------------------------------------------- C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION RTOL(*),ATOL(*),Y(*),WT(*) DIMENSION RPAR(*),IPAR(*) RTOLI=RTOL(1) ATOLI=ATOL(1) DO 20 I=1,NEQ IF (IWT .EQ.0) GO TO 10 RTOLI=RTOL(I) ATOLI=ATOL(I) 10 WT(I)=RTOLI*ABS(Y(I))+ATOLI 20 CONTINUE RETURN C C------END OF SUBROUTINE DDAWTS----------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DINVWT(NEQ,WT,IER) C C***BEGIN PROLOGUE DINVWT C***REFER TO DDASPK C***ROUTINES CALLED (NONE) C***DATE WRITTEN 950125 (YYMMDD) C***END PROLOGUE DINVWT C----------------------------------------------------------------------- C This subroutine checks the error weight vector WT, of length NEQ, C for components that are .le. 0, and if none are found, it C inverts the WT(I) in place. This replaces division operations C with multiplications in all norm evaluations. C IER is returned as 0 if all WT(I) were found positive, C and the first I with WT(I) .le. 0.0 otherwise. C----------------------------------------------------------------------- C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION WT(*) C DO 10 I = 1,NEQ IF (WT(I) .LE. 0.0D0) GO TO 30 10 CONTINUE DO 20 I = 1,NEQ WT(I) = 1.0D0/WT(I) 20 CONTINUE IER = 0 RETURN C 30 IER = I RETURN C C------END OF SUBROUTINE DINVWT----------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DDATRP(X,XOUT,YOUT,YPOUT,NEQ,KOLD,PHI,PSI) C C***BEGIN PROLOGUE DDATRP C***REFER TO DDASPK C***ROUTINES CALLED (NONE) C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***END PROLOGUE DDATRP C C----------------------------------------------------------------------- C The methods in subroutine DDSTP use polynomials C to approximate the solution. DDATRP approximates the C solution and its derivative at time XOUT by evaluating C one of these polynomials, and its derivative, there. C Information defining this polynomial is passed from C DDSTP, so DDATRP cannot be used alone. C C The parameters are C C X The current time in the integration. C XOUT The time at which the solution is desired. C YOUT The interpolated approximation to Y at XOUT. C (This is output.) C YPOUT The interpolated approximation to YPRIME at XOUT. C (This is output.) C NEQ Number of equations. C KOLD Order used on last successful step. C PHI Array of scaled divided differences of Y. C PSI Array of past stepsize history. C----------------------------------------------------------------------- C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION YOUT(*),YPOUT(*) DIMENSION PHI(NEQ,*),PSI(*) KOLDP1=KOLD+1 TEMP1=XOUT-X DO 10 I=1,NEQ YOUT(I)=PHI(I,1) YPOUT(I)=0.0D0 10 CONTINUE C=1.0D0 D=0.0D0 GAMMA=TEMP1/PSI(1) DO 30 J=2,KOLDP1 D=D*GAMMA+C/PSI(J-1) C=C*GAMMA GAMMA=(TEMP1+PSI(J-1))/PSI(J) DO 20 I=1,NEQ YOUT(I)=YOUT(I)+C*PHI(I,J) YPOUT(I)=YPOUT(I)+D*PHI(I,J) 20 CONTINUE 30 CONTINUE RETURN C C------END OF SUBROUTINE DDATRP----------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C DOUBLE PRECISION FUNCTION DDWNRM(NEQ,V,RWT,RPAR,IPAR) C C***BEGIN PROLOGUE DDWNRM C***ROUTINES CALLED (NONE) C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***END PROLOGUE DDWNRM C----------------------------------------------------------------------- C This function routine computes the weighted C root-mean-square norm of the vector of length C NEQ contained in the array V, with reciprocal weights C contained in the array RWT of length NEQ. C DDWNRM=SQRT((1/NEQ)*SUM(V(I)*RWT(I))**2) C----------------------------------------------------------------------- C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION V(*),RWT(*) DIMENSION RPAR(*),IPAR(*) DDWNRM = 0.0D0 VMAX = 0.0D0 DO 10 I = 1,NEQ IF(ABS(V(I)*RWT(I)) .GT. VMAX) VMAX = ABS(V(I)*RWT(I)) 10 CONTINUE IF(VMAX .LE. 0.0D0) GO TO 30 SUM = 0.0D0 DO 20 I = 1,NEQ SUM = SUM + ((V(I)*RWT(I))/VMAX)**2 20 CONTINUE DDWNRM = VMAX*SQRT(SUM/NEQ) 30 CONTINUE RETURN C C------END OF FUNCTION DDWNRM------------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DDASID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JACD,PDUM,H,WT, * JSDUM,RPAR,IPAR,DUMSVR,DELTA,R,YIC,YPIC,DUMPWK,WM,IWM,CJ,UROUND, * DUME,DUMS,DUMR,EPCON,RATEMX,STPTOL,JFDUM, * ICNFLG,ICNSTR,IERNLS) C C***BEGIN PROLOGUE DDASID C***REFER TO DDASPK C***DATE WRITTEN 940701 (YYMMDD) C***REVISION DATE 950808 (YYMMDD) C***REVISION DATE 951110 Removed unreachable block 390. C C C----------------------------------------------------------------------- C***DESCRIPTION C C C DDASID solves a nonlinear system of algebraic equations of the C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in C the initial conditions. C C The method used is a modified Newton scheme. C C The parameters represent C C X -- Independent variable. C Y -- Solution vector. C YPRIME -- Derivative of solution vector. C NEQ -- Number of unknowns. C ICOPT -- Initial condition option chosen (1 or 2). C ID -- Array of dimension NEQ, which must be initialized C if ICOPT = 1. See DDASIC. C RES -- External user-supplied subroutine to evaluate the C residual. See RES description in DDASPK prologue. C JACD -- External user-supplied routine to evaluate the C Jacobian. See JAC description for the case C INFO(12) = 0 in the DDASPK prologue. C PDUM -- Dummy argument. C H -- Scaling factor for this initial condition calc. C WT -- Vector of weights for error criterion. C JSDUM -- Dummy argument. C RPAR,IPAR -- Real and integer arrays used for communication C between the calling program and external user C routines. They are not altered within DASPK. C DUMSVR -- Dummy argument. C DELTA -- Work vector for NLS of length NEQ. C R -- Work vector for NLS of length NEQ. C YIC,YPIC -- Work vectors for NLS, each of length NEQ. C DUMPWK -- Dummy argument. C WM,IWM -- Real and integer arrays storing matrix information C such as the matrix of partial derivatives, C permutation vector, and various other information. C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). C UROUND -- Unit roundoff. C DUME -- Dummy argument. C DUMS -- Dummy argument. C DUMR -- Dummy argument. C EPCON -- Tolerance to test for convergence of the Newton C iteration. C RATEMX -- Maximum convergence rate for which Newton iteration C is considered converging. C JFDUM -- Dummy argument. C STPTOL -- Tolerance used in calculating the minimum lambda C value allowed. C ICNFLG -- Integer scalar. If nonzero, then constraint C violations in the proposed new approximate solution C will be checked for, and the maximum step length C will be adjusted accordingly. C ICNSTR -- Integer array of length NEQ containing flags for C checking constraints. C IERNLS -- Error flag for nonlinear solver. C 0 ==> nonlinear solver converged. C 1,2 ==> recoverable error inside nonlinear solver. C 1 => retry with current Y, YPRIME C 2 => retry with original Y, YPRIME C -1 ==> unrecoverable error in nonlinear solver. C C All variables with "DUM" in their names are dummy variables C which are not used in this routine. C C----------------------------------------------------------------------- C C***ROUTINES CALLED C RES, DMATD, DNSID C C***END PROLOGUE DDASID C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),ID(*),WT(*),ICNSTR(*) DIMENSION DELTA(*),R(*),YIC(*),YPIC(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) EXTERNAL RES, JACD C PARAMETER (LNRE=12, LNJE=13, LMXNIT=32, LMXNJ=33) C C C Perform initializations. C MXNIT = IWM(LMXNIT) MXNJ = IWM(LMXNJ) IERNLS = 0 NJ = 0 C C Call RES to initialize DELTA. C IRES = 0 IWM(LNRE) = IWM(LNRE) + 1 CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 370 C C Looping point for updating the Jacobian. C 300 CONTINUE C C Initialize all error flags to zero. C IERJ = 0 IRES = 0 IERNEW = 0 C C Reevaluate the iteration matrix, J = dG/dY + CJ*dG/dYPRIME, C where G(X,Y,YPRIME) = 0. C NJ = NJ + 1 IWM(LNJE)=IWM(LNJE)+1 CALL DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IERJ,WT,R, * WM,IWM,RES,IRES,UROUND,JACD,RPAR,IPAR) IF (IRES .LT. 0 .OR. IERJ .NE. 0) GO TO 370 C C Call the nonlinear Newton solver for up to MXNIT iterations. C CALL DNSID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,WT,RPAR,IPAR,DELTA,R, * YIC,YPIC,WM,IWM,CJ,EPCON,RATEMX,MXNIT,STPTOL, * ICNFLG,ICNSTR,IERNEW) C IF (IERNEW .EQ. 1 .AND. NJ .LT. MXNJ) THEN C C MXNIT iterations were done, the convergence rate is < 1, C and the number of Jacobian evaluations is less than MXNJ. C Call RES, reevaluate the Jacobian, and try again. C IWM(LNRE)=IWM(LNRE)+1 CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 370 GO TO 300 ENDIF C IF (IERNEW .NE. 0) GO TO 380 RETURN C C C Unsuccessful exits from nonlinear solver. C Compute IERNLS accordingly. C 370 IERNLS = 2 IF (IRES .LE. -2) IERNLS = -1 RETURN C 380 IERNLS = MIN(IERNEW,2) RETURN C C------END OF SUBROUTINE DDASID----------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DNSID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,WT,RPAR,IPAR, * DELTA,R,YIC,YPIC,WM,IWM,CJ,EPCON,RATEMX,MAXIT,STPTOL, * ICNFLG,ICNSTR,IERNEW) C C***BEGIN PROLOGUE DNSID C***REFER TO DDASPK C***DATE WRITTEN 940701 (YYMMDD) C***REVISION DATE 950713 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DNSID solves a nonlinear system of algebraic equations of the C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME C in the initial conditions. C C The method used is a modified Newton scheme. C C The parameters represent C C X -- Independent variable. C Y -- Solution vector. C YPRIME -- Derivative of solution vector. C NEQ -- Number of unknowns. C ICOPT -- Initial condition option chosen (1 or 2). C ID -- Array of dimension NEQ, which must be initialized C if ICOPT = 1. See DDASIC. C RES -- External user-supplied subroutine to evaluate the C residual. See RES description in DDASPK prologue. C WT -- Vector of weights for error criterion. C RPAR,IPAR -- Real and integer arrays used for communication C between the calling program and external user C routines. They are not altered within DASPK. C DELTA -- Residual vector on entry, and work vector of C length NEQ for DNSID. C WM,IWM -- Real and integer arrays storing matrix information C such as the matrix of partial derivatives, C permutation vector, and various other information. C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). C R -- Array of length NEQ used as workspace by the C linesearch routine DLINSD. C YIC,YPIC -- Work vectors for DLINSD, each of length NEQ. C EPCON -- Tolerance to test for convergence of the Newton C iteration. C RATEMX -- Maximum convergence rate for which Newton iteration C is considered converging. C MAXIT -- Maximum allowed number of Newton iterations. C STPTOL -- Tolerance used in calculating the minimum lambda C value allowed. C ICNFLG -- Integer scalar. If nonzero, then constraint C violations in the proposed new approximate solution C will be checked for, and the maximum step length C will be adjusted accordingly. C ICNSTR -- Integer array of length NEQ containing flags for C checking constraints. C IERNEW -- Error flag for Newton iteration. C 0 ==> Newton iteration converged. C 1 ==> failed to converge, but RATE .le. RATEMX. C 2 ==> failed to converge, RATE .gt. RATEMX. C 3 ==> other recoverable error (IRES = -1, or C linesearch failed). C -1 ==> unrecoverable error (IRES = -2). C C----------------------------------------------------------------------- C C***ROUTINES CALLED C DSLVD, DDWNRM, DLINSD, DCOPY C C***END PROLOGUE DNSID C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),WT(*),R(*) DIMENSION ID(*),DELTA(*), YIC(*), YPIC(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) DIMENSION ICNSTR(*) EXTERNAL RES C PARAMETER (LNNI=19, LLSOFF=35) C C C Initializations. M is the Newton iteration counter. C LSOFF = IWM(LLSOFF) M = 0 RATE = 1.0D0 RLX = 0.4D0 C C Compute a new step vector DELTA by back-substitution. C CALL DSLVD (NEQ, DELTA, WM, IWM) C C Get norm of DELTA. Return now if norm(DELTA) .le. EPCON. C DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) FNRM = DELNRM IF (FNRM .LE. EPCON) RETURN C C Newton iteration loop. C 300 CONTINUE IWM(LNNI) = IWM(LNNI) + 1 C C Call linesearch routine for global strategy and set RATE C OLDFNM = FNRM C CALL DLINSD (NEQ, Y, X, YPRIME, CJ, DELTA, DELNRM, WT, LSOFF, * STPTOL, IRET, RES, IRES, WM, IWM, FNRM, ICOPT, ID, * R, YIC, YPIC, ICNFLG, ICNSTR, RLX, RPAR, IPAR) C RATE = FNRM/OLDFNM C C Check for error condition from linesearch. IF (IRET .NE. 0) GO TO 390 C C Test for convergence of the iteration, and return or loop. C IF (FNRM .LE. EPCON) RETURN C C The iteration has not yet converged. Update M. C Test whether the maximum number of iterations have been tried. C M = M + 1 IF (M .GE. MAXIT) GO TO 380 C C Copy the residual to DELTA and its norm to DELNRM, and loop for C another iteration. C CALL DCOPY (NEQ, R, 1, DELTA, 1) DELNRM = FNRM GO TO 300 C C The maximum number of iterations was done. Set IERNEW and return. C 380 IF (RATE .LE. RATEMX) THEN IERNEW = 1 ELSE IERNEW = 2 ENDIF RETURN C 390 IF (IRES .LE. -2) THEN IERNEW = -1 ELSE IERNEW = 3 ENDIF RETURN C C C------END OF SUBROUTINE DNSID------------------------------------------ END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DLINSD (NEQ, Y, T, YPRIME, CJ, P, PNRM, WT, LSOFF, * STPTOL, IRET, RES, IRES, WM, IWM, * FNRM, ICOPT, ID, R, YNEW, YPNEW, ICNFLG, * ICNSTR, RLX, RPAR, IPAR) C C***BEGIN PROLOGUE DLINSD C***REFER TO DNSID C***DATE WRITTEN 941025 (YYMMDD) C***REVISION DATE 941215 (YYMMDD) C***REVISION DATE 960129 Moved line RL = ONE to top block. C C C----------------------------------------------------------------------- C***DESCRIPTION C C DLINSD uses a linesearch algorithm to calculate a new (Y,YPRIME) C pair (YNEW,YPNEW) such that C C f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) , C C where 0 < RL <= 1. Here, f(y,y') is defined as C C f(y,y') = (1/2)*norm( (J-inverse)*G(t,y,y') )**2 , C C where norm() is the weighted RMS vector norm, G is the DAE C system residual function, and J is the system iteration matrix C (Jacobian). C C In addition to the parameters defined elsewhere, we have C C P -- Approximate Newton step used in backtracking. C PNRM -- Weighted RMS norm of P. C LSOFF -- Flag showing whether the linesearch algorithm is C to be invoked. 0 means do the linesearch, and C 1 means turn off linesearch. C STPTOL -- Tolerance used in calculating the minimum lambda C value allowed. C ICNFLG -- Integer scalar. If nonzero, then constraint violations C in the proposed new approximate solution will be C checked for, and the maximum step length will be C adjusted accordingly. C ICNSTR -- Integer array of length NEQ containing flags for C checking constraints. C RLX -- Real scalar restricting update size in DCNSTR. C YNEW -- Array of length NEQ used to hold the new Y in C performing the linesearch. C YPNEW -- Array of length NEQ used to hold the new YPRIME in C performing the linesearch. C Y -- Array of length NEQ containing the new Y (i.e.,=YNEW). C YPRIME -- Array of length NEQ containing the new YPRIME C (i.e.,=YPNEW). C FNRM -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the C current (Y,YPRIME) on input and output. C R -- Work array of length NEQ, containing the scaled C residual (J-inverse)*G(t,y,y') on return. C IRET -- Return flag. C IRET=0 means that a satisfactory (Y,YPRIME) was found. C IRET=1 means that the routine failed to find a new C (Y,YPRIME) that was sufficiently distinct from C the current (Y,YPRIME) pair. C IRET=2 means IRES .ne. 0 from RES. C----------------------------------------------------------------------- C C***ROUTINES CALLED C DFNRMD, DYYPNW, DCOPY C C***END PROLOGUE DLINSD C IMPLICIT DOUBLE PRECISION(A-H,O-Z) EXTERNAL RES DIMENSION Y(*), YPRIME(*), WT(*), R(*), ID(*) DIMENSION WM(*), IWM(*) DIMENSION YNEW(*), YPNEW(*), P(*), ICNSTR(*) DIMENSION RPAR(*), IPAR(*) C PARAMETER (LNRE=12, LKPRIN=31) C SAVE ALPHA, ONE, TWO DATA ALPHA/1.0D-4/, ONE/1.0D0/, TWO/2.0D0/ C KPRIN=IWM(LKPRIN) C F1NRM = (FNRM*FNRM)/TWO RATIO = ONE IF (KPRIN .GE. 2) THEN call rprintfd1( 1 'daspk-- in routine dlinsd--PNRM (= %g)' // char(0), PNRM) ENDIF TAU = PNRM IVIO = 0 RL = ONE C----------------------------------------------------------------------- C Check for violations of the constraints, if any are imposed. C If any violations are found, the step vector P is rescaled, and the C constraint check is repeated, until no violations are found. C----------------------------------------------------------------------- IF (ICNFLG .NE. 0) THEN 10 CONTINUE CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) CALL DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) IF (IRET .EQ. 1) THEN IVIO = 1 RATIO1 = TAU/PNRM RATIO = RATIO*RATIO1 DO 20 I = 1,NEQ P(I) = P(I)*RATIO1 20 CONTINUE PNRM = TAU IF (KPRIN .GE. 2) THEN call rprintfid( 1 'daspk-- constraint violation-PNRM (= %g), index =( %i)' & // char(0), 2 IVAR,PNRM) ENDIF IF (PNRM .LE. STPTOL) THEN IRET = 1 RETURN ENDIF GO TO 10 ENDIF ENDIF C SLPI = (-TWO*F1NRM)*RATIO RLMIN = STPTOL/PNRM IF (LSOFF .EQ. 0 .AND. KPRIN .GE. 2) THEN call rprintfd1( 1 'daspk-- min lambda (= %g)' // char(0), RLMIN) ENDIF C----------------------------------------------------------------------- C Begin iteration to find RL value satisfying alpha-condition. C If RL becomes less than RLMIN, then terminate with IRET = 1. C----------------------------------------------------------------------- 100 CONTINUE CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) CALL DFNRMD (NEQ, YNEW, T, YPNEW, R, CJ, WT, RES, IRES, * FNRMP, WM, IWM, RPAR, IPAR) IWM(LNRE) = IWM(LNRE) + 1 IF (IRES .NE. 0) THEN IRET = 2 RETURN ENDIF IF (LSOFF .EQ. 1) GO TO 150 C F1NRMP = FNRMP*FNRMP/TWO IF (KPRIN .GE. 2) THEN call rprintfd1( 1 'daspk-- LAMBDA (= %g)' // char(0), RL) call rprintfd2( 1 'daspk-- NORM(F1) = %g, NORM(F1NEW) = %g' & // char(0), F1NRM, F1NRMP) ENDIF IF (F1NRMP .GT. F1NRM + ALPHA*SLPI*RL) GO TO 200 C----------------------------------------------------------------------- C Alpha-condition is satisfied, or linesearch is turned off. C Copy YNEW,YPNEW to Y,YPRIME and return. C----------------------------------------------------------------------- 150 IRET = 0 CALL DCOPY (NEQ, YNEW, 1, Y, 1) CALL DCOPY (NEQ, YPNEW, 1, YPRIME, 1) FNRM = FNRMP IF (KPRIN .GE. 1) THEN call rprintfd1( 1 'daspk-- leaving routine dlinsd--FNRM (= %g)' & // char(0),FNRM) ENDIF RETURN C----------------------------------------------------------------------- C Alpha-condition not satisfied. Perform backtrack to compute new RL C value. If no satisfactory YNEW,YPNEW can be found sufficiently C distinct from Y,YPRIME, then return IRET = 1. C----------------------------------------------------------------------- 200 CONTINUE IF (RL .LT. RLMIN) THEN IRET = 1 RETURN ENDIF C RL = RL/TWO GO TO 100 C C----------------------- END OF SUBROUTINE DLINSD ---------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DFNRMD (NEQ, Y, T, YPRIME, R, CJ, WT, RES, IRES, * FNORM, WM, IWM, RPAR, IPAR) C C***BEGIN PROLOGUE DFNRMD C***REFER TO DLINSD C***DATE WRITTEN 941025 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DFNRMD calculates the scaled preconditioned norm of the nonlinear C function used in the nonlinear iteration for obtaining consistent C initial conditions. Specifically, DFNRMD calculates the weighted C root-mean-square norm of the vector (J-inverse)*G(T,Y,YPRIME), C where J is the Jacobian matrix. C C In addition to the parameters described in the calling program C DLINSD, the parameters represent C C R -- Array of length NEQ that contains C (J-inverse)*G(T,Y,YPRIME) on return. C FNORM -- Scalar containing the weighted norm of R on return. C----------------------------------------------------------------------- C C***ROUTINES CALLED C RES, DSLVD, DDWNRM C C***END PROLOGUE DFNRMD C C IMPLICIT DOUBLE PRECISION (A-H,O-Z) EXTERNAL RES DIMENSION Y(*), YPRIME(*), WT(*), R(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) C----------------------------------------------------------------------- C Call RES routine. C----------------------------------------------------------------------- IRES = 0 CALL RES(T,Y,YPRIME,CJ,R,IRES,RPAR,IPAR) IF (IRES .LT. 0) RETURN C----------------------------------------------------------------------- C Apply inverse of Jacobian to vector R. C----------------------------------------------------------------------- CALL DSLVD(NEQ,R,WM,IWM) C----------------------------------------------------------------------- C Calculate norm of R. C----------------------------------------------------------------------- FNORM = DDWNRM(NEQ,R,WT,RPAR,IPAR) C RETURN C----------------------- END OF SUBROUTINE DFNRMD ---------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DNEDD(X,Y,YPRIME,NEQ,RES,JACD,PDUM,H,WT, * JSTART,IDID,RPAR,IPAR,PHI,GAMMA,DUMSVR,DELTA,E, * WM,IWM,CJ,CJOLD,CJLAST,S,UROUND,DUME,DUMS,DUMR, * EPCON,JCALC,JFDUM,KP1,NONNEG,NTYPE,IERNLS) C C***BEGIN PROLOGUE DNEDD C***REFER TO DDASPK C***DATE WRITTEN 891219 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DNEDD solves a nonlinear system of C algebraic equations of the form C G(X,Y,YPRIME) = 0 for the unknown Y. C C The method used is a modified Newton scheme. C C The parameters represent C C X -- Independent variable. C Y -- Solution vector. C YPRIME -- Derivative of solution vector. C NEQ -- Number of unknowns. C RES -- External user-supplied subroutine C to evaluate the residual. See RES description C in DDASPK prologue. C JACD -- External user-supplied routine to evaluate the C Jacobian. See JAC description for the case C INFO(12) = 0 in the DDASPK prologue. C PDUM -- Dummy argument. C H -- Appropriate step size for next step. C WT -- Vector of weights for error criterion. C JSTART -- Indicates first call to this routine. C If JSTART = 0, then this is the first call, C otherwise it is not. C IDID -- Completion flag, output by DNEDD. C See IDID description in DDASPK prologue. C RPAR,IPAR -- Real and integer arrays used for communication C between the calling program and external user C routines. They are not altered within DASPK. C PHI -- Array of divided differences used by C DNEDD. The length is NEQ*(K+1),where C K is the maximum order. C GAMMA -- Array used to predict Y and YPRIME. The length C is MAXORD+1 where MAXORD is the maximum order. C DUMSVR -- Dummy argument. C DELTA -- Work vector for NLS of length NEQ. C E -- Error accumulation vector for NLS of length NEQ. C WM,IWM -- Real and integer arrays storing C matrix information such as the matrix C of partial derivatives, permutation C vector, and various other information. C CJ -- Parameter always proportional to 1/H. C CJOLD -- Saves the value of CJ as of the last call to DMATD. C Accounts for changes in CJ needed to C decide whether to call DMATD. C CJLAST -- Previous value of CJ. C S -- A scalar determined by the approximate rate C of convergence of the Newton iteration and used C in the convergence test for the Newton iteration. C C If RATE is defined to be an estimate of the C rate of convergence of the Newton iteration, C then S = RATE/(1.D0-RATE). C C The closer RATE is to 0., the faster the Newton C iteration is converging; the closer RATE is to 1., C the slower the Newton iteration is converging. C C On the first Newton iteration with an up-dated C preconditioner S = 100.D0, Thus the initial C RATE of convergence is approximately 1. C C S is preserved from call to call so that the rate C estimate from a previous step can be applied to C the current step. C UROUND -- Unit roundoff. C DUME -- Dummy argument. C DUMS -- Dummy argument. C DUMR -- Dummy argument. C EPCON -- Tolerance to test for convergence of the Newton C iteration. C JCALC -- Flag used to determine when to update C the Jacobian matrix. In general: C C JCALC = -1 ==> Call the DMATD routine to update C the Jacobian matrix. C JCALC = 0 ==> Jacobian matrix is up-to-date. C JCALC = 1 ==> Jacobian matrix is out-dated, C but DMATD will not be called unless C JCALC is set to -1. C JFDUM -- Dummy argument. C KP1 -- The current order(K) + 1; updated across calls. C NONNEG -- Flag to determine nonnegativity constraints. C NTYPE -- Identification code for the NLS routine. C 0 ==> modified Newton; direct solver. C IERNLS -- Error flag for nonlinear solver. C 0 ==> nonlinear solver converged. C 1 ==> recoverable error inside nonlinear solver. C -1 ==> unrecoverable error inside nonlinear solver. C C All variables with "DUM" in their names are dummy variables C which are not used in this routine. C C Following is a list and description of local variables which C may not have an obvious usage. They are listed in roughly the C order they occur in this subroutine. C C The following group of variables are passed as arguments to C the Newton iteration solver. They are explained in greater detail C in DNSD: C TOLNEW, MULDEL, MAXIT, IERNEW C C IERTYP -- Flag which tells whether this subroutine is correct. C 0 ==> correct subroutine. C 1 ==> incorrect subroutine. C C----------------------------------------------------------------------- C***ROUTINES CALLED C DDWNRM, RES, DMATD, DNSD C C***END PROLOGUE DNEDD C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),WT(*) DIMENSION DELTA(*),E(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) DIMENSION PHI(NEQ,*),GAMMA(*) EXTERNAL RES, JACD C PARAMETER (LNRE=12, LNJE=13) C SAVE MULDEL, MAXIT, XRATE DATA MULDEL/1/, MAXIT/4/, XRATE/0.25D0/ C C Verify that this is the correct subroutine. C IERTYP = 0 IF (NTYPE .NE. 0) THEN IERTYP = 1 GO TO 380 ENDIF C C If this is the first step, perform initializations. C IF (JSTART .EQ. 0) THEN CJOLD = CJ JCALC = -1 ENDIF C C Perform all other initializations. C IERNLS = 0 C C Decide whether new Jacobian is needed. C TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) TEMP2 = 1.0D0/TEMP1 IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 IF (CJ .NE. CJLAST) S = 100.D0 C C----------------------------------------------------------------------- C Entry point for updating the Jacobian with current C stepsize. C----------------------------------------------------------------------- 300 CONTINUE C C Initialize all error flags to zero. C IERJ = 0 IRES = 0 IERNEW = 0 C C Predict the solution and derivative and compute the tolerance C for the Newton iteration. C DO 310 I=1,NEQ Y(I)=PHI(I,1) YPRIME(I)=0.0D0 310 CONTINUE DO 330 J=2,KP1 DO 320 I=1,NEQ Y(I)=Y(I)+PHI(I,J) YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) 320 CONTINUE 330 CONTINUE PNORM = DDWNRM (NEQ,Y,WT,RPAR,IPAR) TOLNEW = 100.D0*UROUND*PNORM C C Call RES to initialize DELTA. C IWM(LNRE)=IWM(LNRE)+1 CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 380 C C If indicated, reevaluate the iteration matrix C J = dG/dY + CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). C Set JCALC to 0 as an indicator that this has been done. C IF(JCALC .EQ. -1) THEN IWM(LNJE)=IWM(LNJE)+1 JCALC=0 CALL DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IERJ,WT,E,WM,IWM, * RES,IRES,UROUND,JACD,RPAR,IPAR) CJOLD=CJ S = 100.D0 IF (IRES .LT. 0) GO TO 380 IF(IERJ .NE. 0)GO TO 380 ENDIF C C Call the nonlinear Newton solver. C TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD) CALL DNSD(X,Y,YPRIME,NEQ,RES,PDUM,WT,RPAR,IPAR,DUMSVR, * DELTA,E,WM,IWM,CJ,DUMS,DUMR,DUME,EPCON,S,TEMP1, * TOLNEW,MULDEL,MAXIT,IRES,IDUM,IERNEW) C IF (IERNEW .GT. 0 .AND. JCALC .NE. 0) THEN C C The Newton iteration had a recoverable failure with an old C iteration matrix. Retry the step with a new iteration matrix. C JCALC = -1 GO TO 300 ENDIF C IF (IERNEW .NE. 0) GO TO 380 C C The Newton iteration has converged. If nonnegativity of C solution is required, set the solution nonnegative, if the C perturbation to do it is small enough. If the change is too C large, then consider the corrector iteration to have failed. C IF(NONNEG .EQ. 0) GO TO 390 DO 377 I = 1,NEQ DELTA(I) = MIN(Y(I),0.0D0) 377 CONTINUE DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) IF(DELNRM .GT. EPCON) GO TO 380 DO 378 I = 1,NEQ E(I) = E(I) - DELTA(I) 378 CONTINUE GO TO 390 C C C Exits from nonlinear solver. C No convergence with current iteration C matrix, or singular iteration matrix. C Compute IERNLS and IDID accordingly. C 380 CONTINUE IF (IRES .LE. -2 .OR. IERTYP .NE. 0) THEN IERNLS = -1 IF (IRES .LE. -2) IDID = -11 IF (IERTYP .NE. 0) IDID = -15 ELSE IERNLS = 1 IF (IRES .LT. 0) IDID = -10 IF (IERJ .NE. 0) IDID = -8 ENDIF C 390 JCALC = 1 RETURN C C------END OF SUBROUTINE DNEDD------------------------------------------ END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DNSD(X,Y,YPRIME,NEQ,RES,PDUM,WT,RPAR,IPAR, * DUMSVR,DELTA,E,WM,IWM,CJ,DUMS,DUMR,DUME,EPCON, * S,CONFAC,TOLNEW,MULDEL,MAXIT,IRES,IDUM,IERNEW) C C***BEGIN PROLOGUE DNSD C***REFER TO DDASPK C***DATE WRITTEN 891219 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***REVISION DATE 950126 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DNSD solves a nonlinear system of C algebraic equations of the form C G(X,Y,YPRIME) = 0 for the unknown Y. C C The method used is a modified Newton scheme. C C The parameters represent C C X -- Independent variable. C Y -- Solution vector. C YPRIME -- Derivative of solution vector. C NEQ -- Number of unknowns. C RES -- External user-supplied subroutine C to evaluate the residual. See RES description C in DDASPK prologue. C PDUM -- Dummy argument. C WT -- Vector of weights for error criterion. C RPAR,IPAR -- Real and integer arrays used for communication C between the calling program and external user C routines. They are not altered within DASPK. C DUMSVR -- Dummy argument. C DELTA -- Work vector for DNSD of length NEQ. C E -- Error accumulation vector for DNSD of length NEQ. C WM,IWM -- Real and integer arrays storing C matrix information such as the matrix C of partial derivatives, permutation C vector, and various other information. C CJ -- Parameter always proportional to 1/H (step size). C DUMS -- Dummy argument. C DUMR -- Dummy argument. C DUME -- Dummy argument. C EPCON -- Tolerance to test for convergence of the Newton C iteration. C S -- Used for error convergence tests. C In the Newton iteration: S = RATE/(1 - RATE), C where RATE is the estimated rate of convergence C of the Newton iteration. C The calling routine passes the initial value C of S to the Newton iteration. C CONFAC -- A residual scale factor to improve convergence. C TOLNEW -- Tolerance on the norm of Newton correction in C alternative Newton convergence test. C MULDEL -- A flag indicating whether or not to multiply C DELTA by CONFAC. C 0 ==> do not scale DELTA by CONFAC. C 1 ==> scale DELTA by CONFAC. C MAXIT -- Maximum allowed number of Newton iterations. C IRES -- Error flag returned from RES. See RES description C in DDASPK prologue. If IRES = -1, then IERNEW C will be set to 1. C If IRES < -1, then IERNEW will be set to -1. C IDUM -- Dummy argument. C IERNEW -- Error flag for Newton iteration. C 0 ==> Newton iteration converged. C 1 ==> recoverable error inside Newton iteration. C -1 ==> unrecoverable error inside Newton iteration. C C All arguments with "DUM" in their names are dummy arguments C which are not used in this routine. C----------------------------------------------------------------------- C C***ROUTINES CALLED C DSLVD, DDWNRM, RES C C***END PROLOGUE DNSD C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),WT(*),DELTA(*),E(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) EXTERNAL RES C PARAMETER (LNRE=12, LNNI=19) C C Initialize Newton counter M and accumulation vector E. C M = 0 DO 100 I=1,NEQ E(I)=0.0D0 100 CONTINUE C C Corrector loop. C 300 CONTINUE IWM(LNNI) = IWM(LNNI) + 1 C C If necessary, multiply residual by convergence factor. C IF (MULDEL .EQ. 1) THEN DO 320 I = 1,NEQ DELTA(I) = DELTA(I) * CONFAC 320 CONTINUE ENDIF C C Compute a new iterate (back-substitution). C Store the correction in DELTA. C CALL DSLVD(NEQ,DELTA,WM,IWM) C C Update Y, E, and YPRIME. C DO 340 I=1,NEQ Y(I)=Y(I)-DELTA(I) E(I)=E(I)-DELTA(I) YPRIME(I)=YPRIME(I)-CJ*DELTA(I) 340 CONTINUE C C Test for convergence of the iteration. C DELNRM=DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) IF (DELNRM .LE. TOLNEW) GO TO 370 IF (M .EQ. 0) THEN OLDNRM = DELNRM ELSE RATE = (DELNRM/OLDNRM)**(1.0D0/M) IF (RATE .GT. 0.9D0) GO TO 380 S = RATE/(1.0D0 - RATE) ENDIF IF (S*DELNRM .LE. EPCON) GO TO 370 C C The corrector has not yet converged. C Update M and test whether the C maximum number of iterations have C been tried. C M=M+1 IF(M.GE.MAXIT) GO TO 380 C C Evaluate the residual, C and go back to do another iteration. C IWM(LNRE)=IWM(LNRE)+1 CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 380 GO TO 300 C C The iteration has converged. C 370 RETURN C C The iteration has not converged. Set IERNEW appropriately. C 380 CONTINUE IF (IRES .LE. -2 ) THEN IERNEW = -1 ELSE IERNEW = 1 ENDIF RETURN C C C------END OF SUBROUTINE DNSD------------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IER,EWT,E, * WM,IWM,RES,IRES,UROUND,JACD,RPAR,IPAR) C C***BEGIN PROLOGUE DMATD C***REFER TO DDASPK C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***REVISION DATE 940701 (YYMMDD) (new LIPVT) C C----------------------------------------------------------------------- C***DESCRIPTION C C This routine computes the iteration matrix C J = dG/dY+CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). C Here J is computed by: C the user-supplied routine JACD if IWM(MTYPE) is 1 or 4, or C by numerical difference quotients if IWM(MTYPE) is 2 or 5. C C The parameters have the following meanings. C X = Independent variable. C Y = Array containing predicted values. C YPRIME = Array containing predicted derivatives. C DELTA = Residual evaluated at (X,Y,YPRIME). C (Used only if IWM(MTYPE)=2 or 5). C CJ = Scalar parameter defining iteration matrix. C H = Current stepsize in integration. C IER = Variable which is .NE. 0 if iteration matrix C is singular, and 0 otherwise. C EWT = Vector of error weights for computing norms. C E = Work space (temporary) of length NEQ. C WM = Real work space for matrices. On output C it contains the LU decomposition C of the iteration matrix. C IWM = Integer work space containing C matrix information. C RES = External user-supplied subroutine C to evaluate the residual. See RES description C in DDASPK prologue. C IRES = Flag which is equal to zero if no illegal values C in RES, and less than zero otherwise. (If IRES C is less than zero, the matrix was not completed). C In this case (if IRES .LT. 0), then IER = 0. C UROUND = The unit roundoff error of the machine being used. C JACD = Name of the external user-supplied routine C to evaluate the iteration matrix. (This routine C is only used if IWM(MTYPE) is 1 or 4) C See JAC description for the case INFO(12) = 0 C in DDASPK prologue. C RPAR,IPAR= Real and integer parameter arrays that C are used for communication between the C calling program and external user routines. C They are not altered by DMATD. C----------------------------------------------------------------------- C***ROUTINES CALLED C JACD, RES, DGEFA, DGBFA C C***END PROLOGUE DMATD C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),DELTA(*),EWT(*),E(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) EXTERNAL RES, JACD C PARAMETER (LML=1, LMU=2, LMTYPE=4, LNRE=12, LNPD=22, LLCIWP=30) C LIPVT = IWM(LLCIWP) IER = 0 MTYPE=IWM(LMTYPE) IF (MTYPE .EQ. 1) THEN GOTO 100 ELSE IF (MTYPE .EQ. 2) THEN GOTO 200 ELSE IF (MTYPE .EQ. 3) THEN GOTO 300 ELSE IF (MTYPE .EQ. 4) THEN GOTO 400 ELSE IF (MTYPE .EQ. 5) THEN GOTO 500 ENDIF C GO TO (100,200,300,400,500),MTYPE C C C Dense user-supplied matrix. C 100 LENPD=IWM(LNPD) DO 110 I=1,LENPD WM(I)=0.0D0 110 CONTINUE CALL JACD(X,Y,YPRIME,WM,CJ,RPAR,IPAR) GO TO 230 C C C Dense finite-difference-generated matrix. C 200 IRES=0 NROW=0 SQUR = SQRT(UROUND) DO 210 I=1,NEQ DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)), * ABS(1.D0/EWT(I))) DEL=SIGN(DEL,H*YPRIME(I)) DEL=(Y(I)+DEL)-Y(I) YSAVE=Y(I) YPSAVE=YPRIME(I) Y(I)=Y(I)+DEL YPRIME(I)=YPRIME(I)+CJ*DEL IWM(LNRE)=IWM(LNRE)+1 CALL RES(X,Y,YPRIME,CJ,E,IRES,RPAR,IPAR) IF (IRES .LT. 0) RETURN DELINV=1.0D0/DEL DO 220 L=1,NEQ WM(NROW+L)=(E(L)-DELTA(L))*DELINV 220 CONTINUE NROW=NROW+NEQ Y(I)=YSAVE YPRIME(I)=YPSAVE 210 CONTINUE C C C Do dense-matrix LU decomposition on J. C 230 CALL DGEFA(WM,NEQ,NEQ,IWM(LIPVT),IER) RETURN C C C Dummy section for IWM(MTYPE)=3. C 300 RETURN C C C Banded user-supplied matrix. C 400 LENPD=IWM(LNPD) DO 410 I=1,LENPD WM(I)=0.0D0 410 CONTINUE CALL JACD(X,Y,YPRIME,WM,CJ,RPAR,IPAR) MEBAND=2*IWM(LML)+IWM(LMU)+1 GO TO 550 C C C Banded finite-difference-generated matrix. C 500 MBAND=IWM(LML)+IWM(LMU)+1 MBA=MIN0(MBAND,NEQ) MEBAND=MBAND+IWM(LML) MEB1=MEBAND-1 MSAVE=(NEQ/MBAND)+1 ISAVE=IWM(LNPD) IPSAVE=ISAVE+MSAVE IRES=0 SQUR=SQRT(UROUND) DO 540 J=1,MBA DO 510 N=J,NEQ,MBAND K= (N-J)/MBAND + 1 WM(ISAVE+K)=Y(N) WM(IPSAVE+K)=YPRIME(N) DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)), * ABS(1.D0/EWT(N))) DEL=SIGN(DEL,H*YPRIME(N)) DEL=(Y(N)+DEL)-Y(N) Y(N)=Y(N)+DEL YPRIME(N)=YPRIME(N)+CJ*DEL 510 CONTINUE IWM(LNRE)=IWM(LNRE)+1 CALL RES(X,Y,YPRIME,CJ,E,IRES,RPAR,IPAR) IF (IRES .LT. 0) RETURN DO 530 N=J,NEQ,MBAND K= (N-J)/MBAND + 1 Y(N)=WM(ISAVE+K) YPRIME(N)=WM(IPSAVE+K) DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)), * ABS(1.D0/EWT(N))) DEL=SIGN(DEL,H*YPRIME(N)) DEL=(Y(N)+DEL)-Y(N) DELINV=1.0D0/DEL I1=MAX0(1,(N-IWM(LMU))) I2=MIN0(NEQ,(N+IWM(LML))) II=N*MEB1-IWM(LML) DO 520 I=I1,I2 WM(II+I)=(E(I)-DELTA(I))*DELINV 520 CONTINUE 530 CONTINUE 540 CONTINUE C C C Do LU decomposition of banded J. C 550 CALL DGBFA (WM,MEBAND,NEQ,IWM(LML),IWM(LMU),IWM(LIPVT),IER) RETURN C C------END OF SUBROUTINE DMATD------------------------------------------ END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DSLVD(NEQ,DELTA,WM,IWM) C C***BEGIN PROLOGUE DSLVD C***REFER TO DDASPK C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***REVISION DATE 940701 (YYMMDD) (new LIPVT) C C----------------------------------------------------------------------- C***DESCRIPTION C C This routine manages the solution of the linear C system arising in the Newton iteration. C Real matrix information and real temporary storage C is stored in the array WM. C Integer matrix information is stored in the array IWM. C For a dense matrix, the LINPACK routine DGESL is called. C For a banded matrix, the LINPACK routine DGBSL is called. C----------------------------------------------------------------------- C***ROUTINES CALLED C DGESL, DGBSL C C***END PROLOGUE DSLVD C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION DELTA(*),WM(*),IWM(*) C PARAMETER (LML=1, LMU=2, LMTYPE=4, LLCIWP=30) C LIPVT = IWM(LLCIWP) MTYPE=IWM(LMTYPE) IF (MTYPE .EQ. 1 . OR. MTYPE .EQ. 2) THEN GOTO 100 ELSE IF (MTYPE .EQ. 3) THEN GOTO 300 ELSE IF (MTYPE .EQ. 4 .OR. MTYPE .EQ. 5) THEN GOTO 400 ENDIF C GO TO(100,100,300,400,400),MTYPE C C Dense matrix. C 100 CALL DGESL(WM,NEQ,NEQ,IWM(LIPVT),DELTA,0) RETURN C C Dummy section for MTYPE=3. C 300 CONTINUE RETURN C C Banded matrix. C 400 MEBAND=2*IWM(LML)+IWM(LMU)+1 CALL DGBSL(WM,MEBAND,NEQ,IWM(LML), * IWM(LMU),IWM(LIPVT),DELTA,0) RETURN C C------END OF SUBROUTINE DSLVD------------------------------------------ END C Work perfored under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DDASIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JACK,PSOL,H,WT, * JSKIP,RPAR,IPAR,SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,UROUND, * EPLI,SQRTN,RSQRTN,EPCON,RATEMX,STPTOL,JFLG, * ICNFLG,ICNSTR,IERNLS) C C***BEGIN PROLOGUE DDASIK C***REFER TO DDASPK C***DATE WRITTEN 941026 (YYMMDD) C***REVISION DATE 950808 (YYMMDD) C***REVISION DATE 951110 Removed unreachable block 390. C C C----------------------------------------------------------------------- C***DESCRIPTION C C C DDASIK solves a nonlinear system of algebraic equations of the C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in C the initial conditions. C C An initial value for Y and initial guess for YPRIME are input. C C The method used is a Newton scheme with Krylov iteration and a C linesearch algorithm. C C The parameters represent C C X -- Independent variable. C Y -- Solution vector at x. C YPRIME -- Derivative of solution vector. C NEQ -- Number of equations to be integrated. C ICOPT -- Initial condition option chosen (1 or 2). C ID -- Array of dimension NEQ, which must be initialized C if ICOPT = 1. See DDASIC. C RES -- External user-supplied subroutine C to evaluate the residual. See RES description C in DDASPK prologue. C JACK -- External user-supplied routine to update C the preconditioner. (This is optional). C See JAC description for the case C INFO(12) = 1 in the DDASPK prologue. C PSOL -- External user-supplied routine to solve C a linear system using preconditioning. C (This is optional). See explanation inside DDASPK. C H -- Scaling factor for this initial condition calc. C WT -- Vector of weights for error criterion. C JSKIP -- input flag to signal if initial JAC call is to be C skipped. 1 => skip the call, 0 => do not skip call. C RPAR,IPAR -- Real and integer arrays used for communication C between the calling program and external user C routines. They are not altered within DASPK. C SAVR -- Work vector for DDASIK of length NEQ. C DELTA -- Work vector for DDASIK of length NEQ. C R -- Work vector for DDASIK of length NEQ. C YIC,YPIC -- Work vectors for DDASIK, each of length NEQ. C PWK -- Work vector for DDASIK of length NEQ. C WM,IWM -- Real and integer arrays storing C matrix information for linear system C solvers, and various other information. C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). C UROUND -- Unit roundoff. C EPLI -- convergence test constant. C See DDASPK prologue for more details. C SQRTN -- Square root of NEQ. C RSQRTN -- reciprical of square root of NEQ. C EPCON -- Tolerance to test for convergence of the Newton C iteration. C RATEMX -- Maximum convergence rate for which Newton iteration C is considered converging. C JFLG -- Flag showing whether a Jacobian routine is supplied. C ICNFLG -- Integer scalar. If nonzero, then constraint C violations in the proposed new approximate solution C will be checked for, and the maximum step length C will be adjusted accordingly. C ICNSTR -- Integer array of length NEQ containing flags for C checking constraints. C IERNLS -- Error flag for nonlinear solver. C 0 ==> nonlinear solver converged. C 1,2 ==> recoverable error inside nonlinear solver. C 1 => retry with current Y, YPRIME C 2 => retry with original Y, YPRIME C -1 ==> unrecoverable error in nonlinear solver. C C----------------------------------------------------------------------- C C***ROUTINES CALLED C RES, JACK, DNSIK, DCOPY C C***END PROLOGUE DDASIK C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),ID(*),WT(*),ICNSTR(*) DIMENSION SAVR(*),DELTA(*),R(*),YIC(*),YPIC(*),PWK(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) EXTERNAL RES, JACK, PSOL C PARAMETER (LNRE=12, LNJE=13, LLOCWP=29, LLCIWP=30) PARAMETER (LMXNIT=32, LMXNJ=33) C C C Perform initializations. C LWP = IWM(LLOCWP) LIWP = IWM(LLCIWP) MXNIT = IWM(LMXNIT) MXNJ = IWM(LMXNJ) IERNLS = 0 NJ = 0 EPLIN = EPLI*EPCON C C Call RES to initialize DELTA. C IRES = 0 IWM(LNRE) = IWM(LNRE) + 1 CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 370 C C Looping point for updating the preconditioner. C 300 CONTINUE C C Initialize all error flags to zero. C IERPJ = 0 IRES = 0 IERNEW = 0 C C If a Jacobian routine was supplied, call it. C IF (JFLG .EQ. 1 .AND. JSKIP .EQ. 0) THEN NJ = NJ + 1 IWM(LNJE)=IWM(LNJE)+1 CALL JACK (RES, IRES, NEQ, X, Y, YPRIME, WT, DELTA, R, H, CJ, * WM(LWP), IWM(LIWP), IERPJ, RPAR, IPAR) IF (IRES .LT. 0 .OR. IERPJ .NE. 0) GO TO 370 ENDIF JSKIP = 0 C C Call the nonlinear Newton solver for up to MXNIT iterations. C CALL DNSIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,PSOL,WT,RPAR,IPAR, * SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,SQRTN,RSQRTN, * EPLIN,EPCON,RATEMX,MXNIT,STPTOL,ICNFLG,ICNSTR,IERNEW) C IF (IERNEW .EQ. 1 .AND. NJ .LT. MXNJ .AND. JFLG .EQ. 1) THEN C C Up to MXNIT iterations were done, the convergence rate is < 1, C a Jacobian routine is supplied, and the number of JACK calls C is less than MXNJ. C Copy the residual SAVR to DELTA, call JACK, and try again. C CALL DCOPY (NEQ, SAVR, 1, DELTA, 1) GO TO 300 ENDIF C IF (IERNEW .NE. 0) GO TO 380 RETURN C C C Unsuccessful exits from nonlinear solver. C Set IERNLS accordingly. C 370 IERNLS = 2 IF (IRES .LE. -2) IERNLS = -1 RETURN C 380 IERNLS = MIN(IERNEW,2) RETURN C C----------------------- END OF SUBROUTINE DDASIK----------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DNSIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,PSOL,WT,RPAR,IPAR, * SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON, * RATEMX,MAXIT,STPTOL,ICNFLG,ICNSTR,IERNEW) C C***BEGIN PROLOGUE DNSIK C***REFER TO DDASPK C***DATE WRITTEN 940701 (YYMMDD) C***REVISION DATE 950714 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DNSIK solves a nonlinear system of algebraic equations of the C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in C the initial conditions. C C The method used is a Newton scheme combined with a linesearch C algorithm, using Krylov iterative linear system methods. C C The parameters represent C C X -- Independent variable. C Y -- Solution vector. C YPRIME -- Derivative of solution vector. C NEQ -- Number of unknowns. C ICOPT -- Initial condition option chosen (1 or 2). C ID -- Array of dimension NEQ, which must be initialized C if ICOPT = 1. See DDASIC. C RES -- External user-supplied subroutine C to evaluate the residual. See RES description C in DDASPK prologue. C PSOL -- External user-supplied routine to solve C a linear system using preconditioning. C See explanation inside DDASPK. C WT -- Vector of weights for error criterion. C RPAR,IPAR -- Real and integer arrays used for communication C between the calling program and external user C routines. They are not altered within DASPK. C SAVR -- Work vector for DNSIK of length NEQ. C DELTA -- Residual vector on entry, and work vector of C length NEQ for DNSIK. C R -- Work vector for DNSIK of length NEQ. C YIC,YPIC -- Work vectors for DNSIK, each of length NEQ. C PWK -- Work vector for DNSIK of length NEQ. C WM,IWM -- Real and integer arrays storing C matrix information such as the matrix C of partial derivatives, permutation C vector, and various other information. C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). C SQRTN -- Square root of NEQ. C RSQRTN -- reciprical of square root of NEQ. C EPLIN -- Tolerance for linear system solver. C EPCON -- Tolerance to test for convergence of the Newton C iteration. C RATEMX -- Maximum convergence rate for which Newton iteration C is considered converging. C MAXIT -- Maximum allowed number of Newton iterations. C STPTOL -- Tolerance used in calculating the minimum lambda C value allowed. C ICNFLG -- Integer scalar. If nonzero, then constraint C violations in the proposed new approximate solution C will be checked for, and the maximum step length C will be adjusted accordingly. C ICNSTR -- Integer array of length NEQ containing flags for C checking constraints. C IERNEW -- Error flag for Newton iteration. C 0 ==> Newton iteration converged. C 1 ==> failed to converge, but RATE .lt. 1. C 2 ==> failed to converge, RATE .gt. RATEMX. C 3 ==> other recoverable error. C -1 ==> unrecoverable error inside Newton iteration. C----------------------------------------------------------------------- C C***ROUTINES CALLED C DFNRMK, DSLVK, DDWNRM, DLINSK, DCOPY C C***END PROLOGUE DNSIK C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),WT(*),ID(*),DELTA(*),R(*),SAVR(*) DIMENSION YIC(*),YPIC(*),PWK(*),WM(*),IWM(*), RPAR(*),IPAR(*) DIMENSION ICNSTR(*) EXTERNAL RES, PSOL C PARAMETER (LNNI=19, LNPS=21, LLOCWP=29, LLCIWP=30) PARAMETER (LLSOFF=35, LSTOL=14) C C C Initializations. M is the Newton iteration counter. C LSOFF = IWM(LLSOFF) M = 0 RATE = 1.0D0 LWP = IWM(LLOCWP) LIWP = IWM(LLCIWP) RLX = 0.4D0 C C Save residual in SAVR. C CALL DCOPY (NEQ, DELTA, 1, SAVR, 1) C C Compute norm of (P-inverse)*(residual). C CALL DFNRMK (NEQ, Y, X, YPRIME, SAVR, R, CJ, WT, SQRTN, RSQRTN, * RES, IRES, PSOL, 1, IER, FNRM, EPLIN, WM(LWP), IWM(LIWP), * PWK, RPAR, IPAR) IWM(LNPS) = IWM(LNPS) + 1 IF (IER .NE. 0) THEN IERNEW = 3 RETURN ENDIF C C Return now if residual norm is .le. EPCON. C IF (FNRM .LE. EPCON) RETURN C C Newton iteration loop. C 300 CONTINUE IWM(LNNI) = IWM(LNNI) + 1 C C Compute a new step vector DELTA. C CALL DSLVK (NEQ, Y, X, YPRIME, SAVR, DELTA, WT, WM, IWM, * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, * RPAR, IPAR) IF (IRES .NE. 0 .OR. IERSL .NE. 0) GO TO 390 C C Get norm of DELTA. Return now if DELTA is zero. C DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) IF (DELNRM .EQ. 0.0D0) RETURN C C Call linesearch routine for global strategy and set RATE. C OLDFNM = FNRM C CALL DLINSK (NEQ, Y, X, YPRIME, SAVR, CJ, DELTA, DELNRM, WT, * SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL, WM, IWM, * RHOK, FNRM, ICOPT, ID, WM(LWP), IWM(LIWP), R, EPLIN, YIC, YPIC, * PWK, ICNFLG, ICNSTR, RLX, RPAR, IPAR) C RATE = FNRM/OLDFNM C C Check for error condition from linesearch. IF (IRET .NE. 0) GO TO 390 C C Test for convergence of the iteration, and return or loop. C IF (FNRM .LE. EPCON) RETURN C C The iteration has not yet converged. Update M. C Test whether the maximum number of iterations have been tried. C M=M+1 IF(M .GE. MAXIT) GO TO 380 C C Copy the residual SAVR to DELTA and loop for another iteration. C CALL DCOPY (NEQ, SAVR, 1, DELTA, 1) GO TO 300 C C The maximum number of iterations was done. Set IERNEW and return. C 380 IF (RATE .LE. RATEMX) THEN IERNEW = 1 ELSE IERNEW = 2 ENDIF RETURN C 390 IF (IRES .LE. -2 .OR. IERSL .LT. 0) THEN IERNEW = -1 ELSE IERNEW = 3 IF (IRES .EQ. 0 .AND. IERSL .EQ. 1 .AND. M .GE. 2 1 .AND. RATE .LT. 1.0D0) IERNEW = 1 ENDIF RETURN C C C----------------------- END OF SUBROUTINE DNSIK------------------------ END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DLINSK (NEQ, Y, T, YPRIME, SAVR, CJ, P, PNRM, WT, * SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL, WM, IWM, * RHOK, FNRM, ICOPT, ID, WP, IWP, R, EPLIN, YNEW, YPNEW, PWK, * ICNFLG, ICNSTR, RLX, RPAR, IPAR) C C***BEGIN PROLOGUE DLINSK C***REFER TO DNSIK C***DATE WRITTEN 940830 (YYMMDD) C***REVISION DATE 951006 (Arguments SQRTN, RSQRTN added.) C***REVISION DATE 960129 Moved line RL = ONE to top block. C C C----------------------------------------------------------------------- C***DESCRIPTION C C DLINSK uses a linesearch algorithm to calculate a new (Y,YPRIME) C pair (YNEW,YPNEW) such that C C f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) + C ALPHA*RL*RHOK*RHOK , C C where 0 < RL <= 1, and RHOK is the scaled preconditioned norm of C the final residual vector in the Krylov iteration. C Here, f(y,y') is defined as C C f(y,y') = (1/2)*norm( (P-inverse)*G(t,y,y') )**2 , C C where norm() is the weighted RMS vector norm, G is the DAE C system residual function, and P is the preconditioner used C in the Krylov iteration. C C In addition to the parameters defined elsewhere, we have C C SAVR -- Work array of length NEQ, containing the residual C vector G(t,y,y') on return. C P -- Approximate Newton step used in backtracking. C PNRM -- Weighted RMS norm of P. C LSOFF -- Flag showing whether the linesearch algorithm is C to be invoked. 0 means do the linesearch, C 1 means turn off linesearch. C STPTOL -- Tolerance used in calculating the minimum lambda C value allowed. C ICNFLG -- Integer scalar. If nonzero, then constraint violations C in the proposed new approximate solution will be C checked for, and the maximum step length will be C adjusted accordingly. C ICNSTR -- Integer array of length NEQ containing flags for C checking constraints. C RHOK -- Weighted norm of preconditioned Krylov residual. C RLX -- Real scalar restricting update size in DCNSTR. C YNEW -- Array of length NEQ used to hold the new Y in C performing the linesearch. C YPNEW -- Array of length NEQ used to hold the new YPRIME in C performing the linesearch. C PWK -- Work vector of length NEQ for use in PSOL. C Y -- Array of length NEQ containing the new Y (i.e.,=YNEW). C YPRIME -- Array of length NEQ containing the new YPRIME C (i.e.,=YPNEW). C FNRM -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the C current (Y,YPRIME) on input and output. C R -- Work space length NEQ for residual vector. C IRET -- Return flag. C IRET=0 means that a satisfactory (Y,YPRIME) was found. C IRET=1 means that the routine failed to find a new C (Y,YPRIME) that was sufficiently distinct from C the current (Y,YPRIME) pair. C IRET=2 means a failure in RES or PSOL. C----------------------------------------------------------------------- C C***ROUTINES CALLED C DFNRMK, DYYPNW, DCOPY C C***END PROLOGUE DLINSK C IMPLICIT DOUBLE PRECISION(A-H,O-Z) EXTERNAL RES, PSOL DIMENSION Y(*), YPRIME(*), P(*), WT(*), SAVR(*), R(*), ID(*) DIMENSION WM(*), IWM(*), YNEW(*), YPNEW(*), PWK(*), ICNSTR(*) DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*) C PARAMETER (LNRE=12, LNPS=21, LKPRIN=31) C SAVE ALPHA, ONE, TWO DATA ALPHA/1.0D-4/, ONE/1.0D0/, TWO/2.0D0/ C KPRIN=IWM(LKPRIN) F1NRM = (FNRM*FNRM)/TWO RATIO = ONE C IF (KPRIN .GE. 2) THEN call rprintfd1( 1 'daspk-- in routine dlinsd--PNRM (= %g)' // char(0),PNRM) ENDIF TAU = PNRM IVIO = 0 RL = ONE C----------------------------------------------------------------------- C Check for violations of the constraints, if any are imposed. C If any violations are found, the step vector P is rescaled, and the C constraint check is repeated, until no violations are found. C----------------------------------------------------------------------- IF (ICNFLG .NE. 0) THEN 10 CONTINUE CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) CALL DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) IF (IRET .EQ. 1) THEN IVIO = 1 RATIO1 = TAU/PNRM RATIO = RATIO*RATIO1 DO 20 I = 1,NEQ P(I) = P(I)*RATIO1 20 CONTINUE PNRM = TAU IF (KPRIN .GE. 2) THEN call rprintfid( 1 'daspk-- constraint violation, PNRM(%g), INDEX(%i)' & // char(0),IVAR,PNRM) ENDIF IF (PNRM .LE. STPTOL) THEN IRET = 1 RETURN ENDIF GO TO 10 ENDIF ENDIF C SLPI = (-TWO*F1NRM + RHOK*RHOK)*RATIO RLMIN = STPTOL/PNRM IF (LSOFF .EQ. 0 .AND. KPRIN .GE. 2) THEN call rprintfd1( 1 'daspk-- Min. LAMBDA &g' // char(0), RLMIN) ENDIF C----------------------------------------------------------------------- C Begin iteration to find RL value satisfying alpha-condition. C Update YNEW and YPNEW, then compute norm of new scaled residual and C perform alpha condition test. C----------------------------------------------------------------------- 100 CONTINUE CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) CALL DFNRMK (NEQ, YNEW, T, YPNEW, SAVR, R, CJ, WT, SQRTN, RSQRTN, * RES, IRES, PSOL, 0, IER, FNRMP, EPLIN, WP, IWP, PWK, RPAR, IPAR) IWM(LNRE) = IWM(LNRE) + 1 IF (IRES .GE. 0) IWM(LNPS) = IWM(LNPS) + 1 IF (IRES .NE. 0 .OR. IER .NE. 0) THEN IRET = 2 RETURN ENDIF IF (LSOFF .EQ. 1) GO TO 150 C F1NRMP = FNRMP*FNRMP/TWO IF (KPRIN .GE. 2) THEN call rprintfd1( 1 'daspk-- LAMBDA (= %g)' // char(0), RL) call rprintfd2( 1 ' -- NORM(F1) (= %g), NORM(F1NEW) (= %g)' & // char(0), F1NRM, F1NRMP) ENDIF IF (F1NRMP .GT. F1NRM + ALPHA*SLPI*RL) GO TO 200 C----------------------------------------------------------------------- C Alpha-condition is satisfied, or linesearch is turned off. C Copy YNEW,YPNEW to Y,YPRIME and return. C----------------------------------------------------------------------- 150 IRET = 0 CALL DCOPY(NEQ, YNEW, 1, Y, 1) CALL DCOPY(NEQ, YPNEW, 1, YPRIME, 1) FNRM = FNRMP IF (KPRIN .GE. 1) THEN call rprintfd1( 1 'daspk-- leaving routine dlinsk--FNRM %g' // char(0), FNRM) ENDIF RETURN C----------------------------------------------------------------------- C Alpha-condition not satisfied. Perform backtrack to compute new RL C value. If RL is less than RLMIN, i.e. no satisfactory YNEW,YPNEW can C be found sufficiently distinct from Y,YPRIME, then return IRET = 1. C----------------------------------------------------------------------- 200 CONTINUE IF (RL .LT. RLMIN) THEN IRET = 1 RETURN ENDIF C RL = RL/TWO GO TO 100 C C----------------------- END OF SUBROUTINE DLINSK ---------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DFNRMK (NEQ, Y, T, YPRIME, SAVR, R, CJ, WT, * SQRTN, RSQRTN, RES, IRES, PSOL, IRIN, IER, * FNORM, EPLIN, WP, IWP, PWK, RPAR, IPAR) C C***BEGIN PROLOGUE DFNRMK C***REFER TO DLINSK C***DATE WRITTEN 940830 (YYMMDD) C***REVISION DATE 951006 (SQRTN, RSQRTN, and scaling of WT added.) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DFNRMK calculates the scaled preconditioned norm of the nonlinear C function used in the nonlinear iteration for obtaining consistent C initial conditions. Specifically, DFNRMK calculates the weighted C root-mean-square norm of the vector (P-inverse)*G(T,Y,YPRIME), C where P is the preconditioner matrix. C C In addition to the parameters described in the calling program C DLINSK, the parameters represent C C IRIN -- Flag showing whether the current residual vector is C input in SAVR. 1 means it is, 0 means it is not. C R -- Array of length NEQ that contains C (P-inverse)*G(T,Y,YPRIME) on return. C FNORM -- Scalar containing the weighted norm of R on return. C----------------------------------------------------------------------- C C***ROUTINES CALLED C RES, DCOPY, DSCAL, PSOL, DDWNRM C C***END PROLOGUE DFNRMK C C IMPLICIT DOUBLE PRECISION (A-H,O-Z) EXTERNAL RES, PSOL DIMENSION Y(*), YPRIME(*), WT(*), SAVR(*), R(*), PWK(*) DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call RES routine if IRIN = 0. C----------------------------------------------------------------------- IF (IRIN .EQ. 0) THEN IRES = 0 CALL RES (T, Y, YPRIME, CJ, SAVR, IRES, RPAR, IPAR) IF (IRES .LT. 0) RETURN ENDIF C----------------------------------------------------------------------- C Apply inverse of left preconditioner to vector R. C First scale WT array by 1/sqrt(N), and undo scaling afterward. C----------------------------------------------------------------------- CALL DCOPY(NEQ, SAVR, 1, R, 1) CALL DSCAL (NEQ, RSQRTN, WT, 1) IER = 0 CALL PSOL (NEQ, T, Y, YPRIME, SAVR, PWK, CJ, WT, WP, IWP, * R, EPLIN, IER, RPAR, IPAR) CALL DSCAL (NEQ, SQRTN, WT, 1) IF (IER .NE. 0) RETURN C----------------------------------------------------------------------- C Calculate norm of R. C----------------------------------------------------------------------- FNORM = DDWNRM (NEQ, R, WT, RPAR, IPAR) C RETURN C----------------------- END OF SUBROUTINE DFNRMK ---------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DNEDK(X,Y,YPRIME,NEQ,RES,JACK,PSOL, * H,WT,JSTART,IDID,RPAR,IPAR,PHI,GAMMA,SAVR,DELTA,E, * WM,IWM,CJ,CJOLD,CJLAST,S,UROUND,EPLI,SQRTN,RSQRTN, * EPCON,JCALC,JFLG,KP1,NONNEG,NTYPE,IERNLS) C C***BEGIN PROLOGUE DNEDK C***REFER TO DDASPK C***DATE WRITTEN 891219 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***REVISION DATE 940701 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DNEDK solves a nonlinear system of C algebraic equations of the form C G(X,Y,YPRIME) = 0 for the unknown Y. C C The method used is a matrix-free Newton scheme. C C The parameters represent C X -- Independent variable. C Y -- Solution vector at x. C YPRIME -- Derivative of solution vector C after successful step. C NEQ -- Number of equations to be integrated. C RES -- External user-supplied subroutine C to evaluate the residual. See RES description C in DDASPK prologue. C JACK -- External user-supplied routine to update C the preconditioner. (This is optional). C See JAC description for the case C INFO(12) = 1 in the DDASPK prologue. C PSOL -- External user-supplied routine to solve C a linear system using preconditioning. C (This is optional). See explanation inside DDASPK. C H -- Appropriate step size for this step. C WT -- Vector of weights for error criterion. C JSTART -- Indicates first call to this routine. C If JSTART = 0, then this is the first call, C otherwise it is not. C IDID -- Completion flag, output by DNEDK. C See IDID description in DDASPK prologue. C RPAR,IPAR -- Real and integer arrays used for communication C between the calling program and external user C routines. They are not altered within DASPK. C PHI -- Array of divided differences used by C DNEDK. The length is NEQ*(K+1), where C K is the maximum order. C GAMMA -- Array used to predict Y and YPRIME. The length C is K+1, where K is the maximum order. C SAVR -- Work vector for DNEDK of length NEQ. C DELTA -- Work vector for DNEDK of length NEQ. C E -- Error accumulation vector for DNEDK of length NEQ. C WM,IWM -- Real and integer arrays storing C matrix information for linear system C solvers, and various other information. C CJ -- Parameter always proportional to 1/H. C CJOLD -- Saves the value of CJ as of the last call to DITMD. C Accounts for changes in CJ needed to C decide whether to call DITMD. C CJLAST -- Previous value of CJ. C S -- A scalar determined by the approximate rate C of convergence of the Newton iteration and used C in the convergence test for the Newton iteration. C C If RATE is defined to be an estimate of the C rate of convergence of the Newton iteration, C then S = RATE/(1.D0-RATE). C C The closer RATE is to 0., the faster the Newton C iteration is converging; the closer RATE is to 1., C the slower the Newton iteration is converging. C C On the first Newton iteration with an up-dated C preconditioner S = 100.D0, Thus the initial C RATE of convergence is approximately 1. C C S is preserved from call to call so that the rate C estimate from a previous step can be applied to C the current step. C UROUND -- Unit roundoff. C EPLI -- convergence test constant. C See DDASPK prologue for more details. C SQRTN -- Square root of NEQ. C RSQRTN -- reciprical of square root of NEQ. C EPCON -- Tolerance to test for convergence of the Newton C iteration. C JCALC -- Flag used to determine when to update C the Jacobian matrix. In general: C C JCALC = -1 ==> Call the DITMD routine to update C the Jacobian matrix. C JCALC = 0 ==> Jacobian matrix is up-to-date. C JCALC = 1 ==> Jacobian matrix is out-dated, C but DITMD will not be called unless C JCALC is set to -1. C JFLG -- Flag showing whether a Jacobian routine is supplied. C KP1 -- The current order + 1; updated across calls. C NONNEG -- Flag to determine nonnegativity constraints. C NTYPE -- Identification code for the DNEDK routine. C 1 ==> modified Newton; iterative linear solver. C 2 ==> modified Newton; user-supplied linear solver. C IERNLS -- Error flag for nonlinear solver. C 0 ==> nonlinear solver converged. C 1 ==> recoverable error inside non-linear solver. C -1 ==> unrecoverable error inside non-linear solver. C C The following group of variables are passed as arguments to C the Newton iteration solver. They are explained in greater detail C in DNSK: C TOLNEW, MULDEL, MAXIT, IERNEW C C IERTYP -- Flag which tells whether this subroutine is correct. C 0 ==> correct subroutine. C 1 ==> incorrect subroutine. C C----------------------------------------------------------------------- C***ROUTINES CALLED C RES, JACK, DDWNRM, DNSK C C***END PROLOGUE DNEDK C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),WT(*) DIMENSION PHI(NEQ,*),SAVR(*),DELTA(*),E(*) DIMENSION WM(*),IWM(*) DIMENSION GAMMA(*),RPAR(*),IPAR(*) EXTERNAL RES, JACK, PSOL C PARAMETER (LNRE=12, LNJE=13, LLOCWP=29, LLCIWP=30) C SAVE MULDEL, MAXIT, XRATE DATA MULDEL/0/, MAXIT/4/, XRATE/0.25D0/ C C Verify that this is the correct subroutine. C IRES = 0 ! Karline-added that to avoid warning IERTYP = 0 IF (NTYPE .NE. 1) THEN IERTYP = 1 GO TO 380 ENDIF C C If this is the first step, perform initializations. C IF (JSTART .EQ. 0) THEN CJOLD = CJ JCALC = -1 S = 100.D0 ENDIF C C Perform all other initializations. C IERNLS = 0 LWP = IWM(LLOCWP) LIWP = IWM(LLCIWP) C C Decide whether to update the preconditioner. C IF (JFLG .NE. 0) THEN TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) TEMP2 = 1.0D0/TEMP1 IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 IF (CJ .NE. CJLAST) S = 100.D0 ELSE JCALC = 0 ENDIF C C Looping point for updating preconditioner with current stepsize. C 300 CONTINUE C C Initialize all error flags to zero. C IERPJ = 0 IRES = 0 IERSL = 0 IERNEW = 0 C C Predict the solution and derivative and compute the tolerance C for the Newton iteration. C DO 310 I=1,NEQ Y(I)=PHI(I,1) YPRIME(I)=0.0D0 310 CONTINUE DO 330 J=2,KP1 DO 320 I=1,NEQ Y(I)=Y(I)+PHI(I,J) YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) 320 CONTINUE 330 CONTINUE EPLIN = EPLI*EPCON TOLNEW = EPLIN C C Call RES to initialize DELTA. C IWM(LNRE)=IWM(LNRE)+1 CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 380 C C C If indicated, update the preconditioner. C Set JCALC to 0 as an indicator that this has been done. C IF(JCALC .EQ. -1)THEN IWM(LNJE) = IWM(LNJE) + 1 JCALC=0 CALL JACK (RES, IRES, NEQ, X, Y, YPRIME, WT, DELTA, E, H, CJ, * WM(LWP), IWM(LIWP), IERPJ, RPAR, IPAR) CJOLD=CJ S = 100.D0 IF (IRES .LT. 0) GO TO 380 IF (IERPJ .NE. 0) GO TO 380 ENDIF C C Call the nonlinear Newton solver. C CALL DNSK(X,Y,YPRIME,NEQ,RES,PSOL,WT,RPAR,IPAR,SAVR, * DELTA,E,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON, * S,TEMP1,TOLNEW,MULDEL,MAXIT,IRES,IERSL,IERNEW) C IF (IERNEW .GT. 0 .AND. JCALC .NE. 0) THEN C C The Newton iteration had a recoverable failure with an old C preconditioner. Retry the step with a new preconditioner. C JCALC = -1 GO TO 300 ENDIF C IF (IERNEW .NE. 0) GO TO 380 C C The Newton iteration has converged. If nonnegativity of C solution is required, set the solution nonnegative, if the C perturbation to do it is small enough. If the change is too C large, then consider the corrector iteration to have failed. C IF(NONNEG .EQ. 0) GO TO 390 DO 360 I = 1,NEQ DELTA(I) = MIN(Y(I),0.0D0) 360 CONTINUE DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) IF(DELNRM .GT. EPCON) GO TO 380 DO 370 I = 1,NEQ E(I) = E(I) - DELTA(I) 370 CONTINUE GO TO 390 C C C Exits from nonlinear solver. C No convergence with current preconditioner. C Compute IERNLS and IDID accordingly. C 380 CONTINUE IF (IRES .LE. -2 .OR. IERSL .LT. 0 .OR. IERTYP .NE. 0) THEN IERNLS = -1 IF (IRES .LE. -2) IDID = -11 IF (IERSL .LT. 0) IDID = -13 IF (IERTYP .NE. 0) IDID = -15 ELSE IERNLS = 1 IF (IRES .EQ. -1) IDID = -10 IF (IERPJ .NE. 0) IDID = -5 IF (IERSL .GT. 0) IDID = -14 ENDIF C C 390 JCALC = 1 RETURN C C------END OF SUBROUTINE DNEDK------------------------------------------ END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DNSK(X,Y,YPRIME,NEQ,RES,PSOL,WT,RPAR,IPAR, * SAVR,DELTA,E,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON, * S,CONFAC,TOLNEW,MULDEL,MAXIT,IRES,IERSL,IERNEW) C C***BEGIN PROLOGUE DNSK C***REFER TO DDASPK C***DATE WRITTEN 891219 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***REVISION DATE 950126 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DNSK solves a nonlinear system of C algebraic equations of the form C G(X,Y,YPRIME) = 0 for the unknown Y. C C The method used is a modified Newton scheme. C C The parameters represent C C X -- Independent variable. C Y -- Solution vector. C YPRIME -- Derivative of solution vector. C NEQ -- Number of unknowns. C RES -- External user-supplied subroutine C to evaluate the residual. See RES description C in DDASPK prologue. C PSOL -- External user-supplied routine to solve C a linear system using preconditioning. C See explanation inside DDASPK. C WT -- Vector of weights for error criterion. C RPAR,IPAR -- Real and integer arrays used for communication C between the calling program and external user C routines. They are not altered within DASPK. C SAVR -- Work vector for DNSK of length NEQ. C DELTA -- Work vector for DNSK of length NEQ. C E -- Error accumulation vector for DNSK of length NEQ. C WM,IWM -- Real and integer arrays storing C matrix information such as the matrix C of partial derivatives, permutation C vector, and various other information. C CJ -- Parameter always proportional to 1/H (step size). C SQRTN -- Square root of NEQ. C RSQRTN -- reciprical of square root of NEQ. C EPLIN -- Tolerance for linear system solver. C EPCON -- Tolerance to test for convergence of the Newton C iteration. C S -- Used for error convergence tests. C In the Newton iteration: S = RATE/(1.D0-RATE), C where RATE is the estimated rate of convergence C of the Newton iteration. C C The closer RATE is to 0., the faster the Newton C iteration is converging; the closer RATE is to 1., C the slower the Newton iteration is converging. C C The calling routine sends the initial value C of S to the Newton iteration. C CONFAC -- A residual scale factor to improve convergence. C TOLNEW -- Tolerance on the norm of Newton correction in C alternative Newton convergence test. C MULDEL -- A flag indicating whether or not to multiply C DELTA by CONFAC. C 0 ==> do not scale DELTA by CONFAC. C 1 ==> scale DELTA by CONFAC. C MAXIT -- Maximum allowed number of Newton iterations. C IRES -- Error flag returned from RES. See RES description C in DDASPK prologue. If IRES = -1, then IERNEW C will be set to 1. C If IRES < -1, then IERNEW will be set to -1. C IERSL -- Error flag for linear system solver. C See IERSL description in subroutine DSLVK. C If IERSL = 1, then IERNEW will be set to 1. C If IERSL < 0, then IERNEW will be set to -1. C IERNEW -- Error flag for Newton iteration. C 0 ==> Newton iteration converged. C 1 ==> recoverable error inside Newton iteration. C -1 ==> unrecoverable error inside Newton iteration. C----------------------------------------------------------------------- C C***ROUTINES CALLED C RES, DSLVK, DDWNRM C C***END PROLOGUE DNSK C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),WT(*),DELTA(*),E(*),SAVR(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) EXTERNAL RES, PSOL C PARAMETER (LNNI=19, LNRE=12) C C Initialize Newton counter M and accumulation vector E. C M = 0 DO 100 I=1,NEQ E(I) = 0.0D0 100 CONTINUE C C Corrector loop. C 300 CONTINUE IWM(LNNI) = IWM(LNNI) + 1 C C If necessary, multiply residual by convergence factor. C IF (MULDEL .EQ. 1) THEN DO 320 I = 1,NEQ DELTA(I) = DELTA(I) * CONFAC 320 CONTINUE ENDIF C C Save residual in SAVR. C DO 340 I = 1,NEQ SAVR(I) = DELTA(I) 340 CONTINUE C C Compute a new iterate. Store the correction in DELTA. C CALL DSLVK (NEQ, Y, X, YPRIME, SAVR, DELTA, WT, WM, IWM, * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, * RPAR, IPAR) IF (IRES .NE. 0 .OR. IERSL .NE. 0) GO TO 380 C C Update Y, E, and YPRIME. C DO 360 I=1,NEQ Y(I) = Y(I) - DELTA(I) E(I) = E(I) - DELTA(I) YPRIME(I) = YPRIME(I) - CJ*DELTA(I) 360 CONTINUE C C Test for convergence of the iteration. C DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) IF (DELNRM .LE. TOLNEW) GO TO 370 IF (M .EQ. 0) THEN OLDNRM = DELNRM ELSE RATE = (DELNRM/OLDNRM)**(1.0D0/M) IF (RATE .GT. 0.9D0) GO TO 380 S = RATE/(1.0D0 - RATE) ENDIF IF (S*DELNRM .LE. EPCON) GO TO 370 C C The corrector has not yet converged. Update M and test whether C the maximum number of iterations have been tried. C M = M + 1 IF (M .GE. MAXIT) GO TO 380 C C Evaluate the residual, and go back to do another iteration. C IWM(LNRE) = IWM(LNRE) + 1 CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 380 GO TO 300 C C The iteration has converged. C 370 RETURN C C The iteration has not converged. Set IERNEW appropriately. C 380 CONTINUE IF (IRES .LE. -2 .OR. IERSL .LT. 0) THEN IERNEW = -1 ELSE IERNEW = 1 ENDIF RETURN C C C------END OF SUBROUTINE DNSK------------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DSLVK (NEQ, Y, TN, YPRIME, SAVR, X, EWT, WM, IWM, * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, * RPAR, IPAR) C C***BEGIN PROLOGUE DSLVK C***REFER TO DDASPK C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***REVISION DATE 940928 Removed MNEWT and added RHOK in call list. C C C----------------------------------------------------------------------- C***DESCRIPTION C C DSLVK uses a restart algorithm and interfaces to DSPIGM for C the solution of the linear system arising from a Newton iteration. C C In addition to variables described elsewhere, C communication with DSLVK uses the following variables.. C WM = Real work space containing data for the algorithm C (Krylov basis vectors, Hessenberg matrix, etc.). C IWM = Integer work space containing data for the algorithm. C X = The right-hand side vector on input, and the solution vector C on output, of length NEQ. C IRES = Error flag from RES. C IERSL = Output flag .. C IERSL = 0 means no trouble occurred (or user RES routine C returned IRES < 0) C IERSL = 1 means the iterative method failed to converge C (DSPIGM returned IFLAG > 0.) C IERSL = -1 means there was a nonrecoverable error in the C iterative solver, and an error exit will occur. C----------------------------------------------------------------------- C***ROUTINES CALLED C DSCAL, DCOPY, DSPIGM C C***END PROLOGUE DSLVK C INTEGER NEQ, IWM, IRES, IERSL, IPAR DOUBLE PRECISION Y, TN, YPRIME, SAVR, X, EWT, WM, CJ, EPLIN, 1 SQRTN, RSQRTN, RHOK, RPAR DIMENSION Y(*), YPRIME(*), SAVR(*), X(*), EWT(*), 1 WM(*), IWM(*), RPAR(*), IPAR(*) C INTEGER IFLAG, IRST, NRSTS, NRMAX, LR, LDL, LHES, LGMR, LQ, LV, 1 LWK, LZ, MAXLP1, NPSL INTEGER NLI, NPS, NCFL, NRE, MAXL, KMP, MITER EXTERNAL RES, PSOL C PARAMETER (LNRE=12, LNCFL=16, LNLI=20, LNPS=21) PARAMETER (LLOCWP=29, LLCIWP=30) PARAMETER (LMITER=23, LMAXL=24, LKMP=25, LNRMAX=26) C C----------------------------------------------------------------------- C IRST is set to 1, to indicate restarting is in effect. C NRMAX is the maximum number of restarts. C----------------------------------------------------------------------- DATA IRST/1/ C LIWP = IWM(LLCIWP) NLI = IWM(LNLI) NPS = IWM(LNPS) NCFL = IWM(LNCFL) NRE = IWM(LNRE) LWP = IWM(LLOCWP) MAXL = IWM(LMAXL) KMP = IWM(LKMP) NRMAX = IWM(LNRMAX) MITER = IWM(LMITER) IERSL = 0 IRES = 0 C----------------------------------------------------------------------- C Use a restarting strategy to solve the linear system C P*X = -F. Parse the work vector, and perform initializations. C Note that zero is the initial guess for X. C----------------------------------------------------------------------- MAXLP1 = MAXL + 1 LV = 1 LR = LV + NEQ*MAXL LHES = LR + NEQ + 1 LQ = LHES + MAXL*MAXLP1 LWK = LQ + 2*MAXL LDL = LWK + MIN0(1,MAXL-KMP)*NEQ LZ = LDL + NEQ CALL DSCAL (NEQ, RSQRTN, EWT, 1) CALL DCOPY (NEQ, X, 1, WM(LR), 1) DO 110 I = 1,NEQ X(I) = 0.D0 110 CONTINUE C----------------------------------------------------------------------- C Top of loop for the restart algorithm. Initial pass approximates C X and sets up a transformed system to perform subsequent restarts C to update X. NRSTS is initialized to -1, because restarting C does not occur until after the first pass. C Update NRSTS; conditionally copy DL to R; call the DSPIGM C algorithm to solve A*Z = R; updated counters; update X with C the residual solution. C Note: if convergence is not achieved after NRMAX restarts, C then the linear solver is considered to have failed. C----------------------------------------------------------------------- NRSTS = -1 115 CONTINUE NRSTS = NRSTS + 1 IF (NRSTS .GT. 0) CALL DCOPY (NEQ, WM(LDL), 1, WM(LR),1) CALL DSPIGM (NEQ, TN, Y, YPRIME, SAVR, WM(LR), EWT, MAXL, MAXLP1, 1 KMP, EPLIN, CJ, RES, IRES, NRES, PSOL, NPSL, WM(LZ), WM(LV), 2 WM(LHES), WM(LQ), LGMR, WM(LWP), IWM(LIWP), WM(LWK), 3 WM(LDL), RHOK, IFLAG, IRST, NRSTS, RPAR, IPAR) NLI = NLI + LGMR NPS = NPS + NPSL NRE = NRE + NRES DO 120 I = 1,NEQ X(I) = X(I) + WM(LZ+I-1) 120 CONTINUE IF ((IFLAG .EQ. 1) .AND. (NRSTS .LT. NRMAX) .AND. (IRES .EQ. 0)) 1 GO TO 115 C----------------------------------------------------------------------- C The restart scheme is finished. Test IRES and IFLAG to see if C convergence was not achieved, and set flags accordingly. C----------------------------------------------------------------------- IF (IRES .LT. 0) THEN NCFL = NCFL + 1 ELSE IF (IFLAG .NE. 0) THEN NCFL = NCFL + 1 IF (IFLAG .GT. 0) IERSL = 1 IF (IFLAG .LT. 0) IERSL = -1 ENDIF C----------------------------------------------------------------------- C Update IWM with counters, rescale EWT, and return. C----------------------------------------------------------------------- IWM(LNLI) = NLI IWM(LNPS) = NPS IWM(LNCFL) = NCFL IWM(LNRE) = NRE CALL DSCAL (NEQ, SQRTN, EWT, 1) RETURN C C------END OF SUBROUTINE DSLVK------------------------------------------ END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DSPIGM (NEQ, TN, Y, YPRIME, SAVR, R, WGHT, MAXL, * MAXLP1, KMP, EPLIN, CJ, RES, IRES, NRE, PSOL, NPSL, Z, V, * HES, Q, LGMR, WP, IWP, WK, DL, RHOK, IFLAG, IRST, NRSTS, * RPAR, IPAR) C C***BEGIN PROLOGUE DSPIGM C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***REVISION DATE 940927 Removed MNEWT and added RHOK in call list. C C C----------------------------------------------------------------------- C***DESCRIPTION C C This routine solves the linear system A * Z = R using a scaled C preconditioned version of the generalized minimum residual method. C An initial guess of Z = 0 is assumed. C C On entry C C NEQ = Problem size, passed to PSOL. C C TN = Current Value of T. C C Y = Array Containing current dependent variable vector. C C YPRIME = Array Containing current first derivative of Y. C C SAVR = Array containing current value of G(T,Y,YPRIME). C C R = The right hand side of the system A*Z = R. C R is also used as work space when computing C the final approximation and will therefore be C destroyed. C (R is the same as V(*,MAXL+1) in the call to DSPIGM.) C C WGHT = The vector of length NEQ containing the nonzero C elements of the diagonal scaling matrix. C C MAXL = The maximum allowable order of the matrix H. C C MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES. C C KMP = The number of previous vectors the new vector, VNEW, C must be made orthogonal to. (KMP .LE. MAXL.) C C EPLIN = Tolerance on residuals R-A*Z in weighted rms norm. C C CJ = Scalar proportional to current value of C 1/(step size H). C C WK = Real work array used by routine DATVPK and PSOL. C C DL = Real work array used for calculation of the residual C norm RHO when the method is incomplete (KMP.LT.MAXL) C and/or when using restarting. C C WP = Real work array used by preconditioner PSOL. C C IWP = Integer work array used by preconditioner PSOL. C C IRST = Method flag indicating if restarting is being C performed. IRST .GT. 0 means restarting is active, C while IRST = 0 means restarting is not being used. C C NRSTS = Counter for the number of restarts on the current C call to DSPIGM. If NRSTS .GT. 0, then the residual C R is already scaled, and so scaling of R is not C necessary. C C C On Return C C Z = The final computed approximation to the solution C of the system A*Z = R. C C LGMR = The number of iterations performed and C the current order of the upper Hessenberg C matrix HES. C C NRE = The number of calls to RES (i.e. DATVPK) C C NPSL = The number of calls to PSOL. C C V = The neq by (LGMR+1) array containing the LGMR C orthogonal vectors V(*,1) to V(*,LGMR). C C HES = The upper triangular factor of the QR decomposition C of the (LGMR+1) by LGMR upper Hessenberg matrix whose C entries are the scaled inner-products of A*V(*,I) C and V(*,K). C C Q = Real array of length 2*MAXL containing the components C of the givens rotations used in the QR decomposition C of HES. It is loaded in DHEQR and used in DHELS. C C IRES = Error flag from RES. C C DL = Scaled preconditioned residual, C (D-inverse)*(P-inverse)*(R-A*Z). Only loaded when C performing restarts of the Krylov iteration. C C RHOK = Weighted norm of final preconditioned residual. C C IFLAG = Integer error flag.. C 0 Means convergence in LGMR iterations, LGMR.LE.MAXL. C 1 Means the convergence test did not pass in MAXL C iterations, but the new residual norm (RHO) is C .LT. the old residual norm (RNRM), and so Z is C computed. C 2 Means the convergence test did not pass in MAXL C iterations, new residual norm (RHO) .GE. old residual C norm (RNRM), and the initial guess, Z = 0, is C returned. C 3 Means there was a recoverable error in PSOL C caused by the preconditioner being out of date. C -1 Means there was an unrecoverable error in PSOL. C C----------------------------------------------------------------------- C***ROUTINES CALLED C PSOL, DNRM2, DSCAL, DATVPK, DORTH, DHEQR, DCOPY, DHELS, DAXPY C C***END PROLOGUE DSPIGM C INTEGER NEQ,MAXL,MAXLP1,KMP,IRES,NRE,NPSL,LGMR,IWP, 1 IFLAG,IRST,NRSTS,IPAR DOUBLE PRECISION TN,Y,YPRIME,SAVR,R,WGHT,EPLIN,CJ,Z,V,HES,Q,WP,WK, 1 DL,RHOK,RPAR DIMENSION Y(*), YPRIME(*), SAVR(*), R(*), WGHT(*), Z(*), 1 V(NEQ,*), HES(MAXLP1,*), Q(*), WP(*), IWP(*), WK(*), DL(*), 2 RPAR(*), IPAR(*) INTEGER I, IER, INFO, IP1, I2, J, K, LL, LLP1 DOUBLE PRECISION RNRM,C,DLNRM,PROD,RHO,S,SNORMW,DNRM2,TEM EXTERNAL RES, PSOL C ! KARLINE: INITIALISED RHO TO AVOID A WARNING - should have no effect RHO = 0.D0 IER = 0 IFLAG = 0 LGMR = 0 NPSL = 0 NRE = 0 C----------------------------------------------------------------------- C The initial guess for Z is 0. The initial residual is therefore C the vector R. Initialize Z to 0. C----------------------------------------------------------------------- DO 10 I = 1,NEQ Z(I) = 0.0D0 10 CONTINUE C----------------------------------------------------------------------- C Apply inverse of left preconditioner to vector R if NRSTS .EQ. 0. C Form V(*,1), the scaled preconditioned right hand side. C----------------------------------------------------------------------- IF (NRSTS .EQ. 0) THEN CALL PSOL (NEQ, TN, Y, YPRIME, SAVR, WK, CJ, WGHT, WP, IWP, 1 R, EPLIN, IER, RPAR, IPAR) NPSL = 1 IF (IER .NE. 0) GO TO 300 DO 30 I = 1,NEQ V(I,1) = R(I)*WGHT(I) 30 CONTINUE ELSE DO 35 I = 1,NEQ V(I,1) = R(I) 35 CONTINUE ENDIF C----------------------------------------------------------------------- C Calculate norm of scaled vector V(*,1) and normalize it C If, however, the norm of V(*,1) (i.e. the norm of the preconditioned C residual) is .le. EPLIN, then return with Z=0. C----------------------------------------------------------------------- RNRM = DNRM2 (NEQ, V, 1) IF (RNRM .LE. EPLIN) THEN RHOK = RNRM RETURN ENDIF TEM = 1.0D0/RNRM CALL DSCAL (NEQ, TEM, V(1,1), 1) C----------------------------------------------------------------------- C Zero out the HES array. C----------------------------------------------------------------------- DO 65 J = 1,MAXL DO 60 I = 1,MAXLP1 HES(I,J) = 0.0D0 60 CONTINUE 65 CONTINUE C----------------------------------------------------------------------- C Main loop to compute the vectors V(*,2) to V(*,MAXL). C The running product PROD is needed for the convergence test. C----------------------------------------------------------------------- PROD = 1.0D0 DO 90 LL = 1,MAXL LGMR = LL C----------------------------------------------------------------------- C Call routine DATVPK to compute VNEW = ABAR*V(LL), where ABAR is C the matrix A with scaling and inverse preconditioner factors applied. C Call routine DORTH to orthogonalize the new vector VNEW = V(*,LL+1). C call routine DHEQR to update the factors of HES. C----------------------------------------------------------------------- CALL DATVPK (NEQ, Y, TN, YPRIME, SAVR, V(1,LL), WGHT, Z, 1 RES, IRES, PSOL, V(1,LL+1), WK, WP, IWP, CJ, EPLIN, 1 IER, NRE, NPSL, RPAR, IPAR) IF (IRES .LT. 0) RETURN IF (IER .NE. 0) GO TO 300 CALL DORTH (V(1,LL+1), V, HES, NEQ, LL, MAXLP1, KMP, SNORMW) HES(LL+1,LL) = SNORMW CALL DHEQR (HES, MAXLP1, LL, Q, INFO, LL) IF (INFO .EQ. LL) GO TO 120 C----------------------------------------------------------------------- C Update RHO, the estimate of the norm of the residual R - A*ZL. C If KMP .LT. MAXL, then the vectors V(*,1),...,V(*,LL+1) are not C necessarily orthogonal for LL .GT. KMP. The vector DL must then C be computed, and its norm used in the calculation of RHO. C----------------------------------------------------------------------- PROD = PROD*Q(2*LL) RHO = ABS(PROD*RNRM) IF ((LL.GT.KMP) .AND. (KMP.LT.MAXL)) THEN IF (LL .EQ. KMP+1) THEN CALL DCOPY (NEQ, V(1,1), 1, DL, 1) DO 75 I = 1,KMP IP1 = I + 1 I2 = I*2 S = Q(I2) C = Q(I2-1) DO 70 K = 1,NEQ DL(K) = S*DL(K) + C*V(K,IP1) 70 CONTINUE 75 CONTINUE ENDIF S = Q(2*LL) C = Q(2*LL-1)/SNORMW LLP1 = LL + 1 DO 80 K = 1,NEQ DL(K) = S*DL(K) + C*V(K,LLP1) 80 CONTINUE DLNRM = DNRM2 (NEQ, DL, 1) RHO = RHO*DLNRM ENDIF C----------------------------------------------------------------------- C Test for convergence. If passed, compute approximation ZL. C If failed and LL .LT. MAXL, then continue iterating. C----------------------------------------------------------------------- IF (RHO .LE. EPLIN) GO TO 200 IF (LL .EQ. MAXL) GO TO 100 C----------------------------------------------------------------------- C Rescale so that the norm of V(1,LL+1) is one. C----------------------------------------------------------------------- TEM = 1.0D0/SNORMW CALL DSCAL (NEQ, TEM, V(1,LL+1), 1) 90 CONTINUE 100 CONTINUE IF (RHO .LT. RNRM) GO TO 150 120 CONTINUE IFLAG = 2 DO 130 I = 1,NEQ Z(I) = 0.D0 130 CONTINUE RETURN 150 IFLAG = 1 C----------------------------------------------------------------------- C The tolerance was not met, but the residual norm was reduced. C If performing restarting (IRST .gt. 0) calculate the residual vector C RL and store it in the DL array. If the incomplete version is C being used (KMP .lt. MAXL) then DL has already been calculated. C----------------------------------------------------------------------- IF (IRST .GT. 0) THEN IF (KMP .EQ. MAXL) THEN C C Calculate DL from the V(I)'s. C CALL DCOPY (NEQ, V(1,1), 1, DL, 1) MAXLM1 = MAXL - 1 DO 175 I = 1,MAXLM1 IP1 = I + 1 I2 = I*2 S = Q(I2) C = Q(I2-1) DO 170 K = 1,NEQ DL(K) = S*DL(K) + C*V(K,IP1) 170 CONTINUE 175 CONTINUE S = Q(2*MAXL) C = Q(2*MAXL-1)/SNORMW DO 180 K = 1,NEQ DL(K) = S*DL(K) + C*V(K,MAXLP1) 180 CONTINUE ENDIF C C Scale DL by RNRM*PROD to obtain the residual RL. C TEM = RNRM*PROD CALL DSCAL(NEQ, TEM, DL, 1) ENDIF C----------------------------------------------------------------------- C Compute the approximation ZL to the solution. C Since the vector Z was used as work space, and the initial guess C of the Newton correction is zero, Z must be reset to zero. C----------------------------------------------------------------------- 200 CONTINUE LL = LGMR LLP1 = LL + 1 DO 210 K = 1,LLP1 R(K) = 0.0D0 210 CONTINUE R(1) = RNRM CALL DHELS (HES, MAXLP1, LL, Q, R) DO 220 K = 1,NEQ Z(K) = 0.0D0 220 CONTINUE DO 230 I = 1,LL CALL DAXPY (NEQ, R(I), V(1,I), 1, Z, 1) 230 CONTINUE DO 240 I = 1,NEQ Z(I) = Z(I)/WGHT(I) 240 CONTINUE C Load RHO into RHOK. RHOK = RHO RETURN C----------------------------------------------------------------------- C This block handles error returns forced by routine PSOL. C----------------------------------------------------------------------- 300 CONTINUE IF (IER .LT. 0) IFLAG = -1 IF (IER .GT. 0) IFLAG = 3 C RETURN C C------END OF SUBROUTINE DSPIGM----------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DORTH (VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) C C***BEGIN PROLOGUE DORTH C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C This routine orthogonalizes the vector VNEW against the previous C KMP vectors in the V array. It uses a modified Gram-Schmidt C orthogonalization procedure with conditional reorthogonalization. C C On entry C C VNEW = The vector of length N containing a scaled product C OF The Jacobian and the vector V(*,LL). C C V = The N x LL array containing the previous LL C orthogonal vectors V(*,1) to V(*,LL). C C HES = An LL x LL upper Hessenberg matrix containing, C in HES(I,K), K.LT.LL, scaled inner products of C A*V(*,K) and V(*,I). C C LDHES = The leading dimension of the HES array. C C N = The order of the matrix A, and the length of VNEW. C C LL = The current order of the matrix HES. C C KMP = The number of previous vectors the new vector VNEW C must be made orthogonal to (KMP .LE. MAXL). C C C On return C C VNEW = The new vector orthogonal to V(*,I0), C where I0 = MAX(1, LL-KMP+1). C C HES = Upper Hessenberg matrix with column LL filled in with C scaled inner products of A*V(*,LL) and V(*,I). C C SNORMW = L-2 norm of VNEW. C C----------------------------------------------------------------------- C***ROUTINES CALLED C DDOT, DNRM2, DAXPY C C***END PROLOGUE DORTH C INTEGER N, LL, LDHES, KMP DOUBLE PRECISION VNEW, V, HES, SNORMW DIMENSION VNEW(*), V(N,*), HES(LDHES,*) INTEGER I, I0 DOUBLE PRECISION ARG, DDOT, DNRM2, SUMDSQ, TEM, VNRM C C----------------------------------------------------------------------- C Get norm of unaltered VNEW for later use. C----------------------------------------------------------------------- VNRM = DNRM2 (N, VNEW, 1) C----------------------------------------------------------------------- C Do Modified Gram-Schmidt on VNEW = A*V(LL). C Scaled inner products give new column of HES. C Projections of earlier vectors are subtracted from VNEW. C----------------------------------------------------------------------- I0 = MAX0(1,LL-KMP+1) DO 10 I = I0,LL HES(I,LL) = DDOT (N, V(1,I), 1, VNEW, 1) TEM = -HES(I,LL) CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) 10 CONTINUE C----------------------------------------------------------------------- C Compute SNORMW = norm of VNEW. C If VNEW is small compared to its input value (in norm), then C Reorthogonalize VNEW to V(*,1) through V(*,LL). C Correct if relative correction exceeds 1000*(unit roundoff). C Finally, correct SNORMW using the dot products involved. C----------------------------------------------------------------------- SNORMW = DNRM2 (N, VNEW, 1) IF (VNRM + 0.001D0*SNORMW .NE. VNRM) RETURN SUMDSQ = 0.0D0 DO 30 I = I0,LL TEM = -DDOT (N, V(1,I), 1, VNEW, 1) IF (HES(I,LL) + 0.001D0*TEM .EQ. HES(I,LL)) GO TO 30 HES(I,LL) = HES(I,LL) - TEM CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) SUMDSQ = SUMDSQ + TEM**2 30 CONTINUE IF (SUMDSQ .EQ. 0.0D0) RETURN ARG = MAX(0.0D0,SNORMW**2 - SUMDSQ) SNORMW = SQRT(ARG) RETURN C C------END OF SUBROUTINE DORTH------------------------------------------ END C----------------------------------------------------------------------- C Karline: C rescaling of error term according to the index of each variable C index 2 variables are scaled with 1/H C index 3 variables are scaled with 1/H^2 C----------------------------------------------------------------------- SUBROUTINE SCALE(NEQ, NIND, SCAL, H) INTEGER NEQ, NIND(3) , I DOUBLE PRECISION SCAL(*), H IF(NIND(2).NE.0) THEN DO I=NIND(1)+1,NIND(1)+NIND(2) SCAL(I)=SCAL(I)/min(1.D0,H) END DO ENDIF IF(NIND(3).NE.0) THEN DO I=NIND(1)+NIND(2)+1,NIND(1)+NIND(2)+NIND(3) SCAL(I)=SCAL(I)/min(1.D0, H*H) END DO ENDIF RETURN END SUBROUTINE DATVPK(NEQ, Y, TN, YPRIME, SAVR, V, WGHT, YPTEM, RES, * IRES, PSOL, Z, VTEM, WP, IWP, CJ, EPLIN, IER, NRE, NPSL, * RPAR,IPAR) C C***BEGIN PROLOGUE DATV C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) CKS 30-06-2019: name changed to DATVPK C C----------------------------------------------------------------------- C***DESCRIPTION C C This routine computes the product C C Z = (D-inverse)*(P-inverse)*(dF/dY)*(D*V), C C where F(Y) = G(T, Y, CJ*(Y-A)), CJ is a scalar proportional to 1/H, C and A involves the past history of Y. The quantity CJ*(Y-A) is C an approximation to the first derivative of Y and is stored C in the array YPRIME. Note that dF/dY = dG/dY + CJ*dG/dYPRIME. C C D is a diagonal scaling matrix, and P is the left preconditioning C matrix. V is assumed to have L2 norm equal to 1. C The product is stored in Z and is computed by means of a C difference quotient, a call to RES, and one call to PSOL. C C On entry C C NEQ = Problem size, passed to RES and PSOL. C C Y = Array containing current dependent variable vector. C C YPRIME = Array containing current first derivative of y. C C SAVR = Array containing current value of G(T,Y,YPRIME). C C V = Real array of length NEQ (can be the same array as Z). C C WGHT = Array of length NEQ containing scale factors. C 1/WGHT(I) are the diagonal elements of the matrix D. C C YPTEM = Work array of length NEQ. C C VTEM = Work array of length NEQ used to store the C unscaled version of V. C C WP = Real work array used by preconditioner PSOL. C C IWP = Integer work array used by preconditioner PSOL. C C CJ = Scalar proportional to current value of C 1/(step size H). C C C On return C C Z = Array of length NEQ containing desired scaled C matrix-vector product. C C IRES = Error flag from RES. C C IER = Error flag from PSOL. C C NRE = The number of calls to RES. C C NPSL = The number of calls to PSOL. C C----------------------------------------------------------------------- C***ROUTINES CALLED C RES, PSOL C C***END PROLOGUE DATVPK C INTEGER NEQ, IRES, IWP, IER, NRE, NPSL, IPAR DOUBLE PRECISION Y, TN, YPRIME, SAVR, V, WGHT, YPTEM, Z, VTEM, 1 WP, CJ, RPAR DIMENSION Y(*), YPRIME(*), SAVR(*), V(*), WGHT(*), YPTEM(*), 1 Z(*), VTEM(*), WP(*), IWP(*), RPAR(*), IPAR(*) INTEGER I DOUBLE PRECISION EPLIN EXTERNAL RES, PSOL C IRES = 0 C----------------------------------------------------------------------- C Set VTEM = D * V. C----------------------------------------------------------------------- DO 10 I = 1,NEQ VTEM(I) = V(I)/WGHT(I) 10 CONTINUE IER = 0 C----------------------------------------------------------------------- C Store Y in Z and increment Z by VTEM. C Store YPRIME in YPTEM and increment YPTEM by VTEM*CJ. C----------------------------------------------------------------------- DO 20 I = 1,NEQ YPTEM(I) = YPRIME(I) + VTEM(I)*CJ Z(I) = Y(I) + VTEM(I) 20 CONTINUE C----------------------------------------------------------------------- C Call RES with incremented Y, YPRIME arguments C stored in Z, YPTEM. VTEM is overwritten with new residual. C----------------------------------------------------------------------- CONTINUE CALL RES(TN,Z,YPTEM,CJ,VTEM,IRES,RPAR,IPAR) NRE = NRE + 1 IF (IRES .LT. 0) RETURN C----------------------------------------------------------------------- C Set Z = (dF/dY) * VBAR using difference quotient. C (VBAR is old value of VTEM before calling RES) C----------------------------------------------------------------------- DO 70 I = 1,NEQ Z(I) = VTEM(I) - SAVR(I) 70 CONTINUE C----------------------------------------------------------------------- C Apply inverse of left preconditioner to Z. C----------------------------------------------------------------------- CALL PSOL (NEQ, TN, Y, YPRIME, SAVR, YPTEM, CJ, WGHT, WP, IWP, 1 Z, EPLIN, IER, RPAR, IPAR) NPSL = NPSL + 1 IF (IER .NE. 0) RETURN C----------------------------------------------------------------------- C Apply D-inverse to Z and return. C----------------------------------------------------------------------- DO 90 I = 1,NEQ Z(I) = Z(I)*WGHT(I) 90 CONTINUE RETURN C C------END OF SUBROUTINE DATVPK------------------------------------------- END deSolve/src/errmsg.f0000644000176000001440000000524713572134421014152 0ustar ripleyusersC The code in this file is was taken from C https://www.netlib.org/odepack/ C Original author: Hindmarsh, Alan C. (LLNL) C Rewritten to be used with R by Karline Soetaert. C subroutine rprintd1(msg, d1) character (len=*) msg double precision d1 call dblepr(msg, -1, d1, 1) end subroutine subroutine rprintd2(msg, d1, d2) character (len=*) msg double precision DBL(2), d1, d2 DBL(1) = d1 DBL(2) = d2 call dblepr(msg, -1, DBL, 2) end subroutine subroutine rprinti1(msg, i1) character (len=*) msg integer i1 call intpr(msg, -1, i1, 1) end subroutine *DECK XERRWD SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2) C***PURPOSE Write error message with values. C***original AUTHOR Hindmarsh, Alan C., (LLNL) C Rewritten to be used with R by Karline Soetaert C C All arguments are input arguments. C C MSG = The message (character array). C NMES = The length of MSG (number of characters). C NERR = The error number (not used). C LEVEL = The error level.. C 0 or 1 means recoverable (control returns to caller). C 2 means fatal (run is aborted--see note below). C NI = Number of integers (0, 1, or 2) to be printed with message. C I1,I2 = Integers to be printed, depending on NI. C NR = Number of reals (0, 1, or 2) to be printed with message. C R1,R2 = Reals to be printed, depending on NR. C C----------------------------------------------------------------------- C C Declare arguments. C DOUBLE PRECISION R1, R2, RVEC(2), Dummy INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR, Ivec(2) CHARACTER(LEN=*) MSG dummy = 0.d0 MSG = MSG(1:NMES) // char(0) call rprintf(MSG) IF (NI .EQ. 1) THEN MSG = 'In above message, I1 = %d' // char(0) call rprintfi1(MSG, I1) MSG = ' ' // char(0) call rprintf(MSG) ENDIF IF (NI .EQ. 2) THEN IVEC(1) = I1 IVEC(2) = I2 MSG = 'In above message, I1 = %d, I2 = %d' // char(0) call rprintfi2(MSG, I1, I2) MSG = ' ' // char(0) call rprintf(MSG) ENDIF IF (NR .EQ. 1) THEN MSG = 'In above message, R1 = %g' // char(0) call rprintfd1(MSG, R1) MSG = ' ' // char(0) call rprintf(MSG) ENDIF IF (NR .EQ. 2) THEN RVEC(1) = R1 RVEC(2) = R2 MSG = 'In above message, R1 = %g, R2 = %g' // char(0) call rprintfd2(MSG, R1, R2) MSG = ' ' // char(0) call rprintf(MSG) ENDIF C Abort the run if LEVEL = 2. if (LEVEL .eq. 2) call rexit ("fatal error") RETURN END deSolve/src/radau5a.f0000644000176000001440000030120113564604154014170 0ustar ripleyusersC Original author: Ernst Hairer, see copyright statement in radau5.f C Adapted for use in R package deSolve by the deSolve authors. C c----------------------------------------------------------------------- c additional linear algebra routines required by RADAU5 c----------------------------------------------------------------------- c KS: changed sol -> solradau , ... C KS: write statements rewritten C ****************************************** C VERSION OF SEPTEMBER 18, 1995 C ****************************************** C SUBROUTINE DECOMR(N,FJAC,LDJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,FAC1,E1,LDE1,IP1,IER,IJOB,CALHES,IPHES) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1),E1(LDE1,NM1), & IP1(NM1),IPHES(N) LOGICAL CALHES COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG C IF (IJOB .EQ. 1) THEN GOTO 1 ELSE IF (IJOB .EQ. 2) THEN GOTO 2 ELSE IF (IJOB .EQ. 3) THEN GOTO 3 ELSE IF (IJOB .EQ. 4) THEN GOTO 4 ELSE IF (IJOB .EQ. 5) THEN GOTO 5 ELSE IF (IJOB .EQ. 6) THEN GOTO 6 ELSE IF (IJOB .EQ. 7) THEN GOTO 7 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ. 11) THEN GOTO 11 ELSE IF (IJOB .EQ. 12) THEN GOTO 12 ELSE IF (IJOB .EQ. 13) THEN GOTO 13 ELSE IF (IJOB .EQ. 14) THEN GOTO 14 ELSE IF (IJOB .EQ. 15) THEN GOTO 15 ENDIF C karline: changed from C GOTO (1,2,3,4,5,6,7,55,55,55,11,12,13,14,15), IJOB C C ----------------------------------------------------------- C 1 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX DO J=1,N DO I=1,N E1(I,J)=-FJAC(I,J) END DO E1(J,J)=E1(J,J)+FAC1 END DO CALL DECradau(N,LDE1,E1,IP1,IER) RETURN C C ----------------------------------------------------------- C 11 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,NM1 E1(I,J)=-FJAC(I,JM1) END DO E1(J,J)=E1(J,J)+FAC1 END DO 45 MM=M1/M2 DO J=1,M2 DO I=1,NM1 SUM=0.D0 DO K=0,MM-1 SUM=(SUM+FJAC(I,J+K*M2))/FAC1 END DO E1(I,J)=E1(I,J)-SUM END DO END DO CALL DECradau (NM1,LDE1,E1,IP1,IER) RETURN C C ----------------------------------------------------------- C 2 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX DO J=1,N DO I=1,MBJAC E1(I+MLE,J)=-FJAC(I,J) END DO E1(MDIAG,J)=E1(MDIAG,J)+FAC1 END DO CALL DECradB (N,LDE1,E1,MLE,MUE,IP1,IER) RETURN C C ----------------------------------------------------------- C 12 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,MBJAC E1(I+MLE,J)=-FJAC(I,JM1) END DO E1(MDIAG,J)=E1(MDIAG,J)+FAC1 END DO 46 MM=M1/M2 DO J=1,M2 DO I=1,MBJAC SUM=0.D0 DO K=0,MM-1 SUM=(SUM+FJAC(I,J+K*M2))/FAC1 END DO E1(I+MLE,J)=E1(I+MLE,J)-SUM END DO END DO CALL DECradB (NM1,LDE1,E1,MLE,MUE,IP1,IER) RETURN C C ----------------------------------------------------------- C 3 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX DO J=1,N DO I=1,N E1(I,J)=-FJAC(I,J) END DO DO I=MAX(1,J-MUMAS),MIN(N,J+MLMAS) E1(I,J)=E1(I,J)+FAC1*FMAS(I-J+MBDIAG,J) END DO END DO CALL DECradau (N,LDE1,E1,IP1,IER) RETURN C C ----------------------------------------------------------- C 13 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,NM1 E1(I,J)=-FJAC(I,JM1) END DO DO I=MAX(1,J-MUMAS),MIN(NM1,J+MLMAS) E1(I,J)=E1(I,J)+FAC1*FMAS(I-J+MBDIAG,J) END DO END DO GOTO 45 C C ----------------------------------------------------------- C 4 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX DO J=1,N DO I=1,MBJAC E1(I+MLE,J)=-FJAC(I,J) END DO DO I=1,MBB IB=I+MDIFF E1(IB,J)=E1(IB,J)+FAC1*FMAS(I,J) END DO END DO CALL DECradB (N,LDE1,E1,MLE,MUE,IP1,IER) RETURN C C ----------------------------------------------------------- C 14 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,MBJAC E1(I+MLE,J)=-FJAC(I,JM1) END DO DO I=1,MBB IB=I+MDIFF E1(IB,J)=E1(IB,J)+FAC1*FMAS(I,J) END DO END DO GOTO 46 C C ----------------------------------------------------------- C 5 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX DO J=1,N DO I=1,N E1(I,J)=FMAS(I,J)*FAC1-FJAC(I,J) END DO END DO CALL DECradau (N,LDE1,E1,IP1,IER) RETURN C C ----------------------------------------------------------- C 15 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,NM1 E1(I,J)=FMAS(I,J)*FAC1-FJAC(I,JM1) END DO END DO GOTO 45 C C ----------------------------------------------------------- C 6 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX C --- THIS OPTION IS NOT PROVIDED RETURN C C ----------------------------------------------------------- C 7 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION IF (CALHES) CALL ELMHES (LDJAC,N,1,N,FJAC,IPHES) CALHES=.FALSE. DO J=1,N-1 J1=J+1 E1(J1,J)=-FJAC(J1,J) END DO DO J=1,N DO I=1,J E1(I,J)=-FJAC(I,J) END DO E1(J,J)=E1(J,J)+FAC1 END DO CALL DECH(N,LDE1,E1,1,IP1,IER) RETURN C C ----------------------------------------------------------- C 55 CONTINUE RETURN END C C END OF SUBROUTINE DECOMR C C *********************************************************** C SUBROUTINE DECOMC(N,FJAC,LDJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,ALPHN,BETAN,E2R,E2I,LDE1,IP2,IER,IJOB) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1), & E2R(LDE1,NM1),E2I(LDE1,NM1),IP2(NM1) COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG C IF (IJOB .EQ. 1) THEN GOTO 1 ELSE IF (IJOB .EQ. 2) THEN GOTO 2 ELSE IF (IJOB .EQ. 3) THEN GOTO 3 ELSE IF (IJOB .EQ. 4) THEN GOTO 4 ELSE IF (IJOB .EQ. 5) THEN GOTO 5 ELSE IF (IJOB .EQ. 6) THEN GOTO 6 ELSE IF (IJOB .EQ. 7) THEN GOTO 7 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ. 11) THEN GOTO 11 ELSE IF (IJOB .EQ. 12) THEN GOTO 12 ELSE IF (IJOB .EQ. 13) THEN GOTO 13 ELSE IF (IJOB .EQ. 14) THEN GOTO 14 ELSE IF (IJOB .EQ. 15) THEN GOTO 15 ENDIF C karline: changed from C GOTO (1,2,3,4,5,6,7,55,55,55,11,12,13,14,15), IJOB C C ----------------------------------------------------------- C 1 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX DO J=1,N DO I=1,N E2R(I,J)=-FJAC(I,J) E2I(I,J)=0.D0 END DO E2R(J,J)=E2R(J,J)+ALPHN E2I(J,J)=BETAN END DO CALL DECC (N,LDE1,E2R,E2I,IP2,IER) RETURN C C ----------------------------------------------------------- C 11 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,NM1 E2R(I,J)=-FJAC(I,JM1) E2I(I,J)=0.D0 END DO E2R(J,J)=E2R(J,J)+ALPHN E2I(J,J)=BETAN END DO 45 MM=M1/M2 ABNO=ALPHN**2+BETAN**2 ALP=ALPHN/ABNO BET=BETAN/ABNO DO J=1,M2 DO I=1,NM1 SUMR=0.D0 SUMI=0.D0 DO K=0,MM-1 SUMS=SUMR+FJAC(I,J+K*M2) SUMR=SUMS*ALP+SUMI*BET SUMI=SUMI*ALP-SUMS*BET END DO E2R(I,J)=E2R(I,J)-SUMR E2I(I,J)=E2I(I,J)-SUMI END DO END DO CALL DECC (NM1,LDE1,E2R,E2I,IP2,IER) RETURN C C ----------------------------------------------------------- C 2 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX DO J=1,N DO I=1,MBJAC IMLE=I+MLE E2R(IMLE,J)=-FJAC(I,J) E2I(IMLE,J)=0.D0 END DO E2R(MDIAG,J)=E2R(MDIAG,J)+ALPHN E2I(MDIAG,J)=BETAN END DO CALL DECBC (N,LDE1,E2R,E2I,MLE,MUE,IP2,IER) RETURN C C ----------------------------------------------------------- C 12 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,MBJAC E2R(I+MLE,J)=-FJAC(I,JM1) E2I(I+MLE,J)=0.D0 END DO E2R(MDIAG,J)=E2R(MDIAG,J)+ALPHN E2I(MDIAG,J)=E2I(MDIAG,J)+BETAN END DO 46 MM=M1/M2 ABNO=ALPHN**2+BETAN**2 ALP=ALPHN/ABNO BET=BETAN/ABNO DO J=1,M2 DO I=1,MBJAC SUMR=0.D0 SUMI=0.D0 DO K=0,MM-1 SUMS=SUMR+FJAC(I,J+K*M2) SUMR=SUMS*ALP+SUMI*BET SUMI=SUMI*ALP-SUMS*BET END DO IMLE=I+MLE E2R(IMLE,J)=E2R(IMLE,J)-SUMR E2I(IMLE,J)=E2I(IMLE,J)-SUMI END DO END DO CALL DECBC (NM1,LDE1,E2R,E2I,MLE,MUE,IP2,IER) RETURN C C ----------------------------------------------------------- C 3 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX DO J=1,N DO I=1,N E2R(I,J)=-FJAC(I,J) E2I(I,J)=0.D0 END DO END DO DO J=1,N DO I=MAX(1,J-MUMAS),MIN(N,J+MLMAS) BB=FMAS(I-J+MBDIAG,J) E2R(I,J)=E2R(I,J)+ALPHN*BB E2I(I,J)=BETAN*BB END DO END DO CALL DECC(N,LDE1,E2R,E2I,IP2,IER) RETURN C C ----------------------------------------------------------- C 13 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,NM1 E2R(I,J)=-FJAC(I,JM1) E2I(I,J)=0.D0 END DO DO I=MAX(1,J-MUMAS),MIN(NM1,J+MLMAS) FFMA=FMAS(I-J+MBDIAG,J) E2R(I,J)=E2R(I,J)+ALPHN*FFMA E2I(I,J)=E2I(I,J)+BETAN*FFMA END DO END DO GOTO 45 C C ----------------------------------------------------------- C 4 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX DO J=1,N DO I=1,MBJAC IMLE=I+MLE E2R(IMLE,J)=-FJAC(I,J) E2I(IMLE,J)=0.D0 END DO DO I=MAX(1,MUMAS+2-J),MIN(MBB,MUMAS+1-J+N) IB=I+MDIFF BB=FMAS(I,J) E2R(IB,J)=E2R(IB,J)+ALPHN*BB E2I(IB,J)=BETAN*BB END DO END DO CALL DECBC (N,LDE1,E2R,E2I,MLE,MUE,IP2,IER) RETURN C C ----------------------------------------------------------- C 14 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,MBJAC E2R(I+MLE,J)=-FJAC(I,JM1) E2I(I+MLE,J)=0.D0 END DO DO I=1,MBB IB=I+MDIFF FFMA=FMAS(I,J) E2R(IB,J)=E2R(IB,J)+ALPHN*FFMA E2I(IB,J)=E2I(IB,J)+BETAN*FFMA END DO END DO GOTO 46 C C ----------------------------------------------------------- C 5 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX DO J=1,N DO I=1,N BB=FMAS(I,J) E2R(I,J)=BB*ALPHN-FJAC(I,J) E2I(I,J)=BB*BETAN END DO END DO CALL DECC(N,LDE1,E2R,E2I,IP2,IER) RETURN C C ----------------------------------------------------------- C 15 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,NM1 E2R(I,J)=ALPHN*FMAS(I,J)-FJAC(I,JM1) E2I(I,J)=BETAN*FMAS(I,J) END DO END DO GOTO 45 C C ----------------------------------------------------------- C 6 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX C --- THIS OPTION IS NOT PROVIDED RETURN C C ----------------------------------------------------------- C 7 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION DO J=1,N-1 J1=J+1 E2R(J1,J)=-FJAC(J1,J) E2I(J1,J)=0.D0 END DO DO J=1,N DO I=1,J E2I(I,J)=0.D0 E2R(I,J)=-FJAC(I,J) END DO E2R(J,J)=E2R(J,J)+ALPHN E2I(J,J)=BETAN END DO CALL DECHC(N,LDE1,E2R,E2I,1,IP2,IER) RETURN C C ----------------------------------------------------------- C 55 CONTINUE RETURN END C C END OF SUBROUTINE DECOMC C C *********************************************************** C SUBROUTINE SLVRAR(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,FAC1,E1,LDE1,Z1,F1,IP1,IPHES,IER,IJOB) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1),E1(LDE1,NM1), & IP1(NM1),IPHES(N),Z1(N),F1(N) COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG C IF (IJOB .EQ. 1) THEN GOTO 1 ELSE IF (IJOB .EQ. 2) THEN GOTO 2 ELSE IF (IJOB .EQ. 3) THEN GOTO 3 ELSE IF (IJOB .EQ. 4) THEN GOTO 4 ELSE IF (IJOB .EQ. 5) THEN GOTO 5 ELSE IF (IJOB .EQ. 6) THEN GOTO 6 ELSE IF (IJOB .EQ. 7) THEN GOTO 7 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ. 11) THEN GOTO 11 ELSE IF (IJOB .EQ. 12) THEN GOTO 12 ELSE IF (IJOB .EQ. 13 .OR. IJOB .EQ. 14) THEN GOTO 13 ELSE IF (IJOB .EQ. 15) THEN GOTO 15 ENDIF C karline: changed from C GOTO (1,2,3,4,5,6,7,55,55,55,11,12,13,13,15), IJOB C C ----------------------------------------------------------- C 1 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX DO I=1,N Z1(I)=Z1(I)-F1(I)*FAC1 END DO CALL solradau (N,LDE1,E1,Z1,IP1) RETURN C C ----------------------------------------------------------- C 11 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,N Z1(I)=Z1(I)-F1(I)*FAC1 END DO 48 CONTINUE MM=M1/M2 DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUM1=(Z1(JKM)+SUM1)/FAC1 DO I=1,NM1 IM1=I+M1 Z1(IM1)=Z1(IM1)+FJAC(I,JKM)*SUM1 END DO END DO END DO CALL solradau (NM1,LDE1,E1,Z1(M1+1),IP1) 49 CONTINUE DO I=M1,1,-1 Z1(I)=(Z1(I)+Z1(M2+I))/FAC1 END DO RETURN C C ----------------------------------------------------------- C 2 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX DO I=1,N Z1(I)=Z1(I)-F1(I)*FAC1 END DO CALL SOLradB (N,LDE1,E1,MLE,MUE,Z1,IP1) RETURN C C ----------------------------------------------------------- C 12 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER DO I=1,N Z1(I)=Z1(I)-F1(I)*FAC1 END DO 45 CONTINUE MM=M1/M2 DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUM1=(Z1(JKM)+SUM1)/FAC1 DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 Z1(IM1)=Z1(IM1)+FJAC(I+MUJAC+1-J,JKM)*SUM1 END DO END DO END DO CALL SOLradB (NM1,LDE1,E1,MLE,MUE,Z1(M1+1),IP1) GOTO 49 C C ----------------------------------------------------------- C 3 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX DO I=1,N S1=0.0D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) S1=S1-FMAS(I-J+MBDIAG,J)*F1(J) END DO Z1(I)=Z1(I)+S1*FAC1 END DO CALL solradau (N,LDE1,E1,Z1,IP1) RETURN C C ----------------------------------------------------------- C 13 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 Z1(I)=Z1(I)-F1(I)*FAC1 END DO DO I=1,NM1 IM1=I+M1 S1=0.0D0 DO J=MAX(1,I-MLMAS),MIN(NM1,I+MUMAS) S1=S1-FMAS(I-J+MBDIAG,J)*F1(J+M1) END DO Z1(IM1)=Z1(IM1)+S1*FAC1 END DO IF (IJOB.EQ.14) GOTO 45 GOTO 48 C C ----------------------------------------------------------- C 4 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX DO I=1,N S1=0.0D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) S1=S1-FMAS(I-J+MBDIAG,J)*F1(J) END DO Z1(I)=Z1(I)+S1*FAC1 END DO CALL SOLradB (N,LDE1,E1,MLE,MUE,Z1,IP1) RETURN C C ----------------------------------------------------------- C 5 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX DO I=1,N S1=0.0D0 DO J=1,N S1=S1-FMAS(I,J)*F1(J) END DO Z1(I)=Z1(I)+S1*FAC1 END DO CALL solradau (N,LDE1,E1,Z1,IP1) RETURN C C ----------------------------------------------------------- C 15 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 Z1(I)=Z1(I)-F1(I)*FAC1 END DO DO I=1,NM1 IM1=I+M1 S1=0.0D0 DO J=1,NM1 S1=S1-FMAS(I,J)*F1(J+M1) END DO Z1(IM1)=Z1(IM1)+S1*FAC1 END DO GOTO 48 C C ----------------------------------------------------------- C 6 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX C --- THIS OPTION IS NOT PROVIDED RETURN C C ----------------------------------------------------------- C 7 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION DO I=1,N Z1(I)=Z1(I)-F1(I)*FAC1 END DO DO MM=N-2,1,-1 MP=N-MM MP1=MP-1 I=IPHES(MP) IF (I.EQ.MP) GOTO 746 ZSAFE=Z1(MP) Z1(MP)=Z1(I) Z1(I)=ZSAFE 746 CONTINUE DO I=MP+1,N Z1(I)=Z1(I)-FJAC(I,MP1)*Z1(MP) END DO END DO CALL SOLH(N,LDE1,E1,1,Z1,IP1) DO MM=1,N-2 MP=N-MM MP1=MP-1 DO I=MP+1,N Z1(I)=Z1(I)+FJAC(I,MP1)*Z1(MP) END DO I=IPHES(MP) IF (I.EQ.MP) GOTO 750 ZSAFE=Z1(MP) Z1(MP)=Z1(I) Z1(I)=ZSAFE 750 CONTINUE END DO RETURN C C ----------------------------------------------------------- C 55 CONTINUE RETURN END C C END OF SUBROUTINE SLVRAR C C *********************************************************** C SUBROUTINE SLVRAI(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,ALPHN,BETAN,E2R,E2I,LDE1,Z2,Z3, & F2,F3,CONT,IP2,IPHES,IER,IJOB) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1), & IP2(NM1),IPHES(N),Z2(N),Z3(N),F2(N),F3(N) DIMENSION E2R(LDE1,NM1),E2I(LDE1,NM1) COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG IF (IJOB .EQ. 1) THEN GOTO 1 ELSE IF (IJOB .EQ. 2) THEN GOTO 2 ELSE IF (IJOB .EQ. 3) THEN GOTO 3 ELSE IF (IJOB .EQ. 4) THEN GOTO 4 ELSE IF (IJOB .EQ. 5) THEN GOTO 5 ELSE IF (IJOB .EQ. 6) THEN GOTO 6 ELSE IF (IJOB .EQ. 7) THEN GOTO 7 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ. 11) THEN GOTO 11 ELSE IF (IJOB .EQ. 12) THEN GOTO 12 ELSE IF (IJOB .EQ. 13) THEN GOTO 13 ELSE IF (IJOB .EQ. 14) THEN GOTO 13 ELSE IF (IJOB .EQ. 15) THEN GOTO 15 ENDIF C karline: changed from C GOTO (1,2,3,4,5,6,7,55,55,55,11,12,13,13,15), IJOB C C ----------------------------------------------------------- C 1 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX DO I=1,N S2=-F2(I) S3=-F3(I) Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL SOLC (N,LDE1,E2R,E2I,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 11 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,N S2=-F2(I) S3=-F3(I) Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO 48 ABNO=ALPHN**2+BETAN**2 MM=M1/M2 DO J=1,M2 SUM2=0.D0 SUM3=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUMH=(Z2(JKM)+SUM2)/ABNO SUM3=(Z3(JKM)+SUM3)/ABNO SUM2=SUMH*ALPHN+SUM3*BETAN SUM3=SUM3*ALPHN-SUMH*BETAN DO I=1,NM1 IM1=I+M1 Z2(IM1)=Z2(IM1)+FJAC(I,JKM)*SUM2 Z3(IM1)=Z3(IM1)+FJAC(I,JKM)*SUM3 END DO END DO END DO CALL SOLC (NM1,LDE1,E2R,E2I,Z2(M1+1),Z3(M1+1),IP2) 49 CONTINUE DO I=M1,1,-1 MPI=M2+I Z2I=Z2(I)+Z2(MPI) Z3I=Z3(I)+Z3(MPI) Z3(I)=(Z3I*ALPHN-Z2I*BETAN)/ABNO Z2(I)=(Z2I*ALPHN+Z3I*BETAN)/ABNO END DO RETURN C C ----------------------------------------------------------- C 2 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX DO I=1,N S2=-F2(I) S3=-F3(I) Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL SOLBC (N,LDE1,E2R,E2I,MLE,MUE,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 12 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER DO I=1,N S2=-F2(I) S3=-F3(I) Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO 45 ABNO=ALPHN**2+BETAN**2 MM=M1/M2 DO J=1,M2 SUM2=0.D0 SUM3=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUMH=(Z2(JKM)+SUM2)/ABNO SUM3=(Z3(JKM)+SUM3)/ABNO SUM2=SUMH*ALPHN+SUM3*BETAN SUM3=SUM3*ALPHN-SUMH*BETAN DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 IIMU=I+MUJAC+1-J Z2(IM1)=Z2(IM1)+FJAC(IIMU,JKM)*SUM2 Z3(IM1)=Z3(IM1)+FJAC(IIMU,JKM)*SUM3 END DO END DO END DO CALL SOLBC (NM1,LDE1,E2R,E2I,MLE,MUE,Z2(M1+1),Z3(M1+1),IP2) GOTO 49 C C ----------------------------------------------------------- C 3 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX DO I=1,N S2=0.0D0 S3=0.0D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) BB=FMAS(I-J+MBDIAG,J) S2=S2-BB*F2(J) S3=S3-BB*F3(J) END DO Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL SOLC(N,LDE1,E2R,E2I,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 13 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 S2=-F2(I) S3=-F3(I) Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO DO I=1,NM1 IM1=I+M1 S2=0.0D0 S3=0.0D0 DO J=MAX(1,I-MLMAS),MIN(NM1,I+MUMAS) JM1=J+M1 BB=FMAS(I-J+MBDIAG,J) S2=S2-BB*F2(JM1) S3=S3-BB*F3(JM1) END DO Z2(IM1)=Z2(IM1)+S2*ALPHN-S3*BETAN Z3(IM1)=Z3(IM1)+S3*ALPHN+S2*BETAN END DO IF (IJOB.EQ.14) GOTO 45 GOTO 48 C C ----------------------------------------------------------- C 4 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX DO I=1,N S2=0.0D0 S3=0.0D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) BB=FMAS(I-J+MBDIAG,J) S2=S2-BB*F2(J) S3=S3-BB*F3(J) END DO Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL SOLBC(N,LDE1,E2R,E2I,MLE,MUE,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 5 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX DO I=1,N S2=0.0D0 S3=0.0D0 DO J=1,N BB=FMAS(I,J) S2=S2-BB*F2(J) S3=S3-BB*F3(J) END DO Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL SOLC(N,LDE1,E2R,E2I,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 15 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 S2=-F2(I) S3=-F3(I) Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO DO I=1,NM1 IM1=I+M1 S2=0.0D0 S3=0.0D0 DO J=1,NM1 JM1=J+M1 BB=FMAS(I,J) S2=S2-BB*F2(JM1) S3=S3-BB*F3(JM1) END DO Z2(IM1)=Z2(IM1)+S2*ALPHN-S3*BETAN Z3(IM1)=Z3(IM1)+S3*ALPHN+S2*BETAN END DO GOTO 48 C C ----------------------------------------------------------- C 6 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX C --- THIS OPTION IS NOT PROVIDED RETURN C C ----------------------------------------------------------- C 7 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION DO I=1,N S2=-F2(I) S3=-F3(I) Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO DO MM=N-2,1,-1 MP=N-MM MP1=MP-1 I=IPHES(MP) IF (I.EQ.MP) GOTO 746 ZSAFE=Z2(MP) Z2(MP)=Z2(I) Z2(I)=ZSAFE ZSAFE=Z3(MP) Z3(MP)=Z3(I) Z3(I)=ZSAFE 746 CONTINUE DO I=MP+1,N E1IMP=FJAC(I,MP1) Z2(I)=Z2(I)-E1IMP*Z2(MP) Z3(I)=Z3(I)-E1IMP*Z3(MP) END DO END DO CALL SOLHC(N,LDE1,E2R,E2I,1,Z2,Z3,IP2) DO MM=1,N-2 MP=N-MM MP1=MP-1 DO I=MP+1,N E1IMP=FJAC(I,MP1) Z2(I)=Z2(I)+E1IMP*Z2(MP) Z3(I)=Z3(I)+E1IMP*Z3(MP) END DO I=IPHES(MP) IF (I.EQ.MP) GOTO 750 ZSAFE=Z2(MP) Z2(MP)=Z2(I) Z2(I)=ZSAFE ZSAFE=Z3(MP) Z3(MP)=Z3(I) Z3(I)=ZSAFE 750 CONTINUE END DO RETURN C C ----------------------------------------------------------- C 55 CONTINUE RETURN END C C END OF SUBROUTINE SLVRAI C C *********************************************************** C SUBROUTINE SLVRAD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,FAC1,ALPHN,BETAN,E1,E2R,E2I,LDE1,Z1,Z2,Z3, & F1,F2,F3,CONT,IP1,IP2,IPHES,IER,IJOB) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1),E1(LDE1,NM1), & E2R(LDE1,NM1),E2I(LDE1,NM1),IP1(NM1),IP2(NM1), & IPHES(N),Z1(N),Z2(N),Z3(N),F1(N),F2(N),F3(N) COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG C IF (IJOB .EQ. 1) THEN GOTO 1 ELSE IF (IJOB .EQ. 2) THEN GOTO 2 ELSE IF (IJOB .EQ. 3) THEN GOTO 3 ELSE IF (IJOB .EQ. 4) THEN GOTO 4 ELSE IF (IJOB .EQ. 5) THEN GOTO 5 ELSE IF (IJOB .EQ. 6) THEN GOTO 6 ELSE IF (IJOB .EQ. 7) THEN GOTO 7 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ. 11) THEN GOTO 11 ELSE IF (IJOB .EQ. 12) THEN GOTO 12 ELSE IF (IJOB .EQ. 13) THEN GOTO 13 ELSE IF (IJOB .EQ. 14) THEN GOTO 13 ELSE IF (IJOB .EQ. 15) THEN GOTO 15 ENDIF C karline: changed from C GOTO (1,2,3,4,5,6,7,55,55,55,11,12,13,13,15), IJOB C C ----------------------------------------------------------- C 1 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX DO I=1,N S2=-F2(I) S3=-F3(I) Z1(I)=Z1(I)-F1(I)*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL solradau (N,LDE1,E1,Z1,IP1) CALL SOLC (N,LDE1,E2R,E2I,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 11 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,N S2=-F2(I) S3=-F3(I) Z1(I)=Z1(I)-F1(I)*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO 48 ABNO=ALPHN**2+BETAN**2 MM=M1/M2 DO J=1,M2 SUM1=0.D0 SUM2=0.D0 SUM3=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUM1=(Z1(JKM)+SUM1)/FAC1 SUMH=(Z2(JKM)+SUM2)/ABNO SUM3=(Z3(JKM)+SUM3)/ABNO SUM2=SUMH*ALPHN+SUM3*BETAN SUM3=SUM3*ALPHN-SUMH*BETAN DO I=1,NM1 IM1=I+M1 Z1(IM1)=Z1(IM1)+FJAC(I,JKM)*SUM1 Z2(IM1)=Z2(IM1)+FJAC(I,JKM)*SUM2 Z3(IM1)=Z3(IM1)+FJAC(I,JKM)*SUM3 END DO END DO END DO CALL solradau (NM1,LDE1,E1,Z1(M1+1),IP1) CALL SOLC (NM1,LDE1,E2R,E2I,Z2(M1+1),Z3(M1+1),IP2) 49 CONTINUE DO I=M1,1,-1 MPI=M2+I Z1(I)=(Z1(I)+Z1(MPI))/FAC1 Z2I=Z2(I)+Z2(MPI) Z3I=Z3(I)+Z3(MPI) Z3(I)=(Z3I*ALPHN-Z2I*BETAN)/ABNO Z2(I)=(Z2I*ALPHN+Z3I*BETAN)/ABNO END DO RETURN C C ----------------------------------------------------------- C 2 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX DO I=1,N S2=-F2(I) S3=-F3(I) Z1(I)=Z1(I)-F1(I)*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL SOLradB (N,LDE1,E1,MLE,MUE,Z1,IP1) CALL SOLBC (N,LDE1,E2R,E2I,MLE,MUE,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 12 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER DO I=1,N S2=-F2(I) S3=-F3(I) Z1(I)=Z1(I)-F1(I)*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO 45 ABNO=ALPHN**2+BETAN**2 MM=M1/M2 DO J=1,M2 SUM1=0.D0 SUM2=0.D0 SUM3=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUM1=(Z1(JKM)+SUM1)/FAC1 SUMH=(Z2(JKM)+SUM2)/ABNO SUM3=(Z3(JKM)+SUM3)/ABNO SUM2=SUMH*ALPHN+SUM3*BETAN SUM3=SUM3*ALPHN-SUMH*BETAN DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 FFJA=FJAC(I+MUJAC+1-J,JKM) Z1(IM1)=Z1(IM1)+FFJA*SUM1 Z2(IM1)=Z2(IM1)+FFJA*SUM2 Z3(IM1)=Z3(IM1)+FFJA*SUM3 END DO END DO END DO CALL SOLradB (NM1,LDE1,E1,MLE,MUE,Z1(M1+1),IP1) CALL SOLBC (NM1,LDE1,E2R,E2I,MLE,MUE,Z2(M1+1),Z3(M1+1),IP2) GOTO 49 C C ----------------------------------------------------------- C 3 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX DO I=1,N S1=0.0D0 S2=0.0D0 S3=0.0D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) BB=FMAS(I-J+MBDIAG,J) S1=S1-BB*F1(J) S2=S2-BB*F2(J) S3=S3-BB*F3(J) END DO Z1(I)=Z1(I)+S1*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL solradau (N,LDE1,E1,Z1,IP1) CALL SOLC(N,LDE1,E2R,E2I,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 13 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 S2=-F2(I) S3=-F3(I) Z1(I)=Z1(I)-F1(I)*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO DO I=1,NM1 IM1=I+M1 S1=0.0D0 S2=0.0D0 S3=0.0D0 J1B=MAX(1,I-MLMAS) J2B=MIN(NM1,I+MUMAS) DO J=J1B,J2B JM1=J+M1 BB=FMAS(I-J+MBDIAG,J) S1=S1-BB*F1(JM1) S2=S2-BB*F2(JM1) S3=S3-BB*F3(JM1) END DO Z1(IM1)=Z1(IM1)+S1*FAC1 Z2(IM1)=Z2(IM1)+S2*ALPHN-S3*BETAN Z3(IM1)=Z3(IM1)+S3*ALPHN+S2*BETAN END DO IF (IJOB.EQ.14) GOTO 45 GOTO 48 C C ----------------------------------------------------------- C 4 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX DO I=1,N S1=0.0D0 S2=0.0D0 S3=0.0D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) BB=FMAS(I-J+MBDIAG,J) S1=S1-BB*F1(J) S2=S2-BB*F2(J) S3=S3-BB*F3(J) END DO Z1(I)=Z1(I)+S1*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL SOLradB (N,LDE1,E1,MLE,MUE,Z1,IP1) CALL SOLBC(N,LDE1,E2R,E2I,MLE,MUE,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 5 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX DO I=1,N S1=0.0D0 S2=0.0D0 S3=0.0D0 DO J=1,N BB=FMAS(I,J) S1=S1-BB*F1(J) S2=S2-BB*F2(J) S3=S3-BB*F3(J) END DO Z1(I)=Z1(I)+S1*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL solradau (N,LDE1,E1,Z1,IP1) CALL SOLC(N,LDE1,E2R,E2I,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 15 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 S2=-F2(I) S3=-F3(I) Z1(I)=Z1(I)-F1(I)*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO DO I=1,NM1 IM1=I+M1 S1=0.0D0 S2=0.0D0 S3=0.0D0 DO J=1,NM1 JM1=J+M1 BB=FMAS(I,J) S1=S1-BB*F1(JM1) S2=S2-BB*F2(JM1) S3=S3-BB*F3(JM1) END DO Z1(IM1)=Z1(IM1)+S1*FAC1 Z2(IM1)=Z2(IM1)+S2*ALPHN-S3*BETAN Z3(IM1)=Z3(IM1)+S3*ALPHN+S2*BETAN END DO GOTO 48 C C ----------------------------------------------------------- C 6 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX C --- THIS OPTION IS NOT PROVIDED RETURN C C ----------------------------------------------------------- C 7 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION DO I=1,N S2=-F2(I) S3=-F3(I) Z1(I)=Z1(I)-F1(I)*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO DO MM=N-2,1,-1 MP=N-MM MP1=MP-1 I=IPHES(MP) IF (I.EQ.MP) GOTO 746 ZSAFE=Z1(MP) Z1(MP)=Z1(I) Z1(I)=ZSAFE ZSAFE=Z2(MP) Z2(MP)=Z2(I) Z2(I)=ZSAFE ZSAFE=Z3(MP) Z3(MP)=Z3(I) Z3(I)=ZSAFE 746 CONTINUE DO I=MP+1,N E1IMP=FJAC(I,MP1) Z1(I)=Z1(I)-E1IMP*Z1(MP) Z2(I)=Z2(I)-E1IMP*Z2(MP) Z3(I)=Z3(I)-E1IMP*Z3(MP) END DO END DO CALL SOLH(N,LDE1,E1,1,Z1,IP1) CALL SOLHC(N,LDE1,E2R,E2I,1,Z2,Z3,IP2) DO MM=1,N-2 MP=N-MM MP1=MP-1 DO I=MP+1,N E1IMP=FJAC(I,MP1) Z1(I)=Z1(I)+E1IMP*Z1(MP) Z2(I)=Z2(I)+E1IMP*Z2(MP) Z3(I)=Z3(I)+E1IMP*Z3(MP) END DO I=IPHES(MP) IF (I.EQ.MP) GOTO 750 ZSAFE=Z1(MP) Z1(MP)=Z1(I) Z1(I)=ZSAFE ZSAFE=Z2(MP) Z2(MP)=Z2(I) Z2(I)=ZSAFE ZSAFE=Z3(MP) Z3(MP)=Z3(I) Z3(I)=ZSAFE 750 CONTINUE END DO RETURN C C ----------------------------------------------------------- C 55 CONTINUE RETURN END C C END OF SUBROUTINE SLVRAD C C *********************************************************** C SUBROUTINE ESTRAD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & H,DD1,DD2,DD3,FCN,NFCN,Y0,Y,IJOB,X,M1,M2,NM1, & E1,LDE1,Z1,Z2,Z3,CONT,F1,F2,IP1,IPHES,SCAL,ERR, & FIRST,REJECT,FAC1,RPAR,IPAR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1),E1(LDE1,NM1),IP1(NM1), & SCAL(N),IPHES(N),Z1(N),Z2(N),Z3(N),F1(N),F2(N),Y0(N),Y(N) DIMENSION CONT(N),RPAR(1),IPAR(1) LOGICAL FIRST,REJECT COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG HEE1=DD1/H HEE2=DD2/H HEE3=DD3/H IF (IJOB .EQ. 1) THEN GOTO 1 ELSE IF (IJOB .EQ. 2) THEN GOTO 2 ELSE IF (IJOB .EQ. 3) THEN GOTO 3 ELSE IF (IJOB .EQ. 4) THEN GOTO 4 ELSE IF (IJOB .EQ. 5) THEN GOTO 5 ELSE IF (IJOB .EQ. 6) THEN GOTO 6 ELSE IF (IJOB .EQ. 7) THEN GOTO 7 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ. 11) THEN GOTO 11 ELSE IF (IJOB .EQ. 12) THEN GOTO 12 ELSE IF (IJOB .EQ. 13) THEN GOTO 13 ELSE IF (IJOB .EQ. 14) THEN GOTO 14 ELSE IF (IJOB .EQ. 15) THEN GOTO 15 ENDIF C karline changed from: C GOTO (1,2,3,4,5,6,7,55,55,55,11,12,13,14,15), IJOB C 1 CONTINUE C ------ B=IDENTITY, JACOBIAN A FULL MATRIX DO I=1,N F2(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) CONT(I)=F2(I)+Y0(I) END DO CALL solradau (N,LDE1,E1,CONT,IP1) GOTO 77 C 11 CONTINUE C ------ B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,N F2(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) CONT(I)=F2(I)+Y0(I) END DO 48 MM=M1/M2 DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 SUM1=(CONT(J+K*M2)+SUM1)/FAC1 DO I=1,NM1 IM1=I+M1 CONT(IM1)=CONT(IM1)+FJAC(I,J+K*M2)*SUM1 END DO END DO END DO CALL solradau (NM1,LDE1,E1,CONT(M1+1),IP1) DO I=M1,1,-1 CONT(I)=(CONT(I)+CONT(M2+I))/FAC1 END DO GOTO 77 C 2 CONTINUE C ------ B=IDENTITY, JACOBIAN A BANDED MATRIX DO I=1,N F2(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) CONT(I)=F2(I)+Y0(I) END DO CALL SOLradB (N,LDE1,E1,MLE,MUE,CONT,IP1) GOTO 77 C 12 CONTINUE C ------ B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER DO I=1,N F2(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) CONT(I)=F2(I)+Y0(I) END DO 45 MM=M1/M2 DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 SUM1=(CONT(J+K*M2)+SUM1)/FAC1 DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 CONT(IM1)=CONT(IM1)+FJAC(I+MUJAC+1-J,J+K*M2)*SUM1 END DO END DO END DO CALL SOLradB (NM1,LDE1,E1,MLE,MUE,CONT(M1+1),IP1) DO I=M1,1,-1 CONT(I)=(CONT(I)+CONT(M2+I))/FAC1 END DO GOTO 77 C 3 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX DO I=1,N F1(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) END DO DO I=1,N SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*F1(J) END DO F2(I)=SUM CONT(I)=SUM+Y0(I) END DO CALL solradau (N,LDE1,E1,CONT,IP1) GOTO 77 C 13 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 F2(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) CONT(I)=F2(I)+Y0(I) END DO DO I=M1+1,N F1(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) END DO DO I=1,NM1 SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(NM1,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*F1(J+M1) END DO IM1=I+M1 F2(IM1)=SUM CONT(IM1)=SUM+Y0(IM1) END DO GOTO 48 C 4 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX DO I=1,N F1(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) END DO DO I=1,N SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*F1(J) END DO F2(I)=SUM CONT(I)=SUM+Y0(I) END DO CALL SOLradB (N,LDE1,E1,MLE,MUE,CONT,IP1) GOTO 77 C 14 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX, SECOND ORDER DO I=1,M1 F2(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) CONT(I)=F2(I)+Y0(I) END DO DO I=M1+1,N F1(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) END DO DO I=1,NM1 SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(NM1,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*F1(J+M1) END DO IM1=I+M1 F2(IM1)=SUM CONT(IM1)=SUM+Y0(IM1) END DO GOTO 45 C 5 CONTINUE C ------ B IS A FULL MATRIX, JACOBIAN A FULL MATRIX DO I=1,N F1(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) END DO DO I=1,N SUM=0.D0 DO J=1,N SUM=SUM+FMAS(I,J)*F1(J) END DO F2(I)=SUM CONT(I)=SUM+Y0(I) END DO CALL solradau (N,LDE1,E1,CONT,IP1) GOTO 77 C 15 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 F2(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) CONT(I)=F2(I)+Y0(I) END DO DO I=M1+1,N F1(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) END DO DO I=1,NM1 SUM=0.D0 DO J=1,NM1 SUM=SUM+FMAS(I,J)*F1(J+M1) END DO IM1=I+M1 F2(IM1)=SUM CONT(IM1)=SUM+Y0(IM1) END DO GOTO 48 C 6 CONTINUE C ------ B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX C ------ THIS OPTION IS NOT PROVIDED RETURN C 7 CONTINUE C ------ B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION DO I=1,N F2(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) CONT(I)=F2(I)+Y0(I) END DO DO MM=N-2,1,-1 MP=N-MM I=IPHES(MP) IF (I.EQ.MP) GOTO 310 ZSAFE=CONT(MP) CONT(MP)=CONT(I) CONT(I)=ZSAFE 310 CONTINUE DO I=MP+1,N CONT(I)=CONT(I)-FJAC(I,MP-1)*CONT(MP) END DO END DO CALL SOLH(N,LDE1,E1,1,CONT,IP1) DO MM=1,N-2 MP=N-MM DO I=MP+1,N CONT(I)=CONT(I)+FJAC(I,MP-1)*CONT(MP) END DO I=IPHES(MP) IF (I.EQ.MP) GOTO 440 ZSAFE=CONT(MP) CONT(MP)=CONT(I) CONT(I)=ZSAFE 440 CONTINUE END DO C C -------------------------------------- C 77 CONTINUE ERR=0.D0 DO I=1,N ERR=ERR+(CONT(I)/SCAL(I))**2 END DO ERR=MAX(SQRT(ERR/N),1.D-10) C IF (ERR.LT.1.D0) RETURN IF (FIRST.OR.REJECT) THEN DO I=1,N CONT(I)=Y(I)+CONT(I) END DO CALL FCN(N,X,CONT,F1,RPAR,IPAR) NFCN=NFCN+1 DO I=1,N CONT(I)=F1(I)+F2(I) END DO IF (IJOB .EQ. 1 .OR. IJOB .EQ. 3 .OR. IJOB .EQ. 5) THEN GOTO 31 ELSE IF (IJOB .EQ. 2 .OR. IJOB .EQ. 4 .OR. IJOB .EQ. 6) THEN GOTO 32 ELSE IF (IJOB .EQ. 7) THEN GOTO 33 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ.11 .OR. IJOB .EQ.13 .OR. IJOB .EQ.15) THEN GOTO 41 ELSE IF (IJOB .EQ. 12 .OR. IJOB .EQ. 14) THEN GOTO 42 END IF C karline: changed from C GOTO (31,32,31,32,31,32,33,55,55,55,41,42,41,42,41), IJOB C ------ FULL MATRIX OPTION 31 CONTINUE CALL solradau(N,LDE1,E1,CONT,IP1) GOTO 88 C ------ FULL MATRIX OPTION, SECOND ORDER 41 CONTINUE DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 SUM1=(CONT(J+K*M2)+SUM1)/FAC1 DO I=1,NM1 IM1=I+M1 CONT(IM1)=CONT(IM1)+FJAC(I,J+K*M2)*SUM1 END DO END DO END DO CALL solradau(NM1,LDE1,E1,CONT(M1+1),IP1) DO I=M1,1,-1 CONT(I)=(CONT(I)+CONT(M2+I))/FAC1 END DO GOTO 88 C ------ BANDED MATRIX OPTION 32 CONTINUE CALL SOLradB (N,LDE1,E1,MLE,MUE,CONT,IP1) GOTO 88 C ------ BANDED MATRIX OPTION, SECOND ORDER 42 CONTINUE DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 SUM1=(CONT(J+K*M2)+SUM1)/FAC1 DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 CONT(IM1)=CONT(IM1)+FJAC(I+MUJAC+1-J,J+K*M2)*SUM1 END DO END DO END DO CALL SOLradB (NM1,LDE1,E1,MLE,MUE,CONT(M1+1),IP1) DO I=M1,1,-1 CONT(I)=(CONT(I)+CONT(M2+I))/FAC1 END DO GOTO 88 C ------ HESSENBERG MATRIX OPTION 33 CONTINUE DO MM=N-2,1,-1 MP=N-MM I=IPHES(MP) IF (I.EQ.MP) GOTO 510 ZSAFE=CONT(MP) CONT(MP)=CONT(I) CONT(I)=ZSAFE 510 CONTINUE DO I=MP+1,N CONT(I)=CONT(I)-FJAC(I,MP-1)*CONT(MP) END DO END DO CALL SOLH(N,LDE1,E1,1,CONT,IP1) DO MM=1,N-2 MP=N-MM DO I=MP+1,N CONT(I)=CONT(I)+FJAC(I,MP-1)*CONT(MP) END DO I=IPHES(MP) IF (I.EQ.MP) GOTO 640 ZSAFE=CONT(MP) CONT(MP)=CONT(I) CONT(I)=ZSAFE 640 CONTINUE END DO C ----------------------------------- 88 CONTINUE ERR=0.D0 DO I=1,N ERR=ERR+(CONT(I)/SCAL(I))**2 END DO ERR=MAX(SQRT(ERR/N),1.D-10) END IF RETURN C ----------------------------------------------------------- 55 CONTINUE RETURN END C C END OF SUBROUTINE ESTRAD C C *********************************************************** C SUBROUTINE ESTRAV(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & H,DD,FCN,NFCN,Y0,Y,IJOB,X,M1,M2,NM1,NS,NNS, & E1,LDE1,ZZ,CONT,FF,IP1,IPHES,SCAL,ERR, & FIRST,REJECT,FAC1,RPAR,IPAR) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1),E1(LDE1,NM1),IP1(NM1), & SCAL(N),IPHES(N),ZZ(NNS),FF(NNS),Y0(N),Y(N) DIMENSION DD(NS),CONT(N),RPAR(1),IPAR(1) LOGICAL FIRST,REJECT COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG IF (IJOB .EQ. 1) THEN GOTO 1 ELSE IF (IJOB .EQ. 2) THEN GOTO 2 ELSE IF (IJOB .EQ. 3) THEN GOTO 3 ELSE IF (IJOB .EQ. 4) THEN GOTO 4 ELSE IF (IJOB .EQ. 5) THEN GOTO 5 ELSE IF (IJOB .EQ. 6) THEN GOTO 6 ELSE IF (IJOB .EQ. 7) THEN GOTO 7 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ. 11) THEN GOTO 11 ELSE IF (IJOB .EQ. 12) THEN GOTO 12 ELSE IF (IJOB .EQ. 13) THEN GOTO 13 ELSE IF (IJOB .EQ. 14) THEN GOTO 14 ELSE IF (IJOB .EQ. 15) THEN GOTO 15 ENDIF C karline: changed from C GOTO (1,2,3,4,5,6,7,55,55,55,11,12,13,14,15), IJOB C 1 CONTINUE C ------ B=IDENTITY, JACOBIAN A FULL MATRIX DO I=1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I+N)=SUM/H CONT(I)=FF(I+N)+Y0(I) END DO CALL solradau (N,LDE1,E1,CONT,IP1) GOTO 77 C 11 CONTINUE C ------ B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I+N)=SUM/H CONT(I)=FF(I+N)+Y0(I) END DO 48 MM=M1/M2 DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 SUM1=(CONT(J+K*M2)+SUM1)/FAC1 DO I=1,NM1 IM1=I+M1 CONT(IM1)=CONT(IM1)+FJAC(I,J+K*M2)*SUM1 END DO END DO END DO CALL solradau (NM1,LDE1,E1,CONT(M1+1),IP1) DO I=M1,1,-1 CONT(I)=(CONT(I)+CONT(M2+I))/FAC1 END DO GOTO 77 C 2 CONTINUE C ------ B=IDENTITY, JACOBIAN A BANDED MATRIX DO I=1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I+N)=SUM/H CONT(I)=FF(I+N)+Y0(I) END DO CALL SOLradB (N,LDE1,E1,MLE,MUE,CONT,IP1) GOTO 77 C 12 CONTINUE C ------ B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER DO I=1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I+N)=SUM/H CONT(I)=FF(I+N)+Y0(I) END DO 45 MM=M1/M2 DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 SUM1=(CONT(J+K*M2)+SUM1)/FAC1 DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 CONT(IM1)=CONT(IM1)+FJAC(I+MUJAC+1-J,J+K*M2)*SUM1 END DO END DO END DO CALL SOLradB (NM1,LDE1,E1,MLE,MUE,CONT(M1+1),IP1) DO I=M1,1,-1 CONT(I)=(CONT(I)+CONT(M2+I))/FAC1 END DO GOTO 77 C 3 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX DO I=1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I)=SUM/H END DO DO I=1,N SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*FF(J) END DO FF(I+N)=SUM CONT(I)=SUM+Y0(I) END DO CALL solradau (N,LDE1,E1,CONT,IP1) GOTO 77 C 13 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I+N)=SUM/H CONT(I)=FF(I+N)+Y0(I) END DO DO I=M1+1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I)=SUM/H END DO DO I=1,NM1 SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(NM1,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*FF(J+M1) END DO IM1=I+M1 FF(IM1+N)=SUM CONT(IM1)=SUM+Y0(IM1) END DO GOTO 48 C 4 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX DO I=1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I)=SUM/H END DO DO I=1,N SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*FF(J) END DO FF(I+N)=SUM CONT(I)=SUM+Y0(I) END DO CALL SOLradB (N,LDE1,E1,MLE,MUE,CONT,IP1) GOTO 77 C 14 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX, SECOND ORDER DO I=1,M1 SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I+N)=SUM/H CONT(I)=FF(I+N)+Y0(I) END DO DO I=M1+1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I)=SUM/H END DO DO I=1,NM1 SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(NM1,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*FF(J+M1) END DO IM1=I+M1 FF(IM1+N)=SUM CONT(IM1)=SUM+Y0(IM1) END DO GOTO 45 C 5 CONTINUE C ------ B IS A FULL MATRIX, JACOBIAN A FULL MATRIX DO I=1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I)=SUM/H END DO DO I=1,N SUM=0.D0 DO J=1,N SUM=SUM+FMAS(I,J)*FF(J) END DO FF(I+N)=SUM CONT(I)=SUM+Y0(I) END DO CALL solradau (N,LDE1,E1,CONT,IP1) GOTO 77 C 15 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I+N)=SUM/H CONT(I)=FF(I+N)+Y0(I) END DO DO I=M1+1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I)=SUM/H END DO DO I=1,NM1 SUM=0.D0 DO J=1,NM1 SUM=SUM+FMAS(I,J)*FF(J+M1) END DO IM1=I+M1 FF(IM1+N)=SUM CONT(IM1)=SUM+Y0(IM1) END DO GOTO 48 C 6 CONTINUE C ------ B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX C ------ THIS OPTION IS NOT PROVIDED RETURN C 7 CONTINUE C ------ B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION DO I=1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I+N)=SUM/H CONT(I)=FF(I+N)+Y0(I) END DO DO MM=N-2,1,-1 MP=N-MM I=IPHES(MP) IF (I.EQ.MP) GOTO 310 ZSAFE=CONT(MP) CONT(MP)=CONT(I) CONT(I)=ZSAFE 310 CONTINUE DO I=MP+1,N CONT(I)=CONT(I)-FJAC(I,MP-1)*CONT(MP) END DO END DO CALL SOLH(N,LDE1,E1,1,CONT,IP1) DO MM=1,N-2 MP=N-MM DO I=MP+1,N CONT(I)=CONT(I)+FJAC(I,MP-1)*CONT(MP) END DO I=IPHES(MP) IF (I.EQ.MP) GOTO 440 ZSAFE=CONT(MP) CONT(MP)=CONT(I) CONT(I)=ZSAFE 440 CONTINUE END DO C C -------------------------------------- C 77 CONTINUE ERR=0.D0 DO I=1,N ERR=ERR+(CONT(I)/SCAL(I))**2 END DO ERR=MAX(SQRT(ERR/N),1.D-10) C IF (ERR.LT.1.D0) RETURN IF (FIRST.OR.REJECT) THEN DO I=1,N CONT(I)=Y(I)+CONT(I) END DO CALL FCN(N,X,CONT,FF,RPAR,IPAR) NFCN=NFCN+1 DO I=1,N CONT(I)=FF(I)+FF(I+N) END DO IF (IJOB.EQ.1 .OR. IJOB .EQ. 3 .OR. IJOB .EQ. 5) THEN GOTO 31 ELSE IF (IJOB .EQ.2 .OR. IJOB .EQ. 4 .OR. IJOB .EQ. 6) THEN GOTO 32 ELSE IF (IJOB .EQ.7) THEN GOTO 33 ELSE IF (IJOB .LE.10) THEN GOTO 55 ELSE IF (IJOB .EQ.11 .OR. IJOB .EQ. 13 .OR. IJOB.EQ.15) THEN GOTO 41 ELSE IF (IJOB .EQ.12 .OR. IJOB .EQ. 14) THEN GOTO 42 ENDIF C karline: changed from C GOTO (31,32,31,32,31,32,33,55,55,55,41,42,41,42,41), IJOB C ------ FULL MATRIX OPTION 31 CONTINUE CALL solradau (N,LDE1,E1,CONT,IP1) GOTO 88 C ------ FULL MATRIX OPTION, SECOND ORDER 41 CONTINUE DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 SUM1=(CONT(J+K*M2)+SUM1)/FAC1 DO I=1,NM1 IM1=I+M1 CONT(IM1)=CONT(IM1)+FJAC(I,J+K*M2)*SUM1 END DO END DO END DO CALL solradau (NM1,LDE1,E1,CONT(M1+1),IP1) DO I=M1,1,-1 CONT(I)=(CONT(I)+CONT(M2+I))/FAC1 END DO GOTO 88 C ------ BANDED MATRIX OPTION 32 CONTINUE CALL SOLradB (N,LDE1,E1,MLE,MUE,CONT,IP1) GOTO 88 C ------ BANDED MATRIX OPTION, SECOND ORDER 42 CONTINUE DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 SUM1=(CONT(J+K*M2)+SUM1)/FAC1 DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 CONT(IM1)=CONT(IM1)+FJAC(I+MUJAC+1-J,J+K*M2)*SUM1 END DO END DO END DO CALL SOLradB (NM1,LDE1,E1,MLE,MUE,CONT(M1+1),IP1) DO I=M1,1,-1 CONT(I)=(CONT(I)+CONT(M2+I))/FAC1 END DO GOTO 88 C ------ HESSENBERG MATRIX OPTION 33 CONTINUE DO MM=N-2,1,-1 MP=N-MM I=IPHES(MP) IF (I.EQ.MP) GOTO 510 ZSAFE=CONT(MP) CONT(MP)=CONT(I) CONT(I)=ZSAFE 510 CONTINUE DO I=MP+1,N CONT(I)=CONT(I)-FJAC(I,MP-1)*CONT(MP) END DO END DO CALL SOLH(N,LDE1,E1,1,CONT,IP1) DO MM=1,N-2 MP=N-MM DO I=MP+1,N CONT(I)=CONT(I)+FJAC(I,MP-1)*CONT(MP) END DO I=IPHES(MP) IF (I.EQ.MP) GOTO 640 ZSAFE=CONT(MP) CONT(MP)=CONT(I) CONT(I)=ZSAFE 640 CONTINUE END DO C ----------------------------------- 88 CONTINUE ERR=0.D0 DO I=1,N ERR=ERR+(CONT(I)/SCAL(I))**2 END DO ERR=MAX(SQRT(ERR/N),1.D-10) END IF RETURN C C ----------------------------------------------------------- C 55 CONTINUE RETURN END C C END OF SUBROUTINE ESTRAV C C *********************************************************** C SUBROUTINE SLVROD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,FAC1,E,LDE,IP,DY,AK,FX,YNEW,HD,IJOB,STAGE1) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1),E(LDE,NM1), & IP(NM1),DY(N),AK(N),FX(N),YNEW(N) LOGICAL STAGE1 COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG C IF (HD.EQ.0.D0) THEN DO I=1,N AK(I)=DY(I) END DO ELSE DO I=1,N AK(I)=DY(I)+HD*FX(I) END DO END IF C C GOTO (1,2,3,4,5,6,55,55,55,55,11,12,13,13,15), IJOB IF (IJOB .EQ. 1) THEN GOTO 1 ELSE IF (IJOB .EQ. 2) THEN GOTO 2 ELSE IF (IJOB .EQ. 3) THEN GOTO 3 ELSE IF (IJOB .EQ. 4) THEN GOTO 4 ELSE IF (IJOB .EQ. 5) THEN GOTO 5 ELSE IF (IJOB .EQ. 6) THEN GOTO 6 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ. 11) THEN GOTO 11 ELSE IF (IJOB .EQ. 12) THEN GOTO 12 ELSE IF (IJOB .LE. 14) THEN GOTO 13 ELSE IF (IJOB .EQ. 15) THEN GOTO 15 ENDIF C karline: was C GOTO (1,2,3,4,5,6,55,55,55,55,11,12,13,13,15), IJOB C C ----------------------------------------------------------- C 1 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX IF (STAGE1) THEN DO I=1,N AK(I)=AK(I)+YNEW(I) END DO END IF CALL solradau (N,LDE,E,AK,IP) RETURN C C ----------------------------------------------------------- C 11 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER IF (STAGE1) THEN DO I=1,N AK(I)=AK(I)+YNEW(I) END DO END IF 48 MM=M1/M2 DO J=1,M2 SUM=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUM=(AK(JKM)+SUM)/FAC1 DO I=1,NM1 IM1=I+M1 AK(IM1)=AK(IM1)+FJAC(I,JKM)*SUM END DO END DO END DO CALL solradau (NM1,LDE,E,AK(M1+1),IP) DO I=M1,1,-1 AK(I)=(AK(I)+AK(M2+I))/FAC1 END DO RETURN C C ----------------------------------------------------------- C 2 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX IF (STAGE1) THEN DO I=1,N AK(I)=AK(I)+YNEW(I) END DO END IF CALL SOLradB (N,LDE,E,MLE,MUE,AK,IP) RETURN C C ----------------------------------------------------------- C 12 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER IF (STAGE1) THEN DO I=1,N AK(I)=AK(I)+YNEW(I) END DO END IF 45 MM=M1/M2 DO J=1,M2 SUM=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUM=(AK(JKM)+SUM)/FAC1 DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 AK(IM1)=AK(IM1)+FJAC(I+MUJAC+1-J,JKM)*SUM END DO END DO END DO CALL SOLradB (NM1,LDE,E,MLE,MUE,AK(M1+1),IP) DO I=M1,1,-1 AK(I)=(AK(I)+AK(M2+I))/FAC1 END DO RETURN C C ----------------------------------------------------------- C 3 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX IF (STAGE1) THEN DO I=1,N SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*YNEW(J) END DO AK(I)=AK(I)+SUM END DO END IF CALL solradau (N,LDE,E,AK,IP) RETURN C C ----------------------------------------------------------- C 13 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER IF (STAGE1) THEN DO I=1,M1 AK(I)=AK(I)+YNEW(I) END DO DO I=1,NM1 SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(NM1,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*YNEW(J+M1) END DO IM1=I+M1 AK(IM1)=AK(IM1)+SUM END DO END IF IF (IJOB.EQ.14) GOTO 45 GOTO 48 C C ----------------------------------------------------------- C 4 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX IF (STAGE1) THEN DO I=1,N SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*YNEW(J) END DO AK(I)=AK(I)+SUM END DO END IF CALL SOLradB (N,LDE,E,MLE,MUE,AK,IP) RETURN C C ----------------------------------------------------------- C 5 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX IF (STAGE1) THEN DO I=1,N SUM=0.D0 DO J=1,N SUM=SUM+FMAS(I,J)*YNEW(J) END DO AK(I)=AK(I)+SUM END DO END IF CALL solradau (N,LDE,E,AK,IP) RETURN C C ----------------------------------------------------------- C 15 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER IF (STAGE1) THEN DO I=1,M1 AK(I)=AK(I)+YNEW(I) END DO DO I=1,NM1 SUM=0.D0 DO J=1,NM1 SUM=SUM+FMAS(I,J)*YNEW(J+M1) END DO IM1=I+M1 AK(IM1)=AK(IM1)+SUM END DO END IF GOTO 48 C C ----------------------------------------------------------- C 6 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX C --- THIS OPTION IS NOT PROVIDED IF (STAGE1) THEN DO 624 I=1,N SUM=0.D0 DO 623 J=1,N SUM=SUM+FMAS(I,J)*YNEW(J) 623 CONTINUE AK(I)=AK(I)+SUM 624 CONTINUE CALL SOLradB (N,LDE,E,MLE,MUE,AK,IP) END IF RETURN C C ----------------------------------------------------------- C 55 CONTINUE RETURN END C C END OF SUBROUTINE SLVROD C C C *********************************************************** C SUBROUTINE SLVSEU(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,FAC1,E,LDE,IP,IPHES,DEL,IJOB) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1),E(LDE,NM1),DEL(N) DIMENSION IP(NM1),IPHES(N) COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG C IF (IJOB .EQ. 1 .OR. IJOB .EQ. 3 .OR. IJOB .EQ. 5) THEN GOTO 1 ELSE IF (IJOB .EQ. 2 .OR. IJOB .EQ. 4) THEN GOTO 2 ELSE IF (IJOB.EQ.6.OR.IJOB.EQ.8.OR.IJOB.EQ.9.OR.IJOB.EQ.10) THEN GOTO 55 ELSE IF (IJOB .EQ. 7) THEN GOTO 7 ELSE IF (IJOB .EQ. 11 .OR. IJOB .EQ.13 .OR. IJOB .EQ. 15) THEN GOTO 11 ELSE IF (IJOB .EQ. 12 .OR. IJOB .EQ. 14) THEN GOTO 12 ENDIF C karline: the above was changed from this computed goto C GOTO (1,2,1,2,1,55,7,55,55,55,11,12,11,12,11), IJOB C C ----------------------------------------------------------- C 1 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX CALL solradau (N,LDE,E,DEL,IP) RETURN C C ----------------------------------------------------------- C 11 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER MM=M1/M2 DO J=1,M2 SUM=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUM=(DEL(JKM)+SUM)/FAC1 DO I=1,NM1 IM1=I+M1 DEL(IM1)=DEL(IM1)+FJAC(I,JKM)*SUM END DO END DO END DO CALL solradau (NM1,LDE,E,DEL(M1+1),IP) DO I=M1,1,-1 DEL(I)=(DEL(I)+DEL(M2+I))/FAC1 END DO RETURN C C ----------------------------------------------------------- C 2 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX CALL SOLradB (N,LDE,E,MLE,MUE,DEL,IP) RETURN C C ----------------------------------------------------------- C 12 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER MM=M1/M2 DO J=1,M2 SUM=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUM=(DEL(JKM)+SUM)/FAC1 DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 DEL(IM1)=DEL(IM1)+FJAC(I+MUJAC+1-J,JKM)*SUM END DO END DO END DO CALL SOLradB (NM1,LDE,E,MLE,MUE,DEL(M1+1),IP) DO I=M1,1,-1 DEL(I)=(DEL(I)+DEL(M2+I))/FAC1 END DO RETURN C C ----------------------------------------------------------- C 7 CONTINUE C --- HESSENBERG OPTION DO MMM=N-2,1,-1 MP=N-MMM MP1=MP-1 I=IPHES(MP) IF (I.EQ.MP) GOTO 110 ZSAFE=DEL(MP) DEL(MP)=DEL(I) DEL(I)=ZSAFE 110 CONTINUE DO I=MP+1,N DEL(I)=DEL(I)-FJAC(I,MP1)*DEL(MP) END DO END DO CALL SOLH(N,LDE,E,1,DEL,IP) DO MMM=1,N-2 MP=N-MMM MP1=MP-1 DO I=MP+1,N DEL(I)=DEL(I)+FJAC(I,MP1)*DEL(MP) END DO I=IPHES(MP) IF (I.EQ.MP) GOTO 240 ZSAFE=DEL(MP) DEL(MP)=DEL(I) DEL(I)=ZSAFE 240 CONTINUE END DO RETURN C C ----------------------------------------------------------- C 55 CONTINUE RETURN END C C END OF SUBROUTINE SLVSEU C SUBROUTINE DECradau (N, NDIM, A, IP, IER) C VERSION REAL DOUBLE PRECISION INTEGER N,NDIM,IP,IER,NM1,K,KP1,M,I,J DOUBLE PRECISION A,T DIMENSION A(NDIM,N), IP(N) C----------------------------------------------------------------------- C MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION. C INPUT.. C N = ORDER OF MATRIX. C NDIM = DECLARED DIMENSION OF ARRAY A . C A = MATRIX TO BE TRIANGULARIZED. C OUTPUT.. C A(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U . C A(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. C IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW. C IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O . C IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE C SINGULAR AT STAGE K. C USE solradau TO OBTAIN SOLUTION OF LINEAR SYSTEM. C DETERM(A) = IP(N)*A(1,1)*A(2,2)*...*A(N,N). C IF IP(N)=O, A IS SINGULAR, solradau WILL DIVIDE BY ZERO. C C REFERENCE.. C C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, C C.A.C.M. 15 (1972), P. 274. C----------------------------------------------------------------------- IER = 0 IP(N) = 1 IF (N .EQ. 1) GO TO 70 NM1 = N - 1 DO 60 K = 1,NM1 KP1 = K + 1 M = K DO 10 I = KP1,N IF (DABS(A(I,K)) .GT. DABS(A(M,K))) M = I 10 CONTINUE IP(K) = M T = A(M,K) IF (M .EQ. K) GO TO 20 IP(N) = -IP(N) A(M,K) = A(K,K) A(K,K) = T 20 CONTINUE IF (T .EQ. 0.D0) GO TO 80 T = 1.D0/T DO 30 I = KP1,N A(I,K) = -A(I,K)*T 30 CONTINUE DO 50 J = KP1,N T = A(M,J) A(M,J) = A(K,J) A(K,J) = T IF (T .EQ. 0.D0) GO TO 45 DO 40 I = KP1,N A(I,J) = A(I,J) + A(I,K)*T 40 CONTINUE 45 CONTINUE 50 CONTINUE 60 CONTINUE 70 K = N IF (A(N,N) .EQ. 0.D0) GO TO 80 RETURN 80 IER = K IP(N) = 0 RETURN C----------------------- END OF SUBROUTINE DECradau ------------------------- END C C SUBROUTINE solradau (N, NDIM, A, B, IP) C VERSION REAL DOUBLE PRECISION INTEGER N,NDIM,IP,NM1,K,KP1,M,I,KB,KM1 DOUBLE PRECISION A,B,T DIMENSION A(NDIM,N), B(N), IP(N) C----------------------------------------------------------------------- C SOLUTION OF LINEAR SYSTEM, A*X = B . C INPUT.. C N = ORDER OF MATRIX. C NDIM = DECLARED DIMENSION OF ARRAY A . C A = TRIANGULARIZED MATRIX OBTAINED FROM DECradau. C B = RIGHT HAND SIDE VECTOR. C IP = PIVOT VECTOR OBTAINED FROM DECradau. C DO NOT USE IF DECradau HAS SET IER .NE. 0. C OUTPUT.. C B = SOLUTION VECTOR, X . C----------------------------------------------------------------------- IF (N .EQ. 1) GO TO 50 NM1 = N - 1 DO 20 K = 1,NM1 KP1 = K + 1 M = IP(K) T = B(M) B(M) = B(K) B(K) = T DO 10 I = KP1,N B(I) = B(I) + A(I,K)*T 10 CONTINUE 20 CONTINUE DO 40 KB = 1,NM1 KM1 = N - KB K = KM1 + 1 B(K) = B(K)/A(K,K) T = -B(K) DO 30 I = 1,KM1 B(I) = B(I) + A(I,K)*T 30 CONTINUE 40 CONTINUE 50 B(1) = B(1)/A(1,1) RETURN C----------------------- END OF SUBROUTINE solradau ------------------------- END c c SUBROUTINE DECH (N, NDIM, A, LB, IP, IER) C VERSION REAL DOUBLE PRECISION INTEGER N,NDIM,IP,IER,NM1,K,KP1,M,I,J,LB,NA DOUBLE PRECISION A,T DIMENSION A(NDIM,N), IP(N) C----------------------------------------------------------------------- C MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION OF A HESSENBERG C MATRIX WITH LOWER BANDWIDTH LB C INPUT.. C N = ORDER OF MATRIX A. C NDIM = DECLARED DIMENSION OF ARRAY A . C A = MATRIX TO BE TRIANGULARIZED. C LB = LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED, LB.GE.1). C OUTPUT.. C A(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U . C A(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. C IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW. C IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O . C IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE C SINGULAR AT STAGE K. C USE SOLH TO OBTAIN SOLUTION OF LINEAR SYSTEM. C DETERM(A) = IP(N)*A(1,1)*A(2,2)*...*A(N,N). C IF IP(N)=O, A IS SINGULAR, solradau WILL DIVIDE BY ZERO. C C REFERENCE.. C THIS IS A SLIGHT MODIFICATION OF C C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, C C.A.C.M. 15 (1972), P. 274. C----------------------------------------------------------------------- IER = 0 IP(N) = 1 IF (N .EQ. 1) GO TO 70 NM1 = N - 1 DO 60 K = 1,NM1 KP1 = K + 1 M = K NA = MIN0(N,LB+K) DO 10 I = KP1,NA IF (DABS(A(I,K)) .GT. DABS(A(M,K))) M = I 10 CONTINUE IP(K) = M T = A(M,K) IF (M .EQ. K) GO TO 20 IP(N) = -IP(N) A(M,K) = A(K,K) A(K,K) = T 20 CONTINUE IF (T .EQ. 0.D0) GO TO 80 T = 1.D0/T DO 30 I = KP1,NA A(I,K) = -A(I,K)*T 30 CONTINUE DO 50 J = KP1,N T = A(M,J) A(M,J) = A(K,J) A(K,J) = T IF (T .EQ. 0.D0) GO TO 45 DO 40 I = KP1,NA A(I,J) = A(I,J) + A(I,K)*T 40 CONTINUE 45 CONTINUE 50 CONTINUE 60 CONTINUE 70 K = N IF (A(N,N) .EQ. 0.D0) GO TO 80 RETURN 80 IER = K IP(N) = 0 RETURN C----------------------- END OF SUBROUTINE DECH ------------------------ END C C SUBROUTINE SOLH (N, NDIM, A, LB, B, IP) C VERSION REAL DOUBLE PRECISION INTEGER N,NDIM,IP,NM1,K,KP1,M,I,KB,KM1,LB,NA DOUBLE PRECISION A,B,T DIMENSION A(NDIM,N), B(N), IP(N) C----------------------------------------------------------------------- C SOLUTION OF LINEAR SYSTEM, A*X = B . C INPUT.. C N = ORDER OF MATRIX A. C NDIM = DECLARED DIMENSION OF ARRAY A . C A = TRIANGULARIZED MATRIX OBTAINED FROM DECH. C LB = LOWER BANDWIDTH OF A. C B = RIGHT HAND SIDE VECTOR. C IP = PIVOT VECTOR OBTAINED FROM DECradau. C DO NOT USE IF DECH HAS SET IER .NE. 0. C OUTPUT.. C B = SOLUTION VECTOR, X . C----------------------------------------------------------------------- IF (N .EQ. 1) GO TO 50 NM1 = N - 1 DO 20 K = 1,NM1 KP1 = K + 1 M = IP(K) T = B(M) B(M) = B(K) B(K) = T NA = MIN0(N,LB+K) DO 10 I = KP1,NA B(I) = B(I) + A(I,K)*T 10 CONTINUE 20 CONTINUE DO 40 KB = 1,NM1 KM1 = N - KB K = KM1 + 1 B(K) = B(K)/A(K,K) T = -B(K) DO 30 I = 1,KM1 B(I) = B(I) + A(I,K)*T 30 CONTINUE 40 CONTINUE 50 B(1) = B(1)/A(1,1) RETURN C----------------------- END OF SUBROUTINE SOLH ------------------------ END C SUBROUTINE DECC (N, NDIM, AR, AI, IP, IER) C VERSION COMPLEX DOUBLE PRECISION IMPLICIT REAL(KIND=8) (A-H,O-Z) INTEGER N,NDIM,IP,IER,NM1,K,KP1,M,I,J DIMENSION AR(NDIM,N), AI(NDIM,N), IP(N) C----------------------------------------------------------------------- C MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION C ------ MODIFICATION FOR COMPLEX MATRICES -------- C INPUT.. C N = ORDER OF MATRIX. C NDIM = DECLARED DIMENSION OF ARRAYS AR AND AI . C (AR, AI) = MATRIX TO BE TRIANGULARIZED. C OUTPUT.. C AR(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U ; REAL PART. C AI(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U ; IMAGINARY PART. C AR(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. C REAL PART. C AI(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. C IMAGINARY PART. C IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW. C IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O . C IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE C SINGULAR AT STAGE K. C USE solradau TO OBTAIN SOLUTION OF LINEAR SYSTEM. C IF IP(N)=O, A IS SINGULAR, solradau WILL DIVIDE BY ZERO. C C REFERENCE.. C C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, C C.A.C.M. 15 (1972), P. 274. C----------------------------------------------------------------------- IER = 0 IP(N) = 1 IF (N .EQ. 1) GO TO 70 NM1 = N - 1 DO 60 K = 1,NM1 KP1 = K + 1 M = K DO 10 I = KP1,N IF (DABS(AR(I,K))+DABS(AI(I,K)) .GT. & DABS(AR(M,K))+DABS(AI(M,K))) M = I 10 CONTINUE IP(K) = M TR = AR(M,K) TI = AI(M,K) IF (M .EQ. K) GO TO 20 IP(N) = -IP(N) AR(M,K) = AR(K,K) AI(M,K) = AI(K,K) AR(K,K) = TR AI(K,K) = TI 20 CONTINUE IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 80 DEN=TR*TR+TI*TI TR=TR/DEN TI=-TI/DEN DO 30 I = KP1,N PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI AR(I,K)=-PRODR AI(I,K)=-PRODI 30 CONTINUE DO 50 J = KP1,N TR = AR(M,J) TI = AI(M,J) AR(M,J) = AR(K,J) AI(M,J) = AI(K,J) AR(K,J) = TR AI(K,J) = TI IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 48 IF (TI .EQ. 0.D0) THEN DO 40 I = KP1,N PRODR=AR(I,K)*TR PRODI=AI(I,K)*TR AR(I,J) = AR(I,J) + PRODR AI(I,J) = AI(I,J) + PRODI 40 CONTINUE GO TO 48 END IF IF (TR .EQ. 0.D0) THEN DO 45 I = KP1,N PRODR=-AI(I,K)*TI PRODI=AR(I,K)*TI AR(I,J) = AR(I,J) + PRODR AI(I,J) = AI(I,J) + PRODI 45 CONTINUE GO TO 48 END IF DO 47 I = KP1,N PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI AR(I,J) = AR(I,J) + PRODR AI(I,J) = AI(I,J) + PRODI 47 CONTINUE 48 CONTINUE 50 CONTINUE 60 CONTINUE 70 K = N IF (DABS(AR(N,N))+DABS(AI(N,N)) .EQ. 0.D0) GO TO 80 RETURN 80 IER = K IP(N) = 0 RETURN C----------------------- END OF SUBROUTINE DECC ------------------------ END C C SUBROUTINE SOLC (N, NDIM, AR, AI, BR, BI, IP) C VERSION COMPLEX DOUBLE PRECISION IMPLICIT REAL(KIND=8) (A-H,O-Z) INTEGER N,NDIM,IP,NM1,K,KP1,M,I,KB,KM1 DIMENSION AR(NDIM,N), AI(NDIM,N), BR(N), BI(N), IP(N) C----------------------------------------------------------------------- C SOLUTION OF LINEAR SYSTEM, A*X = B . C INPUT.. C N = ORDER OF MATRIX. C NDIM = DECLARED DIMENSION OF ARRAYS AR AND AI. C (AR,AI) = TRIANGULARIZED MATRIX OBTAINED FROM DECradau. C (BR,BI) = RIGHT HAND SIDE VECTOR. C IP = PIVOT VECTOR OBTAINED FROM DECradau. C DO NOT USE IF DECradau HAS SET IER .NE. 0. C OUTPUT.. C (BR,BI) = SOLUTION VECTOR, X . C----------------------------------------------------------------------- IF (N .EQ. 1) GO TO 50 NM1 = N - 1 DO 20 K = 1,NM1 KP1 = K + 1 M = IP(K) TR = BR(M) TI = BI(M) BR(M) = BR(K) BI(M) = BI(K) BR(K) = TR BI(K) = TI DO 10 I = KP1,N PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI BR(I) = BR(I) + PRODR BI(I) = BI(I) + PRODI 10 CONTINUE 20 CONTINUE DO 40 KB = 1,NM1 KM1 = N - KB K = KM1 + 1 DEN=AR(K,K)*AR(K,K)+AI(K,K)*AI(K,K) PRODR=BR(K)*AR(K,K)+BI(K)*AI(K,K) PRODI=BI(K)*AR(K,K)-BR(K)*AI(K,K) BR(K)=PRODR/DEN BI(K)=PRODI/DEN TR = -BR(K) TI = -BI(K) DO 30 I = 1,KM1 PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI BR(I) = BR(I) + PRODR BI(I) = BI(I) + PRODI 30 CONTINUE 40 CONTINUE 50 CONTINUE DEN=AR(1,1)*AR(1,1)+AI(1,1)*AI(1,1) PRODR=BR(1)*AR(1,1)+BI(1)*AI(1,1) PRODI=BI(1)*AR(1,1)-BR(1)*AI(1,1) BR(1)=PRODR/DEN BI(1)=PRODI/DEN RETURN C----------------------- END OF SUBROUTINE SOLC ------------------------ END C C SUBROUTINE DECHC (N, NDIM, AR, AI, LB, IP, IER) C VERSION COMPLEX DOUBLE PRECISION IMPLICIT REAL(KIND=8) (A-H,O-Z) INTEGER N,NDIM,IP,IER,NM1,K,KP1,M,I,J DIMENSION AR(NDIM,N), AI(NDIM,N), IP(N) C----------------------------------------------------------------------- C MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION C ------ MODIFICATION FOR COMPLEX MATRICES -------- C INPUT.. C N = ORDER OF MATRIX. C NDIM = DECLARED DIMENSION OF ARRAYS AR AND AI . C (AR, AI) = MATRIX TO BE TRIANGULARIZED. C OUTPUT.. C AR(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U ; REAL PART. C AI(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U ; IMAGINARY PART. C AR(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. C REAL PART. C AI(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. C IMAGINARY PART. C LB = LOWER BANDWIDTH OF A (DIAGONAL NOT COUNTED), LB.GE.1. C IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW. C IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O . C IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE C SINGULAR AT STAGE K. C USE solradau TO OBTAIN SOLUTION OF LINEAR SYSTEM. C IF IP(N)=O, A IS SINGULAR, solradau WILL DIVIDE BY ZERO. C C REFERENCE.. C C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, C C.A.C.M. 15 (1972), P. 274. C----------------------------------------------------------------------- IER = 0 IP(N) = 1 IF (LB .EQ. 0) GO TO 70 IF (N .EQ. 1) GO TO 70 NM1 = N - 1 DO 60 K = 1,NM1 KP1 = K + 1 M = K NA = MIN0(N,LB+K) DO 10 I = KP1,NA IF (DABS(AR(I,K))+DABS(AI(I,K)) .GT. & DABS(AR(M,K))+DABS(AI(M,K))) M = I 10 CONTINUE IP(K) = M TR = AR(M,K) TI = AI(M,K) IF (M .EQ. K) GO TO 20 IP(N) = -IP(N) AR(M,K) = AR(K,K) AI(M,K) = AI(K,K) AR(K,K) = TR AI(K,K) = TI 20 CONTINUE IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 80 DEN=TR*TR+TI*TI TR=TR/DEN TI=-TI/DEN DO 30 I = KP1,NA PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI AR(I,K)=-PRODR AI(I,K)=-PRODI 30 CONTINUE DO 50 J = KP1,N TR = AR(M,J) TI = AI(M,J) AR(M,J) = AR(K,J) AI(M,J) = AI(K,J) AR(K,J) = TR AI(K,J) = TI IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 48 IF (TI .EQ. 0.D0) THEN DO 40 I = KP1,NA PRODR=AR(I,K)*TR PRODI=AI(I,K)*TR AR(I,J) = AR(I,J) + PRODR AI(I,J) = AI(I,J) + PRODI 40 CONTINUE GO TO 48 END IF IF (TR .EQ. 0.D0) THEN DO 45 I = KP1,NA PRODR=-AI(I,K)*TI PRODI=AR(I,K)*TI AR(I,J) = AR(I,J) + PRODR AI(I,J) = AI(I,J) + PRODI 45 CONTINUE GO TO 48 END IF DO 47 I = KP1,NA PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI AR(I,J) = AR(I,J) + PRODR AI(I,J) = AI(I,J) + PRODI 47 CONTINUE 48 CONTINUE 50 CONTINUE 60 CONTINUE 70 K = N IF (DABS(AR(N,N))+DABS(AI(N,N)) .EQ. 0.D0) GO TO 80 RETURN 80 IER = K IP(N) = 0 RETURN C----------------------- END OF SUBROUTINE DECHC ----------------------- END C C SUBROUTINE SOLHC (N, NDIM, AR, AI, LB, BR, BI, IP) C VERSION COMPLEX DOUBLE PRECISION IMPLICIT REAL(KIND=8) (A-H,O-Z) INTEGER N,NDIM,IP,NM1,K,KP1,M,I,KB,KM1 DIMENSION AR(NDIM,N), AI(NDIM,N), BR(N), BI(N), IP(N) C----------------------------------------------------------------------- C SOLUTION OF LINEAR SYSTEM, A*X = B . C INPUT.. C N = ORDER OF MATRIX. C NDIM = DECLARED DIMENSION OF ARRAYS AR AND AI. C (AR,AI) = TRIANGULARIZED MATRIX OBTAINED FROM DECradau. C (BR,BI) = RIGHT HAND SIDE VECTOR. C LB = LOWER BANDWIDTH OF A. C IP = PIVOT VECTOR OBTAINED FROM DECradau. C DO NOT USE IF DECradau HAS SET IER .NE. 0. C OUTPUT.. C (BR,BI) = SOLUTION VECTOR, X . C----------------------------------------------------------------------- IF (N .EQ. 1) GO TO 50 NM1 = N - 1 IF (LB .EQ. 0) GO TO 25 DO 20 K = 1,NM1 KP1 = K + 1 M = IP(K) TR = BR(M) TI = BI(M) BR(M) = BR(K) BI(M) = BI(K) BR(K) = TR BI(K) = TI DO 10 I = KP1,MIN0(N,LB+K) PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI BR(I) = BR(I) + PRODR BI(I) = BI(I) + PRODI 10 CONTINUE 20 CONTINUE 25 CONTINUE DO 40 KB = 1,NM1 KM1 = N - KB K = KM1 + 1 DEN=AR(K,K)*AR(K,K)+AI(K,K)*AI(K,K) PRODR=BR(K)*AR(K,K)+BI(K)*AI(K,K) PRODI=BI(K)*AR(K,K)-BR(K)*AI(K,K) BR(K)=PRODR/DEN BI(K)=PRODI/DEN TR = -BR(K) TI = -BI(K) DO 30 I = 1,KM1 PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI BR(I) = BR(I) + PRODR BI(I) = BI(I) + PRODI 30 CONTINUE 40 CONTINUE 50 CONTINUE DEN=AR(1,1)*AR(1,1)+AI(1,1)*AI(1,1) PRODR=BR(1)*AR(1,1)+BI(1)*AI(1,1) PRODI=BI(1)*AR(1,1)-BR(1)*AI(1,1) BR(1)=PRODR/DEN BI(1)=PRODI/DEN RETURN C----------------------- END OF SUBROUTINE SOLHC ----------------------- END C SUBROUTINE DECradB (N, NDIM, A, ML, MU, IP, IER) REAL(KIND=8) A,T DIMENSION A(NDIM,N), IP(N) C----------------------------------------------------------------------- C MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION OF A BANDED C MATRIX WITH LOWER BANDWIDTH ML AND UPPER BANDWIDTH MU C INPUT.. C N ORDER OF THE ORIGINAL MATRIX A. C NDIM DECLARED DIMENSION OF ARRAY A. C A CONTAINS THE MATRIX IN BAND STORAGE. THE COLUMNS C OF THE MATRIX ARE STORED IN THE COLUMNS OF A AND C THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS C ML+1 THROUGH 2*ML+MU+1 OF A. C ML LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). C MU UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). C OUTPUT.. C A AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. C IP INDEX VECTOR OF PIVOT INDICES. C IP(N) (-1)**(NUMBER OF INTERCHANGES) OR O . C IER = 0 IF MATRIX A IS NONSINGULAR, OR = K IF FOUND TO BE C SINGULAR AT STAGE K. C USE SOLradB TO OBTAIN SOLUTION OF LINEAR SYSTEM. C DETERM(A) = IP(N)*A(MD,1)*A(MD,2)*...*A(MD,N) WITH MD=ML+MU+1. C IF IP(N)=O, A IS SINGULAR, SOLradB WILL DIVIDE BY ZERO. C C REFERENCE.. C THIS IS A MODIFICATION OF C C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, C C.A.C.M. 15 (1972), P. 274. C----------------------------------------------------------------------- IER = 0 IP(N) = 1 MD = ML + MU + 1 MD1 = MD + 1 JU = 0 IF (ML .EQ. 0) GO TO 70 IF (N .EQ. 1) GO TO 70 IF (N .LT. MU+2) GO TO 7 DO 6 J = MU+2,N DO 5 I = 1,ML A(I,J) = 0.D0 5 CONTINUE 6 CONTINUE 7 NM1 = N - 1 DO 60 K = 1,NM1 KP1 = K + 1 M = MD MDL = MIN(ML,N-K) + MD DO 10 I = MD1,MDL IF (DABS(A(I,K)) .GT. DABS(A(M,K))) M = I 10 CONTINUE IP(K) = M + K - MD T = A(M,K) IF (M .EQ. MD) GO TO 20 IP(N) = -IP(N) A(M,K) = A(MD,K) A(MD,K) = T 20 CONTINUE IF (T .EQ. 0.D0) GO TO 80 T = 1.D0/T DO 30 I = MD1,MDL A(I,K) = -A(I,K)*T 30 CONTINUE JU = MIN0(MAX0(JU,MU+IP(K)),N) MM = MD IF (JU .LT. KP1) GO TO 55 DO 50 J = KP1,JU M = M - 1 MM = MM - 1 T = A(M,J) IF (M .EQ. MM) GO TO 35 A(M,J) = A(MM,J) A(MM,J) = T 35 CONTINUE IF (T .EQ. 0.D0) GO TO 45 JK = J - K DO 40 I = MD1,MDL IJK = I - JK A(IJK,J) = A(IJK,J) + A(I,K)*T 40 CONTINUE 45 CONTINUE 50 CONTINUE 55 CONTINUE 60 CONTINUE 70 K = N IF (A(MD,N) .EQ. 0.D0) GO TO 80 RETURN 80 IER = K IP(N) = 0 RETURN C----------------------- END OF SUBROUTINE DECradB ------------------------ END C C SUBROUTINE SOLradB (N, NDIM, A, ML, MU, B, IP) REAL(KIND=8) A,B,T DIMENSION A(NDIM,N), B(N), IP(N) C----------------------------------------------------------------------- C SOLUTION OF LINEAR SYSTEM, A*X = B . C INPUT.. C N ORDER OF MATRIX A. C NDIM DECLARED DIMENSION OF ARRAY A . C A TRIANGULARIZED MATRIX OBTAINED FROM DECradB. C ML LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). C MU UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). C B RIGHT HAND SIDE VECTOR. C IP PIVOT VECTOR OBTAINED FROM DECradB. C DO NOT USE IF DECradB HAS SET IER .NE. 0. C OUTPUT.. C B SOLUTION VECTOR, X . C----------------------------------------------------------------------- MD = ML + MU + 1 MD1 = MD + 1 MDM = MD - 1 NM1 = N - 1 IF (ML .EQ. 0) GO TO 25 IF (N .EQ. 1) GO TO 50 DO 20 K = 1,NM1 M = IP(K) T = B(M) B(M) = B(K) B(K) = T MDL = MIN(ML,N-K) + MD DO 10 I = MD1,MDL IMD = I + K - MD B(IMD) = B(IMD) + A(I,K)*T 10 CONTINUE 20 CONTINUE 25 CONTINUE DO 40 KB = 1,NM1 K = N + 1 - KB B(K) = B(K)/A(MD,K) T = -B(K) KMD = MD - K LM = MAX0(1,KMD+1) DO 30 I = LM,MDM IMD = I - KMD B(IMD) = B(IMD) + A(I,K)*T 30 CONTINUE 40 CONTINUE 50 B(1) = B(1)/A(MD,1) RETURN C----------------------- END OF SUBROUTINE SOLradB ------------------------ END C SUBROUTINE DECBC (N, NDIM, AR, AI, ML, MU, IP, IER) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION AR(NDIM,N), AI(NDIM,N), IP(N) C----------------------------------------------------------------------- C MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION OF A BANDED COMPLEX C MATRIX WITH LOWER BANDWIDTH ML AND UPPER BANDWIDTH MU C INPUT.. C N ORDER OF THE ORIGINAL MATRIX A. C NDIM DECLARED DIMENSION OF ARRAY A. C AR, AI CONTAINS THE MATRIX IN BAND STORAGE. THE COLUMNS C OF THE MATRIX ARE STORED IN THE COLUMNS OF AR (REAL C PART) AND AI (IMAGINARY PART) AND C THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS C ML+1 THROUGH 2*ML+MU+1 OF AR AND AI. C ML LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). C MU UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). C OUTPUT.. C AR, AI AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. C IP INDEX VECTOR OF PIVOT INDICES. C IP(N) (-1)**(NUMBER OF INTERCHANGES) OR O . C IER = 0 IF MATRIX A IS NONSINGULAR, OR = K IF FOUND TO BE C SINGULAR AT STAGE K. C USE SOLBC TO OBTAIN SOLUTION OF LINEAR SYSTEM. C DETERM(A) = IP(N)*A(MD,1)*A(MD,2)*...*A(MD,N) WITH MD=ML+MU+1. C IF IP(N)=O, A IS SINGULAR, SOLBC WILL DIVIDE BY ZERO. C C REFERENCE.. C THIS IS A MODIFICATION OF C C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, C C.A.C.M. 15 (1972), P. 274. C----------------------------------------------------------------------- IER = 0 IP(N) = 1 MD = ML + MU + 1 MD1 = MD + 1 JU = 0 IF (ML .EQ. 0) GO TO 70 IF (N .EQ. 1) GO TO 70 IF (N .LT. MU+2) GO TO 7 DO 6 J = MU+2,N DO 5 I = 1,ML AR(I,J) = 0.D0 AI(I,J) = 0.D0 5 CONTINUE 6 CONTINUE 7 NM1 = N - 1 DO 60 K = 1,NM1 KP1 = K + 1 M = MD MDL = MIN(ML,N-K) + MD DO 10 I = MD1,MDL IF (DABS(AR(I,K))+DABS(AI(I,K)) .GT. & DABS(AR(M,K))+DABS(AI(M,K))) M = I 10 CONTINUE IP(K) = M + K - MD TR = AR(M,K) TI = AI(M,K) IF (M .EQ. MD) GO TO 20 IP(N) = -IP(N) AR(M,K) = AR(MD,K) AI(M,K) = AI(MD,K) AR(MD,K) = TR AI(MD,K) = TI 20 IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 80 DEN=TR*TR+TI*TI TR=TR/DEN TI=-TI/DEN DO 30 I = MD1,MDL PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI AR(I,K)=-PRODR AI(I,K)=-PRODI 30 CONTINUE JU = MIN0(MAX0(JU,MU+IP(K)),N) MM = MD IF (JU .LT. KP1) GO TO 55 DO 50 J = KP1,JU M = M - 1 MM = MM - 1 TR = AR(M,J) TI = AI(M,J) IF (M .EQ. MM) GO TO 35 AR(M,J) = AR(MM,J) AI(M,J) = AI(MM,J) AR(MM,J) = TR AI(MM,J) = TI 35 CONTINUE IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 48 JK = J - K IF (TI .EQ. 0.D0) THEN DO 40 I = MD1,MDL IJK = I - JK PRODR=AR(I,K)*TR PRODI=AI(I,K)*TR AR(IJK,J) = AR(IJK,J) + PRODR AI(IJK,J) = AI(IJK,J) + PRODI 40 CONTINUE GO TO 48 END IF IF (TR .EQ. 0.D0) THEN DO 45 I = MD1,MDL IJK = I - JK PRODR=-AI(I,K)*TI PRODI=AR(I,K)*TI AR(IJK,J) = AR(IJK,J) + PRODR AI(IJK,J) = AI(IJK,J) + PRODI 45 CONTINUE GO TO 48 END IF DO 47 I = MD1,MDL IJK = I - JK PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI AR(IJK,J) = AR(IJK,J) + PRODR AI(IJK,J) = AI(IJK,J) + PRODI 47 CONTINUE 48 CONTINUE 50 CONTINUE 55 CONTINUE 60 CONTINUE 70 K = N IF (DABS(AR(MD,N))+DABS(AI(MD,N)) .EQ. 0.D0) GO TO 80 RETURN 80 IER = K IP(N) = 0 RETURN C----------------------- END OF SUBROUTINE DECBC ------------------------ END C C SUBROUTINE SOLBC (N, NDIM, AR, AI, ML, MU, BR, BI, IP) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION AR(NDIM,N), AI(NDIM,N), BR(N), BI(N), IP(N) C----------------------------------------------------------------------- C SOLUTION OF LINEAR SYSTEM, A*X = B , C VERSION BANDED AND COMPLEX-DOUBLE PRECISION. C INPUT.. C N ORDER OF MATRIX A. C NDIM DECLARED DIMENSION OF ARRAY A . C AR, AI TRIANGULARIZED MATRIX OBTAINED FROM DECradB (REAL AND IMAG. PART). C ML LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). C MU UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). C BR, BI RIGHT HAND SIDE VECTOR (REAL AND IMAG. PART). C IP PIVOT VECTOR OBTAINED FROM DECBC. C DO NOT USE IF DECradB HAS SET IER .NE. 0. C OUTPUT.. C BR, BI SOLUTION VECTOR, X (REAL AND IMAG. PART). C----------------------------------------------------------------------- MD = ML + MU + 1 MD1 = MD + 1 MDM = MD - 1 NM1 = N - 1 IF (ML .EQ. 0) GO TO 25 IF (N .EQ. 1) GO TO 50 DO 20 K = 1,NM1 M = IP(K) TR = BR(M) TI = BI(M) BR(M) = BR(K) BI(M) = BI(K) BR(K) = TR BI(K) = TI MDL = MIN(ML,N-K) + MD DO 10 I = MD1,MDL IMD = I + K - MD PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI BR(IMD) = BR(IMD) + PRODR BI(IMD) = BI(IMD) + PRODI 10 CONTINUE 20 CONTINUE 25 CONTINUE DO 40 KB = 1,NM1 K = N + 1 - KB DEN=AR(MD,K)*AR(MD,K)+AI(MD,K)*AI(MD,K) PRODR=BR(K)*AR(MD,K)+BI(K)*AI(MD,K) PRODI=BI(K)*AR(MD,K)-BR(K)*AI(MD,K) BR(K)=PRODR/DEN BI(K)=PRODI/DEN TR = -BR(K) TI = -BI(K) KMD = MD - K LM = MAX0(1,KMD+1) DO 30 I = LM,MDM IMD = I - KMD PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI BR(IMD) = BR(IMD) + PRODR BI(IMD) = BI(IMD) + PRODI 30 CONTINUE 40 CONTINUE DEN=AR(MD,1)*AR(MD,1)+AI(MD,1)*AI(MD,1) PRODR=BR(1)*AR(MD,1)+BI(1)*AI(MD,1) PRODI=BI(1)*AR(MD,1)-BR(1)*AI(MD,1) BR(1)=PRODR/DEN BI(1)=PRODI/DEN 50 CONTINUE RETURN C----------------------- END OF SUBROUTINE SOLBC ------------------------ END c C subroutine elmhes(nm,n,low,igh,a,int) C integer i,j,m,n,la,nm,igh,kp1,low,mm1,mp1 real(kind=8) a(nm,n) real(kind=8) x,y real(kind=8) dabs integer int(igh) C C this subroutine is a translation of the algol procedure elmhes, C num. math. 12, 349-368(1968) by martin and wilkinson. C handbook for auto. comp., vol.ii-linear algebra, 339-358(1971). C C given a real general matrix, this subroutine C reduces a submatrix situated in rows and columns C low through igh to upper hessenberg form by C stabilized elementary similarity transformations. C C on input: C C nm must be set to the row dimension of two-dimensional C array parameters as declared in the calling program C dimension statement; C C n is the order of the matrix; C C low and igh are integers determined by the balancing C subroutine balanc. if balanc has not been used, C set low=1, igh=n; C C a contains the input matrix. C C on output: C C a contains the hessenberg matrix. the multipliers C which were used in the reduction are stored in the C remaining triangle under the hessenberg matrix; C C int contains information on the rows and columns C interchanged in the reduction. C only elements low through igh are used. C C questions and comments should be directed to b. s. garbow, C applied mathematics division, argonne national laboratory C C ------------------------------------------------------------------ C la = igh - 1 kp1 = low + 1 if (la .lt. kp1) go to 200 C do 180 m = kp1, la mm1 = m - 1 x = 0.0d0 i = m C do 100 j = m, igh if (dabs(a(j,mm1)) .le. dabs(x)) go to 100 x = a(j,mm1) i = j 100 continue C int(m) = i if (i .eq. m) go to 130 C :::::::::: interchange rows and columns of a :::::::::: do 110 j = mm1, n y = a(i,j) a(i,j) = a(m,j) a(m,j) = y 110 continue C do 120 j = 1, igh y = a(j,i) a(j,i) = a(j,m) a(j,m) = y 120 continue C :::::::::: end interchange :::::::::: 130 if (x .eq. 0.0d0) go to 180 mp1 = m + 1 C do 160 i = mp1, igh y = a(i,mm1) if (y .eq. 0.0d0) go to 160 y = y / x a(i,mm1) = y C do 140 j = m, n a(i,j) = a(i,j) - y * a(m,j) 140 continue C do 150 j = 1, igh a(j,m) = a(j,m) + y * a(j,i) 150 continue C 160 continue C 180 continue C 200 return C :::::::::: last card of elmhes :::::::::: end deSolve/src/Makevars0000644000176000001440000000003713136461013014164 0ustar ripleyusersPKG_LIBS=$(BLAS_LIBS) $(FLIBS) deSolve/src/call_radau.c0000644000176000001440000004630513274246417014747 0ustar ripleyusers#include #include #include "deSolve.h" #include "externalptr.h" /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ RADAU: Implicit runge-Kutta of order 5 due to Hairer and Wanner, with stepsize control and dense output The C-wrappers that provide the interface between FORTRAN codes and R-code are: C_deriv_func_rad: interface with R-code "func", passes derivatives C_deriv_out_rad : interface with R-code "func", passes derivatives + output variables C_deriv_func_forc_rad provides the interface between the function specified in a DLL and the integrator, in case there are forcing functions. version 1.9.1: added time lags -> delay differential equations added root function added events version 1.10: mass matrix for func in a DLL karline soetaert +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ /* globals for radau */ int maxt, it, nout, isDll, ntot; double *xdytmp, *ytmp, *tt, *rwork, *root, *oldroot; int *iwork, *jroot; int iroot, nroot, nr_root, islag, isroot, isEvent, endsim; double tin, tprevroot; typedef void C_root_func_type (int *, double *, double *,int *, double *); C_root_func_type *root_func = NULL; C_deriv_func_type *deriv_func; /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ definition of the calls to the FORTRAN subroutines in file radau.f */ void F77_NAME(radau5)( int *, void (*)(int *, double *, double *, double *, double *, int *), // func double *, double *, double *, double *, double *, double *, int *, void (*)(int *, double *, double *, int *, int *, double *, int *, double *, int *), // jac int *, int *, int *, void (*)(int *, double *, int *, double *, int *), // mas int *, int *, int *, void (*)(int *, double *, double *, double *, double *, int *, int *, double *, int *, int *, double *), // soloutrad int *, double *, int *, int *, int*, double *, int*, int*); /* continuous output formula for radau (used in radau.c and lags.c) */ void F77_NAME (contr5) (int *, double *, double *, int *, double *); /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ interface R with FORTRAN functions */ /* wrapper above the derivate function in a dll that first estimates the values of the forcing functions */ static void C_deriv_func_forc_rad (int *neq, double *t, double *y, double *ydot, double *yout, int *iout) { updatedeforc(t); DLL_deriv_func(neq, t, y, ydot, yout, iout); } /* Fortran code calls C_deriv_func_rad(N, t, y, ydot, yout, iout) R code called as R_deriv_func(time, y) and returns ydot */ static void C_deriv_func_rad (int *neq, double *t, double *y, double *ydot, double *yout, int *iout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); PROTECT(R_fcall = lang3(R_deriv_func,Time,Y)); PROTECT(ans = eval(R_fcall, R_envir)); for (i = 0; i < *neq; i++) ydot[i] = REAL(ans)[i]; UNPROTECT(3); } /* mass matrix function */ static void C_mas_func_rad (int *neq, double *am, int *lmas, double *yout, int *iout) { int i; SEXP NEQ, LM, R_fcall, ans; PROTECT(NEQ = NEW_INTEGER(1)); PROTECT(LM = NEW_INTEGER(1)); INTEGER(NEQ)[0] = *neq; INTEGER(LM) [0] = *lmas; PROTECT(R_fcall = lang3(R_mas_func,NEQ,LM)); PROTECT(ans = eval(R_fcall, R_envir)); for (i = 0; i <*lmas * *neq; i++) am[i] = REAL(ans)[i]; UNPROTECT(4); } /* deriv output function - for ordinary output variables */ static void C_deriv_out_rad (int *nOut, double *t, double *y, double *ydot, double *yout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < n_eq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); PROTECT(R_fcall = lang3(R_deriv_func,Time, Y)); PROTECT(ans = eval(R_fcall, R_envir)); for (i = 0; i < *nOut; i++) yout[i] = REAL(ans)[i + n_eq]; UNPROTECT(3); } /* save output in R-variables */ static void saveOut (double t, double *y) { int j; REAL(YOUT)[(it)*(ntot+1)] = t; for (j = 0; j < n_eq; j++) REAL(YOUT)[(it)*(ntot + 1) + j + 1] = y[j]; /* if ordinary output variables: call function again */ if (nout>0) { if (isDll == 1) /* output function in DLL */ deriv_func (&n_eq, &t, y, xdytmp, out, ipar) ; else C_deriv_out_rad(&nout, &t, y, xdytmp, out); for (j = 0; j < nout; j++) REAL(YOUT)[(it)*(ntot + 1) + j + n_eq + 1] = out[j]; } } /* save lagged variables */ static void C_saveLag(int ini, double *t, double *y, double *con, int *lrc, double *rpar, int *ipar) { /* estimate dy (xdytmp) */ if (isDll == 1) deriv_func (&n_eq, t, y, xdytmp, rpar, ipar) ; else C_deriv_func_rad (&n_eq, t, y, xdytmp, rpar, ipar) ; if (ini == 1) updatehistini(*t, y, xdytmp, rpar, ipar); else updatehist(*t, y, xdytmp, con, lrc); } /* root function */ static void C_root_radau (int *neq, double *t, double *y, int *ng, double *gout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); PROTECT(R_fcall = lang3(R_root_func,Time,Y)); PROTECT(ans = eval(R_fcall, R_envir)); for (i = 0; i < *ng; i++) gout[i] = REAL(ans)[i]; UNPROTECT(3); } /* function for brent's root finding algorithm */ double f (double t, double *Con, int *Lrc) { F77_CALL(contr5) (&n_eq, &t, Con, Lrc, ytmp); /* ytmp = value of y at t */ if (isDll == 1) root_func (&n_eq, &t, ytmp, &nroot, root); /* root at t, ytmp */ else C_root_radau (&n_eq, &t, ytmp, &nroot, root); return root[iroot] ; } /* function called by Fortran to check for output, lags, events, roots */ static void C_soloutrad(int * nr, double * told, double * t, double * y, double * con, int * lrc, int * neq, double * rpar, int * ipar, int * irtrn, double * xout) { int i, j; int istate, iterm; double tr, tmin; double tol = 1e-9; /* Acceptable tolerance */ int maxit = 100; /* Max # of iterations */ extern double brent(double, double, double, double, double (double, double *, int *), double *, int *, double, int); if (*told == *t) return; timesteps[0] = *told-*t; timesteps[1] = *told-*t; if (islag == 1) C_saveLag(0, t, y, con, lrc, rpar, ipar); *irtrn = 0; if (isEvent && ! rootevent) { if (*told <= tEvent && tEvent < *t) { tin = tEvent; F77_CALL(contr5) (&n_eq, &tEvent, con, lrc, y); updateevent(&tin, y, &istate); *irtrn = -1; } } tmin = *t; iroot = -1; if (isroot & (fabs(*t - tprevroot) > tol)) { if (isDll == 1) root_func (&n_eq, t, y, &nroot, root); /* root at t, ytmp */ else C_root_radau (&n_eq, t, y, &nroot, root); for (i = 0; i < nroot; i++) if (fabs(root[i]) < tol) { iroot = i; jroot[i] = 1; *irtrn = -1; endsim = 1; tprevroot = *t; } else if (fabs(oldroot[i]) >= tol && root[i] * oldroot[i] < 0) { iroot = i; jroot[i] = 1; tr = brent(*told, *t, oldroot[i], root[i], f, con, lrc, tol, maxit); if (fabs(tprevroot - tr) > tol) { F77_CALL(contr5) (&n_eq, &tr, con, lrc, ytmp); *irtrn = -1; endsim = 1; if (tr < tmin) { tmin = tr; tprevroot = tmin; for (j = 0; j < n_eq; j++) y[j] = ytmp[j]; } } } else jroot[i] = 0; for (i = 0; i < nroot; i++) oldroot[i] = root[i]; } while (*told <= tt[it] && tt[it] < tmin) { F77_CALL(contr5) (neq, &tt[it], con, lrc, ytmp); saveOut(tt[it], ytmp); it++; if ( it >= maxt) break; } if ((*irtrn == -1) && rootevent) { *t = tmin; tin = *t; tEvent = tin; if (nr_root < Rootsave) { troot[nr_root] = tin; for (j = 0; j < nroot; j++) if (jroot[j] == 1) nrroot[nr_root] = j+1; for (j = 0; j < n_eq; j++) valroot[nr_root* n_eq + j] = y[j]; } iterm = 0; /* check if simulation should be terminated */ for (j = 0; j < nroot; j++) if (jroot[j] == 1 && termroot[j] == 1) iterm = 1; if (iterm == 0) { nr_root++; updateevent(&tin, y, &istate); endsim = 0; } else { endsim = 1; } } } /* interface to jacobian function */ static void C_jac_func_rad(int *neq, double *t, double *y, int *ml, int *mu, double *pd, int *nrowpd, double *yout, int *iout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); PROTECT(R_fcall = lang3(R_jac_func,Time,Y)); PROTECT(ans = eval(R_fcall, R_envir)); for (i = 0; i < *neq * *nrowpd; i++) pd[i] = REAL(ans)[i]; UNPROTECT(3); } /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ give name to data types */ typedef void C_solout_type (int *, double *, double *, double *, double *, int *, int *, double *, int *, int *, double *) ; typedef void C_mas_type (int *, double *, int *, double *, int *); // to be changed... typedef void C_jac_func_type_rad(int *, double *, double *, int *, int *, double *, int*, double *, int *); /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ MAIN C-FUNCTION, CALLED FROM R-code */ SEXP call_radau(SEXP y, SEXP times, SEXP derivfunc, SEXP masfunc, SEXP jacfunc, SEXP parms, SEXP rtol, SEXP atol, SEXP Nrjac, SEXP Nrmas, SEXP rho, SEXP initfunc, SEXP rWork, SEXP iWork, SEXP nOut, SEXP lRw, SEXP lIw, SEXP Rpar, SEXP Ipar, SEXP Hini, SEXP flist, SEXP elag, SEXP rootfunc, SEXP nRoot, SEXP eventfunc, SEXP elist ) { /******************************************************************************/ /****** DECLARATION SECTION ******/ /******************************************************************************/ int j, nt, latol, lrtol, lrw, liw, ijac, mljac, mujac, imas, mlmas, mumas; int isForcing; double *xytmp, tout, *Atol, *Rtol, hini=0; int itol, iout, idid; int nprot = 0; SEXP TROOT, NROOT, VROOT, IROOT; /* pointers to functions passed to FORTRAN */ C_solout_type *solout = NULL; C_jac_func_type_rad *jac_func = NULL; C_mas_type *mas_func = NULL; /******************************************************************************/ /****** STATEMENTS ******/ /******************************************************************************/ /* #### initialisation #### */ lock_solver(); /* prevent nested call of solvers that have global variables */ n_eq = LENGTH(y); /* number of equations */ nt = LENGTH(times); /* number of output times */ maxt = nt; nroot = INTEGER(nRoot)[0]; /* number of roots */ isroot = 0; nr_root = 0; if (nroot > 0) isroot = 1; tt = (double *) R_alloc(nt, sizeof(double)); for (j = 0; j < nt; j++) tt[j] = REAL(times)[j]; ijac = INTEGER(Nrjac)[0]; mljac = INTEGER(Nrjac)[1]; mujac = INTEGER(Nrjac)[2]; imas = INTEGER(Nrmas)[0]; mlmas = INTEGER(Nrmas)[1]; mumas = INTEGER(Nrmas)[2]; /* is function a dll ?*/ isDll = inherits(derivfunc, "NativeSymbol"); /* initialise output ... */ initOutC(isDll, &nout, &ntot, n_eq, nOut, Rpar, Ipar); /* copies of variables that will be changed in the FORTRAN subroutine */ xytmp = (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) xytmp[j] = REAL(y)[j]; ytmp = (double *) R_alloc(n_eq, sizeof(double)); latol = LENGTH(atol); Atol = (double *) R_alloc((int) latol, sizeof(double)); for (j = 0; j < latol; j++) Atol[j] = REAL(atol)[j]; lrtol = LENGTH(rtol); Rtol = (double *) R_alloc((int) lrtol, sizeof(double)); for (j = 0; j < lrtol; j++) Rtol[j] = REAL(rtol)[j]; /* tolerance specifications */ if (latol == 1 ) itol = 0; else itol = 1; hini = REAL(Hini)[0]; /* work vectors */ liw = INTEGER (lIw)[0]; iwork = (int *) R_alloc(liw, sizeof(int)); for (j=0; j 0 || islag) { xdytmp= (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) xdytmp[j] = 0.; } /* pointers to functions deriv_func, jac_func, passed to FORTRAN */ if (isDll) { /* DLL address passed to FORTRAN */ deriv_func = (C_deriv_func_type *) R_ExternalPtrAddrFn_(derivfunc); /* overruling deriv_func if forcing */ if (isForcing) { DLL_deriv_func = deriv_func; deriv_func = (C_deriv_func_type *) C_deriv_func_forc_rad; } } else { /* interface function between FORTRAN and C/R passed to FORTRAN */ deriv_func = (C_deriv_func_type *) C_deriv_func_rad; /* needed to communicate with R */ R_deriv_func = derivfunc; } R_envir = rho; /* karline: this to allow merging compiled and R-code (e.g. events)*/ if (!isNull(jacfunc)) { if (isDll) jac_func = (C_jac_func_type_rad *) R_ExternalPtrAddrFn_(jacfunc); else { R_jac_func = jacfunc; jac_func= C_jac_func_rad; } } if (!isNull(masfunc)) { R_mas_func = masfunc; mas_func= C_mas_func_rad; if (isDll) R_envir = rho; } solout = C_soloutrad; iout = 2; /* solout called after each step OR 1???*/ idid = 0; /* #### integration #### */ it = 0; tin = REAL(times)[0]; tout = REAL(times)[nt-1]; saveOut (tin, xytmp); /* save initial condition */ it++; if (nroot > 0) { /* also must find a root */ jroot = (int *) R_alloc(nroot, sizeof(int)); for (j = 0; j < nroot; j++) jroot[j] = 0; root = (double *) R_alloc(nroot, sizeof(double)); oldroot = (double *) R_alloc(nroot, sizeof(double)); if (isDll) { root_func = (C_root_func_type *) R_ExternalPtrAddrFn_(rootfunc); } else { root_func = (C_root_func_type *) C_root_radau; R_root_func = rootfunc; } /* value of oldroot */ if (isDll == 1) root_func (&n_eq, &tin, xytmp, &nroot, oldroot); /* root at t, ytmp */ else C_root_radau (&n_eq, &tin, xytmp, &nroot, oldroot); tprevroot = tin; /* to make sure that roots are not too close */ } endsim = 0; do { if (islag == 1) C_saveLag(1, &tin, xytmp, out, ipar, out, ipar); F77_CALL(radau5) ( &n_eq, deriv_func, &tin, xytmp, &tout, &hini, Rtol, Atol, &itol, jac_func, &ijac, &mljac, &mujac, mas_func, &imas, &mlmas, &mumas, solout, &iout, rwork, &lrw, iwork, &liw, out, ipar, &idid); } while (tin < tout && idid >= 0 && endsim == 0); if (idid == -1) warning("input is not consistent"); else if (idid == -2) warning("larger maxsteps needed"); else if (idid == -3) warning("step size becomes too small"); else if (idid == -4) warning("problem is probably stiff - interrupted"); /* #### an error occurred #### */ if(it <= nt-1) saveOut (tin, xytmp); /* save final condition */ if (idid < 0) { it = it-1; PROTECT(YOUT2 = allocMatrix(REALSXP,ntot+1,(it+2))); nprot++; returnearly (1, it, ntot); } else if (idid == 2) { it = it-1; PROTECT(YOUT2 = allocMatrix(REALSXP,ntot+1,(it+2))); nprot++; returnearly (0, it, ntot); idid = -2; } /* #### returning output #### */ rwork[0] = hini; rwork[1] = tin ; PROTECT(ISTATE = allocVector(INTSXP, 7)); nprot++; PROTECT(RWORK = allocVector(REALSXP, 5)); nprot++; terminate(idid,iwork,7,13,rwork,5,0); if (iroot >= 0 || nr_root > 0) { PROTECT(IROOT = allocVector(INTSXP, nroot)); nprot++; for (j = 0; j < nroot; j++) INTEGER(IROOT)[j] = jroot[j]; PROTECT(NROOT = allocVector(INTSXP, 1)); nprot++; INTEGER(NROOT)[0] = nr_root; if (nr_root == 0) { PROTECT(TROOT = allocVector(REALSXP, 1)); nprot++; REAL(TROOT)[0] = tin; } else { if (nr_root > Rootsave) nr_root = Rootsave; PROTECT(TROOT = allocVector(REALSXP, nr_root)); nprot++; for (j = 0; j < nr_root; j++) REAL(TROOT)[j] = troot[j]; PROTECT(VROOT = allocVector(REALSXP, nr_root*n_eq)); nprot++; for (j = 0; j < nr_root*n_eq; j++) REAL(VROOT)[j] = valroot[j]; PROTECT(IROOT = allocVector(INTSXP, nr_root)); nprot++; for (j = 0; j < nr_root; j++) INTEGER(IROOT)[j] = nrroot[j]; if (idid == 1) { setAttrib(YOUT, install("valroot"), VROOT); setAttrib(YOUT, install("indroot"), IROOT); } else { setAttrib(YOUT2, install("valroot"), VROOT); setAttrib(YOUT2, install("indroot"), IROOT); } } if (idid == 1 ) { setAttrib(YOUT, install("troot"), TROOT); setAttrib(YOUT, install("nroot"), NROOT); } else { setAttrib(YOUT2, install("iroot"), IROOT); setAttrib(YOUT2, install("troot"), TROOT); setAttrib(YOUT2, install("nroot"), NROOT); } } /* #### termination #### */ unlock_solver(); UNPROTECT(nprot); // thpe: after reworking PROTECT/UNPROTECT, I checked how YOUT, YOUT2 is handled // and see that the following is not consistent, because YOUT is only set when idid==1 // Is this a (still) hidden bug? // // original version // if (idid > 0) // return(YOUT); // else // return(YOUT2); // thpe: test version (currently disabled) if (idid > 0) return(YOUT); else return(YOUT2); } deSolve/src/rprintf.c0000644000176000001440000000222513507471346014335 0ustar ripleyusers#define USE_FC_LEN_T #include #ifdef FC_LEN_T # include // for size_t if needed # define FCLEN ,FC_LEN_T msg_len #else # define FCLEN #endif void F77_SUB(rprintf)(const char* msg FCLEN) { Rprintf(msg); Rprintf("\n"); } void F77_SUB(rprintfid)(const char* msg, int *i, double *d FCLEN) { Rprintf(msg, *i, *d); Rprintf("\n"); } void F77_SUB(rprintfdi)(const char* msg, double *d, int *i FCLEN) { Rprintf(msg, *d, *i); Rprintf("\n"); } void F77_SUB(rprintfdid)(const char* msg, double *d1, int *i, double *d2 FCLEN) { Rprintf(msg, *d1, *i, *d2); Rprintf("\n"); } void F77_SUB(rprintfd1)(const char* msg, double *d FCLEN) { Rprintf(msg, *d); Rprintf("\n"); } void F77_SUB(rprintfd2)(const char* msg, double *d1, double *d2 FCLEN) { Rprintf(msg, *d1, *d2); Rprintf("\n"); } void F77_SUB(rprintfi1)(const char* msg, int *i FCLEN) { Rprintf(msg, *i); Rprintf("\n"); } void F77_SUB(rprintfi2)(const char* msg, int *i1, int *i2 FCLEN) { Rprintf(msg, *i1, *i2); Rprintf("\n"); } void F77_SUB(rprintfi3)(const char* msg, int *i1, int *i2, int* i3 FCLEN) { Rprintf(msg, *i1, *i2, *i3); Rprintf("\n"); } deSolve/src/dlsoder.f0000644000176000001440000020416313572134421014305 0ustar ripleyusersC The code in this file is based on ODEPACK from netlib C https://www.netlib.org/odepack/ C C Original author: Alan C. Hindmarsh C C Created by merging DLSODE with DLSODAR by Karline Soetaert C for use in R package deSolve. C *DECK DLSODER C DLSODER was created by merging DLSODE with DLSODAR - Karline Soetaert SUBROUTINE DLSODER (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF, 2 G, NG, JROOT, rpar, ipar) IMPLICIT NONE EXTERNAL F, JAC, G CKS: added rpar, ipar, and G INTEGER ipar(*) DOUBLE PRECISION rpar(*) INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF INTEGER NG, JROOT DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW), 1 JROOT(NG) C----------------------------------------------------------------------- C***BEGIN PROLOGUE DLSODER C***PURPOSE Livermore Solver for Ordinary Differential Equations. C DLSODER solves the initial-value problem for stiff or C nonstiff systems of first-order ODE's, C dy/dt = f(t,y), or, in component form, C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(N)), i=1,...,N. C and with Root-finding. C***CATEGORY I1A C***TYPE DOUBLE PRECISION (SLSODE-S, DLSODE-D) C***KEYWORDS ORDINARY DIFFERENTIAL EQUATIONS, INITIAL VALUE PROBLEM, C STIFF, NONSTIFF C***AUTHOR Hindmarsh, Alan C., (LLNL) C Center for Applied Scientific Computing, L-561 C Lawrence Livermore National Laboratory C Livermore, CA 94551. C Root function added by Karline Soetaert C***DESCRIPTION - see DLSODE and DLSODAR C Note: length of RWORK array = 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM + 3*NG. C C----------------------------------------------------------------------- C Declare externals. EXTERNAL DPREPJ, DSOLSY DOUBLE PRECISION DUMACH, DVNORM C C Declare all other variables. INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C KS: added next line INTEGER LG0, LG1, LGX, IMAX, LAST, IRFND, ITASKC, NGC, NGE INTEGER I, I1, I2, IFLAG, IMXER, KGO, LF0, 1 LENIW, LENRW, LENWM, ML, MORD, MU, MXHNL0, MXSTP0 INTEGER IRFP, IRT, LENYH, LYHNEW DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION ALPHA, X2, T0, TLAST, TOUTC DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 DIMENSION MORD(2) LOGICAL IHIT CHARACTER(LEN=80) MSG SAVE MORD, MXSTP0, MXHNL0 C----------------------------------------------------------------------- C The following internal Common block contains C (a) variables which are local to any subroutine but whose values must C be preserved between calls to the routine ("own" variables), and C (b) variables which are communicated between subroutines. C The block DLS001 is declared in subroutines DLSODER, DINTDY, DSTODE, C DPREPJ, and DSOLSY. C The block DLSR01 is declared in subroutines DLSODAR, DRCHEK, DROOTS. C Groups of variables are replaced by dummy arrays in the Common C declarations in routines where those variables are not used. C----------------------------------------------------------------------- COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C karline: added next common block COMMON /DLSR01/ ALPHA, X2, T0, TLAST, TOUTC, 1 LG0, LG1, LGX, IMAX, LAST, IRFND, ITASKC, NGC, NGE C DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ C----------------------------------------------------------------------- C Block A. C This code block is executed on every call. C It tests ISTATE and ITASK for legality and branches appropriately. C If ISTATE .GT. 1 but the flag INIT shows that initialization has C not yet been done, an error return occurs. C If ISTATE = 1 and TOUT = T, return immediately. C----------------------------------------------------------------------- C KARLINE: INITIALISED IHIT TO AVOID COMPILER WARNINGS - SHOULD HAVE NO EFFEXT IHIT = .TRUE. C***FIRST EXECUTABLE STATEMENT DLSODER IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 C Karline: added next sentence ITASKC = ITASK IF (ISTATE .EQ. 1) GO TO 10 IF (INIT .EQ. 0) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) RETURN C----------------------------------------------------------------------- C Block B. C The next code block is executed for the initial call (ISTATE = 1), C or for a continuation call with parameter changes (ISTATE = 3). C It contains checking of all inputs and various initializations. C C First check legality of the non-optional inputs NEQ, ITOL, IOPT, C MF, ML, MU, and NG.. C----------------------------------------------------------------------- 20 IF (NEQ(1) .LE. 0) GO TO 604 IF (ISTATE .EQ. 1) GO TO 25 IF (NEQ(1) .GT. N) GO TO 605 25 N = NEQ(1) IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 METH = MF/10 MITER = MF - 10*METH IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 IF (MITER .LE. 3) GO TO 30 ML = IWORK(1) MU = IWORK(2) IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 30 CONTINUE C karline: added next four lines IF (NG .LT. 0) GO TO 630 IF (ISTATE .EQ. 1) GO TO 35 IF (IRFND .EQ. 0 .AND. NG .NE. NGC) GO TO 631 35 NGC = NG C Next process and check the optional inputs. -------------------------- IF (IOPT .EQ. 1) GO TO 40 MAXORD = MORD(METH) MXSTEP = MXSTP0 MXHNIL = MXHNL0 IF (ISTATE .EQ. 1) H0 = 0.0D0 HMXI = 0.0D0 HMIN = 0.0D0 GO TO 60 40 MAXORD = IWORK(5) IF (MAXORD .LT. 0) GO TO 611 IF (MAXORD .EQ. 0) MAXORD = 100 MAXORD = MIN(MAXORD,MORD(METH)) MXSTEP = IWORK(6) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .NE. 1) GO TO 50 H0 = RWORK(5) IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. 0.0D0) GO TO 615 HMXI = 0.0D0 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX HMIN = RWORK(7) IF (HMIN .LT. 0.0D0) GO TO 616 C----------------------------------------------------------------------- C Set work array pointers and check lengths LRW and LIW. C Pointers to segments of RWORK and IWORK are named by prefixing L to C the name of the segment. E.g., the segment YH starts at RWORK(LYH). C Segments of RWORK (in order) are denoted G0, G1, GX, YH, WM, C EWT, SAVF, ACOR. C----------------------------------------------------------------------- CKS: init changes 60 LYH = 21 60 IF (ISTATE .EQ. 1) NYH = N LG0 = 21 LG1 = LG0 + NG LGX = LG1 + NG LYHNEW = LGX + NG IF (ISTATE .EQ. 1) LYH = LYHNEW IF (LYHNEW .EQ. LYH) GO TO 62 C If ISTATE = 3 and NG was changed, shift YH to its new location. ------ LENYH = L*NYH IF (LRW .LT. LYHNEW-1+LENYH) GO TO 62 I1 = 1 IF (LYHNEW .GT. LYH) I1 = -1 CALL DCOPY (LENYH, RWORK(LYH), I1, RWORK(LYHNEW), I1) LYH = LYHNEW 62 CONTINUE CKS end of changes LWM = LYH + (MAXORD + 1)*NYH IF (MITER .EQ. 0) LENWM = 0 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENWM = N*N + 2 IF (MITER .EQ. 3) LENWM = N + 2 IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 LEWT = LWM + LENWM LSAVF = LEWT + N LACOR = LSAVF + N LENRW = LACOR + N - 1 IWORK(17) = LENRW LIWM = 1 LENIW = 20 + N IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 20 IWORK(18) = LENIW IF (LENRW .GT. LRW) GO TO 617 IF (LENIW .GT. LIW) GO TO 618 C Check RTOL and ATOL for legality. ------------------------------------ RTOLI = RTOL(1) ATOLI = ATOL(1) DO 70 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. 0.0D0) GO TO 619 IF (ATOLI .LT. 0.0D0) GO TO 620 70 CONTINUE IF (ISTATE .EQ. 1) GO TO 100 C If ISTATE = 3, set flag to signal parameter changes to DSTODE. ------- JSTART = -1 IF (NQ .LE. MAXORD) GO TO 90 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- DO 80 I = 1,N RWORK(I+LSAVF-1) = RWORK(I+LWM-1) 80 CONTINUE C Reload WM(1) = RWORK(LWM), since LWM may have changed. --------------- 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) IF (N .EQ. NYH) GO TO 200 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- I1 = LYH + L*NYH I2 = LYH + (MAXORD + 1)*NYH - 1 IF (I1 .GT. I2) GO TO 200 DO 95 I = I1,I2 RWORK(I) = 0.0D0 95 CONTINUE GO TO 200 C----------------------------------------------------------------------- C Block C. C The next block is for the initial call only (ISTATE = 1). C It contains all remaining initializations, the initial call to F, C and the calculation of the initial step size. C The error weights in EWT are inverted after being loaded. C----------------------------------------------------------------------- 100 UROUND = DUMACH() TN = T IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 1 H0 = TCRIT - T 110 JSTART = 0 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) NHNIL = 0 NST = 0 NJE = 0 NSLAST = 0 HU = 0.0D0 NQU = 0 CCMAX = 0.3D0 MAXCOR = 3 MSBP = 20 MXNCF = 10 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- LF0 = LYH + NYH CALL F (NEQ, T, Y, RWORK(LF0), rpar, ipar) NFE = 1 C Load the initial value vector in YH. --------------------------------- DO 115 I = 1,N RWORK(I+LYH-1) = Y(I) 115 CONTINUE C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- NQ = 1 H = 1.0D0 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 120 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 120 CONTINUE C----------------------------------------------------------------------- C The coding below computes the step size, H0, to be attempted on the C first step, unless the user has supplied a value for this. C First check that TOUT - T differs significantly from zero. C A scalar tolerance quantity TOL is computed, as MAX(RTOL(I)) C if this is positive, or MAX(ATOL(I)/ABS(Y(I))) otherwise, adjusted C so as to be between 100*UROUND and 1.0E-3. C Then the computed value H0 is given by.. C NEQ C H0**2 = TOL / ( w0**-2 + (1/NEQ) * SUM ( f(i)/ywt(i) )**2 ) C 1 C where w0 = MAX ( ABS(T), ABS(TOUT) ), C f(i) = i-th component of initial value of f, C ywt(i) = EWT(i)/TOL (a weight for y(i)). C The sign of H0 is inferred from the initial values of TOUT and T. C----------------------------------------------------------------------- IF (H0 .NE. 0.0D0) GO TO 180 TDIST = ABS(TOUT - T) W0 = MAX(ABS(T),ABS(TOUT)) IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 TOL = RTOL(1) IF (ITOL .LE. 2) GO TO 140 DO 130 I = 1,N TOL = MAX(TOL,RTOL(I)) 130 CONTINUE 140 IF (TOL .GT. 0.0D0) GO TO 160 ATOLI = ATOL(1) DO 150 I = 1,N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) AYI = ABS(Y(I)) IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 150 CONTINUE 160 TOL = MAX(TOL,100.0D0*UROUND) TOL = MIN(TOL,0.001D0) SUM = DVNORM (N, RWORK(LF0), RWORK(LEWT)) SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 H0 = 1.0D0/SQRT(SUM) H0 = MIN(H0,TDIST) H0 = SIGN(H0,TOUT-T) C Adjust H0 if necessary to meet HMAX bound. --------------------------- 180 RH = ABS(H0)*HMXI IF (RH .GT. 1.0D0) H0 = H0/RH C Load H with H0 and scale YH(*,2) by H0. ------------------------------ H = H0 DO 190 I = 1,N RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 190 CONTINUE CKS: start changes GO TO 270 C C Check for a zero of g at T. ------------------------------------------ IRFND = 0 TOUTC = TOUT IF (NGC .EQ. 0) GO TO 270 CALL DRCHEK (1, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .EQ. 0) GO TO 270 GO TO 632 CKS: end changes C----------------------------------------------------------------------- C Block D. C The next code block is for continuation calls only (ISTATE = 2 or 3) C and is to check stop conditions before taking a step. C First, DRCHEK is called to check for a root within the last step C taken, other than the last root found there, if any. C If ITASK = 2 or 5, and y(TN) has not yet been returned to the user C because of an intervening root, return through Block G. C----------------------------------------------------------------------- 200 NSLAST = NST C karline: added from here IRFP = IRFND IF (NGC .EQ. 0) GO TO 205 IF (ITASK .EQ. 1 .OR. ITASK .EQ. 4) TOUTC = TOUT CALL DRCHEK (2, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .NE. 1) GO TO 205 IRFND = 1 ISTATE = 3 T = T0 GO TO 425 205 CONTINUE IRFND = 0 IF (IRFP .EQ. 1 .AND. TLAST .NE. TN .AND. ITASK .EQ. 2) GO TO 400 C karline: till here IF (ITASK .EQ. 1) THEN GOTO 210 ELSE IF (ITASK .EQ. 2) THEN GOTO 250 ELSE IF (ITASK .EQ. 3) THEN GOTO 220 ELSE IF (ITASK .EQ. 4) THEN GOTO 230 ELSE IF (ITASK .EQ. 5) THEN GOTO 240 ENDIF C GO TO (210, 250, 220, 230, 240), ITASK 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 245 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX C this in lsoda, not in lsode... IF (IHIT) T = TCRIT + karline added next line IF (IRFP .EQ. 1 .AND. TLAST .NE. TN .AND. ITASK .EQ. 5) GO TO 400 IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (ISTATE .EQ. 2) JSTART = -2 C----------------------------------------------------------------------- C Block E. C The next block is normally executed for all calls and contains C the call to the one-step core integrator DSTODE. C C This is a looping point for the integration steps. C C First check for too many steps being taken, update EWT (if not at C start of problem), check for too much accuracy being requested, and C check for H below the roundoff level in T. C----------------------------------------------------------------------- 250 CONTINUE IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 260 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 260 CONTINUE 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) IF (TOLSF .LE. 1.0D0) GO TO 280 TOLSF = TOLSF*2.0D0 IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 MSG = 'DLSODER- Warning..internal T (=R1) and H (=R2) are' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' such that in the machine, T + H = T on the next step ' CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' (H = step size). Solver will continue anyway' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 MSG = 'DLSODER- Above warning has been issued I1 times. ' CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' It will not be issued again for this problem' CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 290 CONTINUE C----------------------------------------------------------------------- C CALL DSTODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,DPREPJ,DSOLSY) C----------------------------------------------------------------------- CALL DSTODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), 2 F, JAC, DPREPJ, DSOLSY, rpar,ipar) KGO = 1 - KFLAG IF (KGO .EQ. 1) THEN GOTO 300 ELSE IF (KGO .EQ. 2) THEN GOTO 530 ELSE IF (KGO .EQ. 3) THEN GOTO 540 ENDIF C GO TO (300, 530, 540), KGO C----------------------------------------------------------------------- C Block F. C The following block handles the case of a successful return from the C core integrator (KFLAG = 0). Test for stop conditions. C Then call DRCHEK to check for a root within the last step. C Then, if no root was found, check for stop conditions. C----------------------------------------------------------------------- 300 INIT = 1 Ckarline: changed this IF (NGC .EQ. 0) GO TO 315 CALL DRCHEK (3, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .NE. 1) GO TO 315 IRFND = 1 ISTATE = 3 T = T0 GO TO 425 315 CONTINUE C karline: end of changes IF (ITASK .EQ. 1) THEN GOTO 320 ELSE IF (ITASK .EQ. 2) THEN GOTO 400 ELSE IF (ITASK .EQ. 3) THEN GOTO 330 ELSE IF (ITASK .EQ. 4) THEN GOTO 340 ELSE IF (ITASK .EQ. 5) THEN GOTO 350 ENDIF C GO TO (320, 400, 330, 340, 350), ITASK C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 320 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 GO TO 250 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 345 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) JSTART = -2 GO TO 250 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 350 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX C----------------------------------------------------------------------- C Block G. C The following block handles all successful returns from DLSODER. C If ITASK .NE. 1, Y is loaded from YH and T is set accordingly. C ISTATE is set to 2, and the optional outputs are loaded into the C work arrays before returning. C----------------------------------------------------------------------- 400 DO 410 I = 1,N Y(I) = RWORK(I+LYH-1) 410 CONTINUE T = TN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 IF (IHIT) T = TCRIT 420 ISTATE = 2 425 CONTINUE RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ C karline: added next two lines IWORK(10) = NGE TLAST = T RETURN C----------------------------------------------------------------------- C Block H. C The following block handles all unsuccessful returns other than C those for illegal input. First the error message routine is called. C If there was an error test or convergence test failure, IMXER is set. C Then Y is loaded from YH and T is set to TN. The optional outputs C are loaded into the work arrays before returning. C----------------------------------------------------------------------- C The maximum number of steps was taken before reaching TOUT. ---------- 500 MSG = 'DLSODER- At current T (=R1), MXSTEP (=I1) steps ' CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' taken on this call before reaching TOUT ' CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) ISTATE = -1 GO TO 580 C EWT(I) .LE. 0.0 for some I (not at start of problem). ---------------- 510 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODER- At T (=R1), EWT(I1) has become R2 .LE. 0.' CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) ISTATE = -6 GO TO 580 C Too much accuracy requested for machine precision. ------------------- 520 MSG = 'DLSODER- At T (=R1), too much accuracy requested ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' for precision of machine.. see TOLSF (=R2) ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) RWORK(14) = TOLSF ISTATE = -2 GO TO 580 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 530 MSG = 'DLSODER- At T(=R1) and step size H(=R2), the error' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' test failed repeatedly or with ABS(H) = HMIN' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) ISTATE = -4 GO TO 560 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 540 MSG = 'DLSODER- At T (=R1) and step size H (=R2), the ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' corrector convergence failed repeatedly ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' or with ABS(H) = HMIN ' CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) ISTATE = -5 C Compute IMXER if relevant. ------------------------------------------- 560 BIG = 0.0D0 IMXER = 1 DO 570 I = 1,N SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) IF (BIG .GE. SIZE) GO TO 570 BIG = SIZE IMXER = I 570 CONTINUE IWORK(16) = IMXER C Set Y vector, T, and optional outputs. ------------------------------- 580 DO 590 I = 1,N Y(I) = RWORK(I+LYH-1) 590 CONTINUE T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ C Karline: added next two lines IWORK(10) = NGE TLAST = T RETURN C----------------------------------------------------------------------- C Block I. C The following block handles all error returns due to illegal input C (ISTATE = -3), as detected before calling the core integrator. C First the error message routine is called. If the illegal input C is a negative ISTATE, the run is aborted (apparent infinite loop). C----------------------------------------------------------------------- 601 MSG = 'DLSODER- ISTATE (=I1) illegal ' CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) IF (ISTATE .LT. 0) GO TO 800 GO TO 700 602 MSG = 'DLSODER- ITASK (=I1) illegal ' CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) GO TO 700 603 MSG = 'DLSODER- ISTATE .GT. 1 but DLSODER not initialized ' CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) GO TO 700 604 MSG = 'DLSODER- NEQ (=I1) .LT. 1 ' CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) GO TO 700 605 MSG = 'DLSODER- ISTATE = 3 and NEQ increased (I1 to I2) ' CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 606 MSG = 'DLSODER- ITOL (=I1) illegal ' CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) GO TO 700 607 MSG = 'DLSODER- IOPT (=I1) illegal ' CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) GO TO 700 608 MSG = 'DLSODER- MF (=I1) illegal ' CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) GO TO 700 609 MSG = 'DLSODER- ML (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)' CALL XERRWD (MSG, 50, 9, 0, 2, ML, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 610 MSG = 'DLSODER- MU (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)' CALL XERRWD (MSG, 50, 10, 0, 2, MU, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 611 MSG = 'DLSODER- MAXORD (=I1) .LT. 0 ' CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) GO TO 700 612 MSG = 'DLSODER- MXSTEP (=I1) .LT. 0 ' CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) GO TO 700 613 MSG = 'DLSODER- MXHNIL (=I1) .LT. 0 ' CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) GO TO 700 614 MSG = 'DLSODER- TOUT (=R1) behind T (=R2) ' CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) MSG = ' Integration direction is given by H0 (=R1) ' CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) GO TO 700 615 MSG = 'DLSODER- HMAX (=R1) .LT. 0.0 ' CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) GO TO 700 616 MSG = 'DLSODER- HMIN (=R1) .LT. 0.0 ' CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) GO TO 700 617 CONTINUE MSG='DLSODER- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 618 CONTINUE MSG='DLSODER- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) GO TO 700 619 MSG = 'DLSODER- RTOL(I1) is R1 .LT. 0.0 ' CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) GO TO 700 620 MSG = 'DLSODER- ATOL(I1) is R1 .LT. 0.0 ' CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) GO TO 700 621 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODER- EWT(I1) is R1 .LE. 0.0 ' CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) GO TO 700 622 CONTINUE MSG='DLSODER- TOUT (=R1) too close to T(=R2) to start integration' CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) GO TO 700 623 CONTINUE MSG='DLSODER- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) GO TO 700 624 CONTINUE MSG='DLSODER- ITASK = 4 OR 5 and TCRIT (=R1) behind TCUR (=R2) ' CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) GO TO 700 625 CONTINUE MSG='DLSODER- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) GO TO 700 626 MSG = 'DLSODER- At start of problem, too much accuracy ' CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' requested for precision of machine.. See TOLSF (=R1) ' CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) RWORK(14) = TOLSF GO TO 700 627 MSG = 'DLSODER- Trouble in DINTDY. ITASK = I1, TOUT = R1' CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) C Karline: added next error messages 630 MSG = 'DLSODER- NG (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 30, 0, 1, NG, 0, 0, 0.0D0, 0.0D0) GO TO 700 631 MSG = 'DLSODER- NG changed (from I1 to I2) illegally, ' CALL XERRWD (MSG, 50, 31, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' i.e. not immediately after a root was found.' CALL XERRWD (MSG, 50, 31, 0, 2, NGC, NG, 0, 0.0D0, 0.0D0) GO TO 700 632 MSG = 'DLSODER- One or more components of g has a root ' CALL XERRWD (MSG, 50, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' too near to the initial point. ' CALL XERRWD (MSG, 40, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) C C 700 ISTATE = -3 RETURN C 800 MSG = 'DLSODER- Run aborted.. apparent infinite loop ' CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) RETURN C----------------------- END OF SUBROUTINE DLSODER ---------------------- END *DECK DLSODESR C DLSODESR was created by merging DLSODES with DLSODAR - Karline Soetaert SUBROUTINE DLSODESR (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, IWK, JAC, MF, 2 G, NG, JROOT, rpar, ipar) IMPLICIT NONE EXTERNAL F, JAC, G CKS: added rpar, ipar, and G INTEGER ipar(*) DOUBLE PRECISION rpar(*) INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF INTEGER NG, JROOT DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK INTEGER IWK(2*LRW) DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW), & JROOT(NG) C----------------------------------------------------------------------- C DLSODES solves the initial value problem for stiff or nonstiff C systems of first order ODEs, C dy/dt = f(t,y) , or, in component form, C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). C DLSODES is a variant of the DLSODE package, and is intended for C problems in which the Jacobian matrix df/dy has an arbitrary C sparse structure (when the problem is stiff). C C Authors: Alan C. Hindmarsh C Center for Applied Scientific Computing, L-561 C Lawrence Livermore National Laboratory C Livermore, CA 94551 C and C Andrew H. Sherman C J. S. Nolen and Associates C Houston, TX 77084 C C Root function added by Karline Soetaert C C***DESCRIPTION - see DLSODES C Note: length of RWORK array = 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM + 3*NG. C----------------------------------------------------------------------- EXTERNAL DPRJS, DSOLSS DOUBLE PRECISION DUMACH, DVNORM INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU C KS: added next lines INTEGER LG0, LG1, LGX, IOWNR3, IRFND, ITASKC, NGC, NGE INTEGER IRFP, IRT, LYHNEW DOUBLE PRECISION ROWNR3, T0, TLAST, TOUTC INTEGER I, I1, I2, IFLAG, IMAX, IMUL, IMXER, IPFLAG, IPGO, IREM, 1 J, KGO, LENRAT, LENYHT, LENIW, LENRW, LF0, LIA, LJA, 2 LRTEM, LWTEM, LYHD, LYHN, MF1, MORD, MXHNL0, MXSTP0, NCOLM DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 DIMENSION MORD(2) LOGICAL IHIT CHARACTER(LEN=60) MSG SAVE LENRAT, MORD, MXSTP0, MXHNL0 C----------------------------------------------------------------------- C The following two internal Common blocks contain C (a) variables which are local to any subroutine but whose values must C be preserved between calls to the routine ("own" variables), and C (b) variables which are communicated between subroutines. C The block DLS001 is declared in subroutines DLSODES, DIPREP, DPREP, C DINTDY, DSTODE, DPRJS, and DSOLSS. C The block DLSS01 is declared in subroutines DLSODES, DIPREP, DPREP, C DPRJS, and DSOLSS. C Groups of variables are replaced by dummy arrays in the Common C declarations in routines where those variables are not used. C----------------------------------------------------------------------- COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C COMMON /DLSS01/ CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH, 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU C karline: COMMON /DLSR01/ ROWNR3(2), T0, TLAST, TOUTC, 1 LG0, LG1, LGX, IOWNR3(2), IRFND, ITASKC, NGC, NGE C DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ C----------------------------------------------------------------------- C In the Data statement below, set LENRAT equal to the ratio of C the wordlength for a real number to that for an integer. Usually, C LENRAT = 1 for single precision and 2 for double precision. If the C true ratio is not an integer, use the next smaller integer (.ge. 1). C----------------------------------------------------------------------- DATA LENRAT/2/ C----------------------------------------------------------------------- C Block A. C This code block is executed on every call. C It tests ISTATE and ITASK for legality and branches appropriately. C If ISTATE .gt. 1 but the flag INIT shows that initialization has C not yet been done, an error return occurs. C If ISTATE = 1 and TOUT = T, return immediately. C----------------------------------------------------------------------- C KARLINE: INITIALISED IHIT TO AVOID COMPILER WARNINGS - SHOULD HAVE NO EFFEXT IHIT = .TRUE. IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 C Karline: added nest sentence ITASKC = ITASK IF (ISTATE .EQ. 1) GO TO 10 IF (INIT .EQ. 0) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) RETURN C----------------------------------------------------------------------- C Block B. C The next code block is executed for the initial call (ISTATE = 1), C or for a continuation call with parameter changes (ISTATE = 3). C It contains checking of all inputs and various initializations. C If ISTATE = 1, the final setting of work space pointers, the matrix C preprocessing, and other initializations are done in Block C. C C First check legality of the non-optional inputs NEQ, ITOL, IOPT, C MF, ML, MU, and NG. C----------------------------------------------------------------------- 20 IF (NEQ(1) .LE. 0) GO TO 604 IF (ISTATE .EQ. 1) GO TO 25 IF (NEQ(1) .GT. N) GO TO 605 25 N = NEQ(1) IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 MOSS = MF/100 MF1 = MF - 100*MOSS METH = MF1/10 MITER = MF1 - 10*METH IF (MOSS .LT. 0 .OR. MOSS .GT. 2) GO TO 608 IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 IF (MITER .LT. 0 .OR. MITER .GT. 3) GO TO 608 IF (MITER .EQ. 0 .OR. MITER .EQ. 3) MOSS = 0 C Karline: start add IF (NG .LT. 0) GO TO 680 IF (ISTATE .EQ. 1) GO TO 35 IF (IRFND .EQ. 0 .AND. NG .NE. NGC) GO TO 681 35 NGC = NG C Karline: end added C Next process and check the optional inputs. -------------------------- IF (IOPT .EQ. 1) GO TO 40 MAXORD = MORD(METH) MXSTEP = MXSTP0 MXHNIL = MXHNL0 IF (ISTATE .EQ. 1) H0 = 0.0D0 HMXI = 0.0D0 HMIN = 0.0D0 SETH = 0.0D0 GO TO 60 40 MAXORD = IWORK(5) IF (MAXORD .LT. 0) GO TO 611 IF (MAXORD .EQ. 0) MAXORD = 100 MAXORD = MIN(MAXORD,MORD(METH)) MXSTEP = IWORK(6) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .NE. 1) GO TO 50 H0 = RWORK(5) IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. 0.0D0) GO TO 615 HMXI = 0.0D0 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX HMIN = RWORK(7) IF (HMIN .LT. 0.0D0) GO TO 616 SETH = RWORK(8) IF (SETH .LT. 0.0D0) GO TO 609 C Check RTOL and ATOL for legality. ------------------------------------ 60 RTOLI = RTOL(1) ATOLI = ATOL(1) DO 65 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. 0.0D0) GO TO 619 IF (ATOLI .LT. 0.0D0) GO TO 620 65 CONTINUE C----------------------------------------------------------------------- C Compute required work array lengths, as far as possible, and test C these against LRW and LIW. Then set tentative pointers for work C arrays. Pointers to RWORK/IWORK segments are named by prefixing L to C the name of the segment. E.g., the segment YH starts at RWORK(LYH). C Segments of RWORK (in order) are denoted G0, G1, GX, WM, YH, SAVF, EWT, ACOR. C If MITER = 1 or 2, the required length of the matrix work space WM C is not yet known, and so a crude minimum value is used for the C initial tests of LRW and LIW, and YH is temporarily stored as far C to the right in RWORK as possible, to leave the maximum amount C of space for WM for matrix preprocessing. Thus if MITER = 1 or 2 C and MOSS .ne. 2, some of the segments of RWORK are temporarily C omitted, as they are not needed in the preprocessing. These C omitted segments are: ACOR if ISTATE = 1, EWT and ACOR if ISTATE = 3 C and MOSS = 1, and SAVF, EWT, and ACOR if ISTATE = 3 and MOSS = 0. C----------------------------------------------------------------------- LRAT = LENRAT IF (ISTATE .EQ. 1) NYH = N LWMIN = 0 IF (MITER .EQ. 1) LWMIN = 4*N + 10*N/LRAT IF (MITER .EQ. 2) LWMIN = 4*N + 11*N/LRAT IF (MITER .EQ. 3) LWMIN = N + 2 LENYH = (MAXORD+1)*NYH LREST = LENYH + 3*N LENRW = 20 + LWMIN + LREST IWORK(17) = LENRW LENIW = 30 IF (MOSS .EQ. 0 .AND. MITER .NE. 0 .AND. MITER .NE. 3) 1 LENIW = LENIW + N + 1 IWORK(18) = LENIW IF (LENRW .GT. LRW) GO TO 617 IF (LENIW .GT. LIW) GO TO 618 LIA = 31 IF (MOSS .EQ. 0 .AND. MITER .NE. 0 .AND. MITER .NE. 3) 1 LENIW = LENIW + IWORK(LIA+N) - 1 IWORK(18) = LENIW IF (LENIW .GT. LIW) GO TO 618 LJA = LIA + N + 1 LIA = MIN(LIA,LIW) LJA = MIN(LJA,LIW) C LWM = 21 C Karline: start changes IF (ISTATE .EQ. 1) NYH = N LG0 = 21 LG1 = LG0 + NG LGX = LG1 + NG LYHNEW = LGX + NG IF (ISTATE .EQ. 1) LYH = LYHNEW IF (LYHNEW .EQ. LYH) GO TO 67 C If ISTATE = 3 and NG was changed, shift YH to its new location. ------ LENYH = L*NYH IF (LRW .LT. LYHNEW-1+LENYH) GO TO 67 I1 = 1 IF (LYHNEW .GT. LYH) I1 = -1 CALL DCOPY (LENYH, RWORK(LYH), I1, RWORK(LYHNEW), I1) LYH = LYHNEW 67 CONTINUE CKS end of changes LWM = LYHNEW IF (ISTATE .EQ. 1) NQ = 1 NCOLM = MIN(NQ+1,MAXORD+2) LENYHM = NCOLM*NYH LENYHT = LENYH IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENYHT = LENYHM IMUL = 2 IF (ISTATE .EQ. 3) IMUL = MOSS IF (MOSS .EQ. 2) IMUL = 3 LRTEM = LENYHT + IMUL*N LWTEM = LWMIN C IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LWTEM = LRW - 20 - LRTEM IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LWTEM = LRW -(LWM-1)-LRTEM LENWK = LWTEM LYHN = LWM + LWTEM LSAVF = LYHN + LENYHT LEWT = LSAVF + N LACOR = LEWT + N ISTATC = ISTATE IF (ISTATE .EQ. 1) GO TO 100 C----------------------------------------------------------------------- C ISTATE = 3. Move YH to its new location. C Note that only the part of YH needed for the next step, namely C MIN(NQ+1,MAXORD+2) columns, is actually moved. C A temporary error weight array EWT is loaded if MOSS = 2. C Sparse matrix processing is done in DIPREP/DPREP if MITER = 1 or 2. C If MAXORD was reduced below NQ, then the pointers are finally set C so that SAVF is identical to YH(*,MAXORD+2). C----------------------------------------------------------------------- LYHD = LYH - LYHN IMAX = LYHN - 1 + LENYHM C Move YH. Move right if LYHD < 0; move left if LYHD > 0. ------------- IF (LYHD .LT. 0) THEN DO 72 I = LYHN,IMAX J = IMAX + LYHN - I RWORK(J) = RWORK(J+LYHD) 72 CONTINUE ENDIF IF (LYHD .GT. 0) THEN DO 76 I = LYHN,IMAX RWORK(I) = RWORK(I+LYHD) 76 CONTINUE ENDIF LYH = LYHN IWORK(22) = LYH IF (MITER .EQ. 0 .OR. MITER .EQ. 3) GO TO 92 IF (MOSS .NE. 2) GO TO 85 C Temporarily load EWT if MITER = 1 or 2 and MOSS = 2. ----------------- CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 82 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 82 CONTINUE 85 CONTINUE C DIPREP and DPREP do sparse matrix preprocessing if MITER = 1 or 2. --- LSAVF = MIN(LSAVF,LRW) LEWT = MIN(LEWT,LRW) LACOR = MIN(LACOR,LRW) CKS CALL DIPREP (NEQ,Y,RWORK,IWK,IWORK(LIA),IWORK(LJA),IPFLAG,F,JAC, & rpar, ipar ) LENRW = LWM - 1 + LENWK + LREST IWORK(17) = LENRW IF (IPFLAG .NE. -1) IWORK(23) = IPIAN IF (IPFLAG .NE. -1) IWORK(24) = IPJAN IPGO = -IPFLAG + 1 IF (IPGO .EQ. 1) THEN GOTO 90 ELSE IF (IPGO .EQ. 2) THEN GOTO 628 ELSE IF (IPGO .EQ. 3) THEN GOTO 629 ELSE IF (IPGO .EQ. 4) THEN GOTO 630 ELSE IF (IPGO .EQ. 5) THEN GOTO 631 ELSE IF (IPGO .EQ. 6) THEN GOTO 632 ELSE IF (IPGO .EQ. 7) THEN GOTO 633 ENDIF C GO TO (90, 628, 629, 630, 631, 632, 633), IPGO 90 IWORK(22) = LYH IF (LENRW .GT. LRW) GO TO 617 C Set flag to signal parameter changes to DSTODE. ---------------------- 92 JSTART = -1 IF (N .EQ. NYH) GO TO 200 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- I1 = LYH + L*NYH I2 = LYH + (MAXORD + 1)*NYH - 1 IF (I1 .GT. I2) GO TO 200 DO 95 I = I1,I2 RWORK(I) = 0.0D0 95 CONTINUE GO TO 200 C----------------------------------------------------------------------- C Block C. C The next block is for the initial call only (ISTATE = 1). C It contains all remaining initializations, the initial call to F, C the sparse matrix preprocessing (MITER = 1 or 2), and the C calculation of the initial step size. C The error weights in EWT are inverted after being loaded. C----------------------------------------------------------------------- 100 CONTINUE LYH = LYHN IWORK(22) = LYH TN = T NST = 0 H = 1.0D0 NNZ = 0 NGP = 0 NZL = 0 NZU = 0 C Load the initial value vector in YH. --------------------------------- DO 105 I = 1,N RWORK(I+LYH-1) = Y(I) 105 CONTINUE C Initial call to F. (LF0 points to YH(*,2).) ------------------------- LF0 = LYH + NYH CALL F (NEQ, T, Y, RWORK(LF0), rpar, ipar) NFE = 1 C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 110 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 110 CONTINUE IF (MITER .EQ. 0 .OR. MITER .EQ. 3) GO TO 120 C DIPREP and DPREP do sparse matrix preprocessing if MITER = 1 or 2. --- LACOR = MIN(LACOR,LRW) CALL DIPREP (NEQ,Y,RWORK,IWK,IWORK(LIA),IWORK(LJA),IPFLAG,F,JAC, & rpar, ipar) LENRW = LWM - 1 + LENWK + LREST IWORK(17) = LENRW IF (IPFLAG .NE. -1) IWORK(23) = IPIAN IF (IPFLAG .NE. -1) IWORK(24) = IPJAN IPGO = -IPFLAG + 1 IF (IPGO .EQ. 1) THEN GOTO 115 ELSE IF (IPGO .EQ. 2) THEN GOTO 628 ELSE IF (IPGO .EQ. 3) THEN GOTO 629 ELSE IF (IPGO .EQ. 4) THEN GOTO 630 ELSE IF (IPGO .EQ. 5) THEN GOTO 631 ELSE IF (IPGO .EQ. 6) THEN GOTO 632 ELSE IF (IPGO .EQ. 7) THEN GOTO 633 ENDIF C GO TO (115, 628, 629, 630, 631, 632, 633), IPGO 115 IWORK(22) = LYH IF (LENRW .GT. LRW) GO TO 617 C Check TCRIT for legality (ITASK = 4 or 5). --------------------------- 120 CONTINUE IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 125 TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 1 H0 = TCRIT - T C Initialize all remaining parameters. --------------------------------- 125 UROUND = DUMACH() JSTART = 0 IF (MITER .NE. 0) RWORK(LWM) = SQRT(UROUND) MSBJ = 50 NSLJ = 0 CCMXJ = 0.2D0 PSMALL = 1000.0D0*UROUND RBIG = 0.01D0/PSMALL NHNIL = 0 NJE = 0 NLU = 0 NSLAST = 0 HU = 0.0D0 NQU = 0 CCMAX = 0.3D0 MAXCOR = 3 MSBP = 20 MXNCF = 10 C----------------------------------------------------------------------- C The coding below computes the step size, H0, to be attempted on the C first step, unless the user has supplied a value for this. C First check that TOUT - T differs significantly from zero. C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i)) C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted C so as to be between 100*UROUND and 1.0E-3. C Then the computed value H0 is given by.. C NEQ C H0**2 = TOL / ( w0**-2 + (1/NEQ) * Sum ( f(i)/ywt(i) )**2 ) C 1 C where w0 = MAX ( ABS(T), ABS(TOUT) ), C f(i) = i-th component of initial value of f, C ywt(i) = EWT(i)/TOL (a weight for y(i)). C The sign of H0 is inferred from the initial values of TOUT and T. C ABS(H0) is made .le. ABS(TOUT-T) in any case. C----------------------------------------------------------------------- LF0 = LYH + NYH IF (H0 .NE. 0.0D0) GO TO 180 TDIST = ABS(TOUT - T) W0 = MAX(ABS(T),ABS(TOUT)) IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 TOL = RTOL(1) IF (ITOL .LE. 2) GO TO 140 DO 130 I = 1,N TOL = MAX(TOL,RTOL(I)) 130 CONTINUE 140 IF (TOL .GT. 0.0D0) GO TO 160 ATOLI = ATOL(1) DO 150 I = 1,N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) AYI = ABS(Y(I)) IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 150 CONTINUE 160 TOL = MAX(TOL,100.0D0*UROUND) TOL = MIN(TOL,0.001D0) SUM = DVNORM (N, RWORK(LF0), RWORK(LEWT)) SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 H0 = 1.0D0/SQRT(SUM) H0 = MIN(H0,TDIST) H0 = SIGN(H0,TOUT-T) C Adjust H0 if necessary to meet HMAX bound. --------------------------- 180 RH = ABS(H0)*HMXI IF (RH .GT. 1.0D0) H0 = H0/RH C Load H with H0 and scale YH(*,2) by H0. ------------------------------ H = H0 DO 190 I = 1,N RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 190 CONTINUE CKS: start changes GO TO 270 C C Check for a zero of g at T. ------------------------------------------ IRFND = 0 TOUTC = TOUT IF (NGC .EQ. 0) GO TO 270 CALL DRCHEK (1, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .EQ. 0) GO TO 270 GO TO 682 CKS: end changes C----------------------------------------------------------------------- C Block D. C The next code block is for continuation calls only (ISTATE = 2 or 3) C and is to check stop conditions before taking a step. C First, DRCHEK is called to check for a root within the last step C taken, other than the last root found there, if any. C If ITASK = 2 or 5, and y(TN) has not yet been returned to the user C because of an intervening root, return through Block G. C----------------------------------------------------------------------- 200 NSLAST = NST C karline: added from here IRFP = IRFND IF (NGC .EQ. 0) GO TO 205 IF (ITASK .EQ. 1 .OR. ITASK .EQ. 4) TOUTC = TOUT CALL DRCHEK (2, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .NE. 1) GO TO 205 IRFND = 1 ISTATE = 3 T = T0 GO TO 425 205 CONTINUE IRFND = 0 IF (IRFP .EQ. 1 .AND. TLAST .NE. TN .AND. ITASK .EQ. 2) GO TO 400 C karline: till here IF (ITASK .EQ. 1) THEN GOTO 210 ELSE IF (ITASK .EQ. 2) THEN GOTO 250 ELSE IF (ITASK .EQ. 3) THEN GOTO 220 ELSE IF (ITASK .EQ. 4) THEN GOTO 230 ELSE IF (ITASK .EQ. 5) THEN GOTO 240 ENDIF C GO TO (210, 250, 220, 230, 240), ITASK 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 245 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX C karline:added next line IF (IRFP .EQ. 1 .AND. TLAST .NE. TN .AND. ITASK .EQ. 5) GO TO 400 IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (ISTATE .EQ. 2) JSTART = -2 C----------------------------------------------------------------------- C Block E. C The next block is normally executed for all calls and contains C the call to the one-step core integrator DSTODE. C C This is a looping point for the integration steps. C C First check for too many steps being taken, update EWT (if not at C start of problem), check for too much accuracy being requested, and C check for H below the roundoff level in T. C----------------------------------------------------------------------- 250 CONTINUE IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 260 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 260 CONTINUE 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) IF (TOLSF .LE. 1.0D0) GO TO 280 TOLSF = TOLSF*2.0D0 IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 MSG = 'DLSODES- Warning..Internal T (=R1) and H (=R2) are' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' such that in the machine, T + H = T on the next step ' CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' (H = step size). Solver will continue anyway.' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 MSG = 'DLSODES- Above warning has been issued I1 times. ' CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' It will not be issued again for this problem.' CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 290 CONTINUE C----------------------------------------------------------------------- C CALL DSTODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,WM,F,JAC,DPRJS,DSOLSS) C----------------------------------------------------------------------- CALL DSTODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWK(2*LWM-1), 2 F, JAC, DPRJS, DSOLSS, rpar,ipar) KGO = 1 - KFLAG IF (KGO .EQ. 1) THEN GOTO 300 ELSE IF (KGO .EQ. 2) THEN GOTO 530 ELSE IF (KGO .EQ. 3) THEN GOTO 540 ELSE IF (KGO .EQ. 4) THEN GOTO 550 ENDIF C GO TO (300, 530, 540, 550), KGO C----------------------------------------------------------------------- C Block F. C The following block handles the case of a successful return from the C core integrator (KFLAG = 0). Test for stop conditions. C Then call DRCHEK to check for a root within the last step. C Then, if no root was found, check for stop conditions. C----------------------------------------------------------------------- 300 INIT = 1 Ckarline: changed this IF (NGC .EQ. 0) GO TO 305 CALL DRCHEK (3, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .NE. 1) GO TO 305 IRFND = 1 ISTATE = 3 T = T0 GO TO 425 305 CONTINUE IF (ITASK .EQ. 1) THEN GOTO 310 ELSE IF (ITASK .EQ. 2) THEN GOTO 400 ELSE IF (ITASK .EQ. 3) THEN GOTO 330 ELSE IF (ITASK .EQ. 4) THEN GOTO 340 ELSE IF (ITASK .EQ. 5) THEN GOTO 350 ENDIF C GO TO (310, 400, 330, 340, 350), ITASK C ITASK = 1. if TOUT has been reached, interpolate. ------------------- 310 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 GO TO 250 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 345 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) JSTART = -2 GO TO 250 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 350 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX C----------------------------------------------------------------------- C Block G. C The following block handles all successful returns from DLSODES. C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. C ISTATE is set to 2, and the optional outputs are loaded into the C work arrays before returning. C----------------------------------------------------------------------- 400 DO 410 I = 1,N Y(I) = RWORK(I+LYH-1) 410 CONTINUE T = TN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 IF (IHIT) T = TCRIT 420 ISTATE = 2 425 CONTINUE RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = NNZ IWORK(20) = NGP IWORK(21) = NLU IWORK(25) = NZL IWORK(26) = NZU C karline: added next two lines IWORK(10) = NGE TLAST = T RETURN C----------------------------------------------------------------------- C Block H. C The following block handles all unsuccessful returns other than C those for illegal input. First the error message routine is called. C If there was an error test or convergence test failure, IMXER is set. C Then Y is loaded from YH and T is set to TN. C The optional outputs are loaded into the work arrays before returning. C----------------------------------------------------------------------- C The maximum number of steps was taken before reaching TOUT. ---------- 500 MSG = 'DLSODES- At current T (=R1), MXSTEP (=I1) steps ' CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' taken on this call before reaching TOUT ' CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) ISTATE = -1 GO TO 580 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 510 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODES- At T (=R1), EWT(I1) has become R2 .le. 0.' CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) ISTATE = -6 GO TO 580 C Too much accuracy requested for machine precision. ------------------- 520 MSG = 'DLSODES- At T (=R1), too much accuracy requested ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' for precision of machine.. See TOLSF (=R2) ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) RWORK(14) = TOLSF ISTATE = -2 GO TO 580 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 530 MSG = 'DLSODES- At T(=R1) and step size H(=R2), the error' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' test failed repeatedly or with ABS(H) = HMIN' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) ISTATE = -4 GO TO 560 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 540 MSG = 'DLSODES- At T (=R1) and step size H (=R2), the ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' corrector convergence failed repeatedly ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' or with ABS(H) = HMIN ' CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) ISTATE = -5 GO TO 560 C KFLAG = -3. Fatal error flag returned by DPRJS or DSOLSS (CDRV). ---- 550 MSG = 'DLSODES- At T (=R1) and step size H (=R2), a fatal' CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' error flag was returned by CDRV (by way of ' CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' Subroutine DPRJS or DSOLSS) ' CALL XERRWD (MSG, 40, 207, 0, 0, 0, 0, 2, TN, H) ISTATE = -7 GO TO 580 C Compute IMXER if relevant. ------------------------------------------- 560 BIG = 0.0D0 IMXER = 1 DO 570 I = 1,N SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) IF (BIG .GE. SIZE) GO TO 570 BIG = SIZE IMXER = I 570 CONTINUE IWORK(16) = IMXER C Set Y vector, T, and optional outputs. ------------------------------- 580 DO 590 I = 1,N Y(I) = RWORK(I+LYH-1) 590 CONTINUE T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = NNZ IWORK(20) = NGP IWORK(21) = NLU IWORK(25) = NZL IWORK(26) = NZU C karline: added next two lines IWORK(10) = NGE TLAST = T RETURN C----------------------------------------------------------------------- C Block I. C The following block handles all error returns due to illegal input C (ISTATE = -3), as detected before calling the core integrator. C First the error message routine is called. If the illegal input C is a negative ISTATE, the run is aborted (apparent infinite loop). C----------------------------------------------------------------------- 601 MSG = 'DLSODES- ISTATE (=I1) illegal.' CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) IF (ISTATE .LT. 0) GO TO 800 GO TO 700 602 MSG = 'DLSODES- ITASK (=I1) illegal. ' CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) GO TO 700 603 MSG = 'DLSODES- ISTATE.gt.1 but DLSODES not initialized. ' CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) GO TO 700 604 MSG = 'DLSODES- NEQ (=I1) .lt. 1 ' CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) GO TO 700 605 MSG = 'DLSODES- ISTATE = 3 and NEQ increased (I1 to I2). ' CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 606 MSG = 'DLSODES- ITOL (=I1) illegal. ' CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) GO TO 700 607 MSG = 'DLSODES- IOPT (=I1) illegal. ' CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) GO TO 700 608 MSG = 'DLSODES- MF (=I1) illegal. ' CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) GO TO 700 609 MSG = 'DLSODES- SETH (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 9, 0, 0, 0, 0, 1, SETH, 0.0D0) GO TO 700 611 MSG = 'DLSODES- MAXORD (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) GO TO 700 612 MSG = 'DLSODES- MXSTEP (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) GO TO 700 613 MSG = 'DLSODES- MXHNIL (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) GO TO 700 614 MSG = 'DLSODES- TOUT (=R1) behind T (=R2) ' CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) MSG = ' Integration direction is given by H0 (=R1) ' CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) GO TO 700 615 MSG = 'DLSODES- HMAX (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) GO TO 700 616 MSG = 'DLSODES- HMIN (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) GO TO 700 617 MSG = 'DLSODES- RWORK length is insufficient to proceed. ' CALL XERRWD (MSG, 50, 17, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 618 MSG = 'DLSODES- IWORK length is insufficient to proceed. ' CALL XERRWD (MSG, 50, 18, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENIW (=I1), exceeds LIW (=I2)' CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) GO TO 700 619 MSG = 'DLSODES- RTOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) GO TO 700 620 MSG = 'DLSODES- ATOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) GO TO 700 621 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODES- EWT(I1) is R1 .le. 0.0 ' CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) GO TO 700 622 MSG='DLSODES- TOUT(=R1) too close to T(=R2) to start integration.' CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) GO TO 700 623 MSG='DLSODES- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) GO TO 700 624 MSG='DLSODES- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) GO TO 700 625 MSG='DLSODES- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) GO TO 700 626 MSG = 'DLSODES- At start of problem, too much accuracy ' CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' requested for precision of machine.. See TOLSF (=R1) ' CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) RWORK(14) = TOLSF GO TO 700 627 MSG = 'DLSODES- Trouble in DINTDY. ITASK = I1, TOUT = R1' CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) GO TO 700 628 MSG='DLSODES- RWORK length insufficient (for Subroutine DPREP). ' CALL XERRWD (MSG, 60, 28, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 28, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 629 MSG='DLSODES- RWORK length insufficient (for Subroutine JGROUP). ' CALL XERRWD (MSG, 60, 29, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 29, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 630 MSG='DLSODES- RWORK length insufficient (for Subroutine ODRV). ' CALL XERRWD (MSG, 60, 30, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 30, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 631 MSG='DLSODES- Error from ODRV in Yale Sparse Matrix Package. ' CALL XERRWD (MSG, 60, 31, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) IMUL = (IYS - 1)/N IREM = IYS - IMUL*N MSG=' At T (=R1), ODRV returned error flag = I1*NEQ + I2. ' CALL XERRWD (MSG, 60, 31, 0, 2, IMUL, IREM, 1, TN, 0.0D0) GO TO 700 632 MSG='DLSODES- RWORK length insufficient (for Subroutine CDRV). ' CALL XERRWD (MSG, 60, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 32, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 633 MSG='DLSODES- Error from CDRV in Yale Sparse Matrix Package. ' CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) IMUL = (IYS - 1)/N IREM = IYS - IMUL*N MSG=' At T (=R1), CDRV returned error flag = I1*NEQ + I2. ' CALL XERRWD (MSG, 60, 33, 0, 2, IMUL, IREM, 1, TN, 0.0D0) IF (IMUL .EQ. 2) THEN MSG=' Duplicate entry in sparsity structure descriptors. ' CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) ENDIF IF (IMUL .EQ. 3 .OR. IMUL .EQ. 6) THEN MSG=' Insufficient storage for NSFC (called by CDRV). ' CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) ENDIF C Karline: added next error messages 680 MSG = 'DLSODES- NG (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 30, 0, 1, NG, 0, 0, 0.0D0, 0.0D0) GO TO 700 681 MSG = 'DLSODES- NG changed (from I1 to I2) illegally, ' CALL XERRWD (MSG, 50, 31, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' i.e. not immediately after a root was found.' CALL XERRWD (MSG, 50, 31, 0, 2, NGC, NG, 0, 0.0D0, 0.0D0) GO TO 700 682 MSG = 'DLSODES- One or more components of g has a root ' CALL XERRWD (MSG, 50, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' too near to the initial point. ' CALL XERRWD (MSG, 40, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) C C 700 ISTATE = -3 RETURN C 800 MSG = 'DLSODES- Run aborted.. apparent infinite loop. ' CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) RETURN C----------------------- End of Subroutine DLSODES --------------------- END deSolve/src/zvode.f0000644000176000001440000053022313572134421013777 0ustar ripleyusersC Original authors: Peter N. Brown, Alan C. Hindmarsh, C Geore D. Byrne (see original author statement below) C C Adapted for use in R package deSolve by the deSolve authors. C *DECK ZVODE SUBROUTINE ZVODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 1 ISTATE, IOPT, ZWORK, LZW, RWORK, LRW, IWORK, LIW, 2 JAC, MF, RPAR, IPAR) EXTERNAL F, JAC COMPLEX(KIND=8) Y, ZWORK DOUBLE PRECISION T, TOUT, RTOL, ATOL, RWORK INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LZW, LRW, IWORK, LIW, 1 MF, IPAR DIMENSION Y(*), RTOL(*), ATOL(*), ZWORK(LZW), RWORK(LRW), 1 IWORK(LIW), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C ZVODE: Variable-coefficient Ordinary Differential Equation solver, C with fixed-leading-coefficient implementation. C This version is in complex double precision. C C ZVODE solves the initial value problem for stiff or nonstiff C systems of first order ODEs, C dy/dt = f(t,y) , or, in component form, C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). C Here the y vector is treated as complex. C ZVODE is a package based on the EPISODE and EPISODEB packages, and C on the ODEPACK user interface standard, with minor modifications. C C NOTE: When using ZVODE for a stiff system, it should only be used for C the case in which the function f is analytic, that is, when each f(i) C is an analytic function of each y(j). Analyticity means that the C partial derivative df(i)/dy(j) is a unique complex number, and this C fact is critical in the way ZVODE solves the dense or banded linear C systems that arise in the stiff case. For a complex stiff ODE system C in which f is not analytic, ZVODE is likely to have convergence C failures, and for this problem one should instead use DVODE on the C equivalent real system (in the real and imaginary parts of y). C----------------------------------------------------------------------- C Authors: C Peter N. Brown and Alan C. Hindmarsh C Center for Applied Scientific Computing C Lawrence Livermore National Laboratory C Livermore, CA 94551 C and C George D. Byrne (Prof. Emeritus) C Illinois Institute of Technology C Chicago, IL 60616 C----------------------------------------------------------------------- C For references, see DVODE. C----------------------------------------------------------------------- C Summary of usage. C C Communication between the user and the ZVODE package, for normal C situations, is summarized here. This summary describes only a subset C of the full set of options available. See the full description for C details, including optional communication, nonstandard options, C and instructions for special situations. See also the example C problem (with program and output) following this summary. C C A. First provide a subroutine of the form: C SUBROUTINE F (NEQ, T, Y, YDOT, RPAR, IPAR) C DOUBLE COMPLEX Y(NEQ), YDOT(NEQ) C DOUBLE PRECISION T C which supplies the vector function f by loading YDOT(i) with f(i). C C B. Next determine (or guess) whether or not the problem is stiff. C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue C whose real part is negative and large in magnitude, compared to the C reciprocal of the t span of interest. If the problem is nonstiff, C use a method flag MF = 10. If it is stiff, there are four standard C choices for MF (21, 22, 24, 25), and ZVODE requires the Jacobian C matrix in some form. In these cases (MF .gt. 0), ZVODE will use a C saved copy of the Jacobian matrix. If this is undesirable because of C storage limitations, set MF to the corresponding negative value C (-21, -22, -24, -25). (See full description of MF below.) C The Jacobian matrix is regarded either as full (MF = 21 or 22), C or banded (MF = 24 or 25). In the banded case, ZVODE requires two C half-bandwidth parameters ML and MU. These are, respectively, the C widths of the lower and upper parts of the band, excluding the main C diagonal. Thus the band consists of the locations (i,j) with C i-ML .le. j .le. i+MU, and the full bandwidth is ML+MU+1. C C C. If the problem is stiff, you are encouraged to supply the Jacobian C directly (MF = 21 or 24), but if this is not feasible, ZVODE will C compute it internally by difference quotients (MF = 22 or 25). C If you are supplying the Jacobian, provide a subroutine of the form: C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, RPAR, IPAR) C DOUBLE COMPLEX Y(NEQ), PD(NROWPD,NEQ) C DOUBLE PRECISION T C which supplies df/dy by loading PD as follows: C For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j), C the partial derivative of f(i) with respect to y(j). (Ignore the C ML and MU arguments in this case.) C For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with C df(i)/dy(j), i.e. load the diagonal lines of df/dy into the rows of C PD from the top down. C In either case, only nonzero elements need be loaded. C C D. Write a main program which calls subroutine ZVODE once for C each point at which answers are desired. This should also provide C for possible use of logical unit 6 for output of error messages C by ZVODE. On the first call to ZVODE, supply arguments as follows: C F = Name of subroutine for right-hand side vector f. C This name must be declared external in calling program. C NEQ = Number of first order ODEs. C Y = Double complex array of initial values, of length NEQ. C T = The initial value of the independent variable. C TOUT = First point where output is desired (.ne. T). C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. C RTOL = Relative tolerance parameter (scalar). C ATOL = Absolute tolerance parameter (scalar or array). C The estimated local error in Y(i) will be controlled so as C to be roughly less (in magnitude) than C EWT(i) = RTOL*abs(Y(i)) + ATOL if ITOL = 1, or C EWT(i) = RTOL*abs(Y(i)) + ATOL(i) if ITOL = 2. C Thus the local error test passes if, in each component, C either the absolute error is less than ATOL (or ATOL(i)), C or the relative error is less than RTOL. C Use RTOL = 0.0 for pure absolute error control, and C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error C control. Caution: Actual (global) errors may exceed these C local tolerances, so choose them conservatively. C ITASK = 1 for normal computation of output values of Y at t = TOUT. C ISTATE = Integer flag (input and output). Set ISTATE = 1. C IOPT = 0 to indicate no optional input used. C ZWORK = Double precision complex work array of length at least: C 15*NEQ for MF = 10, C 8*NEQ + 2*NEQ**2 for MF = 21 or 22, C 10*NEQ + (3*ML + 2*MU)*NEQ for MF = 24 or 25. C LZW = Declared length of ZWORK (in user's DIMENSION statement). C RWORK = Real work array of length at least 20 + NEQ. C LRW = Declared length of RWORK (in user's DIMENSION statement). C IWORK = Integer work array of length at least: C 30 for MF = 10, C 30 + NEQ for MF = 21, 22, 24, or 25. C If MF = 24 or 25, input in IWORK(1),IWORK(2) the lower C and upper half-bandwidths ML,MU. C LIW = Declared length of IWORK (in user's DIMENSION statement). C JAC = Name of subroutine for Jacobian matrix (MF = 21 or 24). C If used, this name must be declared external in calling C program. If not used, pass a dummy name. C MF = Method flag. Standard values are: C 10 for nonstiff (Adams) method, no Jacobian used. C 21 for stiff (BDF) method, user-supplied full Jacobian. C 22 for stiff method, internally generated full Jacobian. C 24 for stiff method, user-supplied banded Jacobian. C 25 for stiff method, internally generated banded Jacobian. C RPAR = user-defined real or complex array passed to F and JAC. C IPAR = user-defined integer array passed to F and JAC. C Note that the main program must declare arrays Y, ZWORK, RWORK, IWORK, C and possibly ATOL, RPAR, and IPAR. RPAR may be declared REAL, DOUBLE, C COMPLEX, or DOUBLE COMPLEX, depending on the user's needs. C C E. The output from the first call (or any call) is: C Y = Array of computed values of y(t) vector. C T = Corresponding value of independent variable (normally TOUT). C ISTATE = 2 if ZVODE was successful, negative otherwise. C -1 means excess work done on this call. (Perhaps wrong MF.) C -2 means excess accuracy requested. (Tolerances too small.) C -3 means illegal input detected. (See printed message.) C -4 means repeated error test failures. (Check all input.) C -5 means repeated convergence failures. (Perhaps bad C Jacobian supplied or wrong choice of MF or tolerances.) C -6 means error weight became zero during problem. (Solution C component i vanished, and ATOL or ATOL(i) = 0.) C C F. To continue the integration after a successful return, simply C reset TOUT and call ZVODE again. No other parameters need be reset. C C----------------------------------------------------------------------- C EXAMPLE PROBLEM C C The program below uses ZVODE to solve the following system of 2 ODEs: C dw/dt = -i*w*w*z, dz/dt = i*z; w(0) = 1/2.1, z(0) = 1; t = 0 to 2*pi. C Solution: w = 1/(z + 1.1), z = exp(it). As z traces the unit circle, C w traces a circle of radius 10/2.1 with center at 11/2.1. C For convenience, Main passes RPAR = (imaginary unit i) to FEX and JEX. C C EXTERNAL FEX, JEX C DOUBLE COMPLEX Y(2), ZWORK(24), RPAR, WTRU, ERR C DOUBLE PRECISION ABERR, AEMAX, ATOL, RTOL, RWORK(22), T, TOUT C DIMENSION IWORK(32) C NEQ = 2 C Y(1) = 1.0D0/2.1D0 C Y(2) = 1.0D0 C T = 0.0D0 C DTOUT = 0.1570796326794896D0 C TOUT = DTOUT C ITOL = 1 C RTOL = 1.D-9 C ATOL = 1.D-8 C ITASK = 1 C ISTATE = 1 C IOPT = 0 C LZW = 24 C LRW = 22 C LIW = 32 C MF = 21 C RPAR = DCMPLX(0.0D0,1.0D0) C AEMAX = 0.0D0 C WRITE(6,10) C 10 FORMAT(' t',11X,'w',26X,'z') C DO 40 IOUT = 1,40 C CALL ZVODE(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE,IOPT, C 1 ZWORK,LZW,RWORK,LRW,IWORK,LIW,JEX,MF,RPAR,IPAR) C WTRU = 1.0D0/DCMPLX(COS(T) + 1.1D0, SIN(T)) C ERR = Y(1) - WTRU C ABERR = ABS(DREAL(ERR)) + ABS(DIMAG(ERR)) C AEMAX = MAX(AEMAX,ABERR) C WRITE(6,20) T, DREAL(Y(1)),DIMAG(Y(1)), DREAL(Y(2)),DIMAG(Y(2)) C 20 FORMAT(F9.5,2X,2F12.7,3X,2F12.7) C IF (ISTATE .LT. 0) THEN C WRITE(6,30) ISTATE C 30 FORMAT(//'***** Error halt. ISTATE =',I3) C STOP C ENDIF C 40 TOUT = TOUT + DTOUT C WRITE(6,50) IWORK(11), IWORK(12), IWORK(13), IWORK(20), C 1 IWORK(21), IWORK(22), IWORK(23), AEMAX C 50 FORMAT(/' No. steps =',I4,' No. f-s =',I5, C 1 ' No. J-s =',I4,' No. LU-s =',I4/ C 2 ' No. nonlinear iterations =',I4/ C 3 ' No. nonlinear convergence failures =',I4/ C 4 ' No. error test failures =',I4/ C 5 ' Max. abs. error in w =',D10.2) C STOP C END C C SUBROUTINE FEX (NEQ, T, Y, YDOT, RPAR, IPAR) C DOUBLE COMPLEX Y(NEQ), YDOT(NEQ), RPAR C DOUBLE PRECISION T C YDOT(1) = -RPAR*Y(1)*Y(1)*Y(2) C YDOT(2) = RPAR*Y(2) C RETURN C END C C SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD, RPAR, IPAR) C DOUBLE COMPLEX Y(NEQ), PD(NRPD,NEQ), RPAR C DOUBLE PRECISION T C PD(1,1) = -2.0D0*RPAR*Y(1)*Y(2) C PD(1,2) = -RPAR*Y(1)*Y(1) C PD(2,2) = RPAR C RETURN C END C C The output of this example program is as follows: C C t w z C 0.15708 0.4763242 -0.0356919 0.9876884 0.1564345 C 0.31416 0.4767322 -0.0718256 0.9510565 0.3090170 C 0.47124 0.4774351 -0.1088651 0.8910065 0.4539906 C 0.62832 0.4784699 -0.1473206 0.8090170 0.5877853 C 0.78540 0.4798943 -0.1877789 0.7071067 0.7071069 C 0.94248 0.4817938 -0.2309414 0.5877852 0.8090171 C 1.09956 0.4842934 -0.2776778 0.4539904 0.8910066 C 1.25664 0.4875766 -0.3291039 0.3090169 0.9510566 C 1.41372 0.4919177 -0.3866987 0.1564343 0.9876884 C 1.57080 0.4977376 -0.4524889 -0.0000001 1.0000000 C 1.72788 0.5057044 -0.5293524 -0.1564346 0.9876883 C 1.88496 0.5169274 -0.6215400 -0.3090171 0.9510565 C 2.04204 0.5333540 -0.7356275 -0.4539906 0.8910065 C 2.19911 0.5586542 -0.8823669 -0.5877854 0.8090169 C 2.35619 0.6004188 -1.0806013 -0.7071069 0.7071067 C 2.51327 0.6764486 -1.3664281 -0.8090171 0.5877851 C 2.67035 0.8366909 -1.8175245 -0.8910066 0.4539904 C 2.82743 1.2657121 -2.6260146 -0.9510566 0.3090168 C 2.98451 3.0284506 -4.2182180 -0.9876884 0.1564343 C 3.14159 10.0000699 0.0000663 -1.0000000 -0.0000002 C 3.29867 3.0284170 4.2182053 -0.9876883 -0.1564346 C 3.45575 1.2657041 2.6260067 -0.9510565 -0.3090172 C 3.61283 0.8366878 1.8175205 -0.8910064 -0.4539907 C 3.76991 0.6764469 1.3664259 -0.8090169 -0.5877854 C 3.92699 0.6004178 1.0806000 -0.7071066 -0.7071069 C 4.08407 0.5586535 0.8823662 -0.5877851 -0.8090171 C 4.24115 0.5333535 0.7356271 -0.4539903 -0.8910066 C 4.39823 0.5169271 0.6215398 -0.3090168 -0.9510566 C 4.55531 0.5057041 0.5293523 -0.1564343 -0.9876884 C 4.71239 0.4977374 0.4524890 0.0000002 -1.0000000 C 4.86947 0.4919176 0.3866988 0.1564347 -0.9876883 C 5.02655 0.4875765 0.3291040 0.3090172 -0.9510564 C 5.18363 0.4842934 0.2776780 0.4539907 -0.8910064 C 5.34071 0.4817939 0.2309415 0.5877854 -0.8090169 C 5.49779 0.4798944 0.1877791 0.7071069 -0.7071066 C 5.65487 0.4784700 0.1473208 0.8090171 -0.5877850 C 5.81195 0.4774352 0.1088652 0.8910066 -0.4539903 C 5.96903 0.4767324 0.0718257 0.9510566 -0.3090168 C 6.12611 0.4763244 0.0356920 0.9876884 -0.1564342 C 6.28319 0.4761907 0.0000000 1.0000000 0.0000003 C C No. steps = 542 No. f-s = 610 No. J-s = 10 No. LU-s = 47 C No. nonlinear iterations = 607 C No. nonlinear convergence failures = 0 C No. error test failures = 13 C Max. abs. error in w = 0.13E-03 C C----------------------------------------------------------------------- C Full description of user interface to ZVODE. C C The user interface to ZVODE consists of the following parts. C C i. The call sequence to subroutine ZVODE, which is a driver C routine for the solver. This includes descriptions of both C the call sequence arguments and of user-supplied routines. C Following these descriptions is C * a description of optional input available through the C call sequence, C * a description of optional output (in the work arrays), and C * instructions for interrupting and restarting a solution. C C ii. Descriptions of other routines in the ZVODE package that may be C (optionally) called by the user. These provide the ability to C alter error message handling, save and restore the internal C COMMON, and obtain specified derivatives of the solution y(t). C C iii. Descriptions of COMMON blocks to be declared in overlay C or similar environments. C C iv. Description of two routines in the ZVODE package, either of C which the user may replace with his own version, if desired. C these relate to the measurement of errors. C C----------------------------------------------------------------------- C Part i. Call Sequence. C C The call sequence parameters used for input only are C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF, C and those used for both input and output are C Y, T, ISTATE. C The work arrays ZWORK, RWORK, and IWORK are also used for conditional C and optional input and optional output. (The term output here refers C to the return from subroutine ZVODE to the user's calling program.) C C The legality of input parameters will be thoroughly checked on the C initial call for the problem, but not checked thereafter unless a C change in input parameters is flagged by ISTATE = 3 in the input. C C The descriptions of the call arguments are as follows. C C F = The name of the user-supplied subroutine defining the C ODE system. The system must be put in the first-order C form dy/dt = f(t,y), where f is a vector-valued function C of the scalar t and the vector y. Subroutine F is to C compute the function f. It is to have the form C SUBROUTINE F (NEQ, T, Y, YDOT, RPAR, IPAR) C DOUBLE COMPLEX Y(NEQ), YDOT(NEQ) C DOUBLE PRECISION T C where NEQ, T, and Y are input, and the array YDOT = f(t,y) C is output. Y and YDOT are double complex arrays of length C NEQ. Subroutine F should not alter Y(1),...,Y(NEQ). C F must be declared EXTERNAL in the calling program. C C Subroutine F may access user-defined real/complex and C integer work arrays RPAR and IPAR, which are to be C dimensioned in the calling program. C C If quantities computed in the F routine are needed C externally to ZVODE, an extra call to F should be made C for this purpose, for consistent and accurate results. C If only the derivative dy/dt is needed, use ZVINDY instead. C C NEQ = The size of the ODE system (number of first order C ordinary differential equations). Used only for input. C NEQ may not be increased during the problem, but C can be decreased (with ISTATE = 3 in the input). C C Y = A double precision complex array for the vector of dependent C variables, of length NEQ or more. Used for both input and C output on the first call (ISTATE = 1), and only for output C on other calls. On the first call, Y must contain the C vector of initial values. In the output, Y contains the C computed solution evaluated at T. If desired, the Y array C may be used for other purposes between calls to the solver. C C This array is passed as the Y argument in all calls to C F and JAC. C C T = The independent variable. In the input, T is used only on C the first call, as the initial point of the integration. C In the output, after each call, T is the value at which a C computed solution Y is evaluated (usually the same as TOUT). C On an error return, T is the farthest point reached. C C TOUT = The next value of t at which a computed solution is desired. C Used only for input. C C When starting the problem (ISTATE = 1), TOUT may be equal C to T for one call, then should .ne. T for the next call. C For the initial T, an input value of TOUT .ne. T is used C in order to determine the direction of the integration C (i.e. the algebraic sign of the step sizes) and the rough C scale of the problem. Integration in either direction C (forward or backward in t) is permitted. C C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after C the first call (i.e. the first call with TOUT .ne. T). C Otherwise, TOUT is required on every call. C C If ITASK = 1, 3, or 4, the values of TOUT need not be C monotone, but a value of TOUT which backs up is limited C to the current internal t interval, whose endpoints are C TCUR - HU and TCUR. (See optional output, below, for C TCUR and HU.) C C ITOL = An indicator for the type of error control. See C description below under ATOL. Used only for input. C C RTOL = A relative error tolerance parameter, either a scalar or C an array of length NEQ. See description below under ATOL. C Input only. C C ATOL = An absolute error tolerance parameter, either a scalar or C an array of length NEQ. Input only. C C The input parameters ITOL, RTOL, and ATOL determine C the error control performed by the solver. The solver will C control the vector e = (e(i)) of estimated local errors C in Y, according to an inequality of the form C rms-norm of ( e(i)/EWT(i) ) .le. 1, C where EWT(i) = RTOL(i)*abs(Y(i)) + ATOL(i), C and the rms-norm (root-mean-square norm) here is C rms-norm(v) = sqrt(sum v(i)**2 / NEQ). Here EWT = (EWT(i)) C is a vector of weights which must always be positive, and C the values of RTOL and ATOL should all be non-negative. C The following table gives the types (scalar/array) of C RTOL and ATOL, and the corresponding form of EWT(i). C C ITOL RTOL ATOL EWT(i) C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) C C When either of these parameters is a scalar, it need not C be dimensioned in the user's calling program. C C If none of the above choices (with ITOL, RTOL, and ATOL C fixed throughout the problem) is suitable, more general C error controls can be obtained by substituting C user-supplied routines for the setting of EWT and/or for C the norm calculation. See Part iv below. C C If global errors are to be estimated by making a repeated C run on the same problem with smaller tolerances, then all C components of RTOL and ATOL (i.e. of EWT) should be scaled C down uniformly. C C ITASK = An index specifying the task to be performed. C Input only. ITASK has the following values and meanings. C 1 means normal computation of output values of y(t) at C t = TOUT (by overshooting and interpolating). C 2 means take one step only and return. C 3 means stop at the first internal mesh point at or C beyond t = TOUT and return. C 4 means normal computation of output values of y(t) at C t = TOUT but without overshooting t = TCRIT. C TCRIT must be input as RWORK(1). TCRIT may be equal to C or beyond TOUT, but not behind it in the direction of C integration. This option is useful if the problem C has a singularity at or beyond t = TCRIT. C 5 means take one step, without passing TCRIT, and return. C TCRIT must be input as RWORK(1). C C Note: If ITASK = 4 or 5 and the solver reaches TCRIT C (within roundoff), it will return T = TCRIT (exactly) to C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, C in which case answers at T = TOUT are returned first). C C ISTATE = an index used for input and output to specify the C the state of the calculation. C C In the input, the values of ISTATE are as follows. C 1 means this is the first call for the problem C (initializations will be done). See note below. C 2 means this is not the first call, and the calculation C is to continue normally, with no change in any input C parameters except possibly TOUT and ITASK. C (If ITOL, RTOL, and/or ATOL are changed between calls C with ISTATE = 2, the new values will be used but not C tested for legality.) C 3 means this is not the first call, and the C calculation is to continue normally, but with C a change in input parameters other than C TOUT and ITASK. Changes are allowed in C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, ML, MU, C and any of the optional input except H0. C (See IWORK description for ML and MU.) C Note: A preliminary call with TOUT = T is not counted C as a first call here, as no initialization or checking of C input is done. (Such a call is sometimes useful to include C the initial conditions in the output.) C Thus the first call for which TOUT .ne. T requires C ISTATE = 1 in the input. C C In the output, ISTATE has the following values and meanings. C 1 means nothing was done, as TOUT was equal to T with C ISTATE = 1 in the input. C 2 means the integration was performed successfully. C -1 means an excessive amount of work (more than MXSTEP C steps) was done on this call, before completing the C requested task, but the integration was otherwise C successful as far as T. (MXSTEP is an optional input C and is normally 500.) To continue, the user may C simply reset ISTATE to a value .gt. 1 and call again. C (The excess work step counter will be reset to 0.) C In addition, the user may increase MXSTEP to avoid C this error return. (See optional input below.) C -2 means too much accuracy was requested for the precision C of the machine being used. This was detected before C completing the requested task, but the integration C was successful as far as T. To continue, the tolerance C parameters must be reset, and ISTATE must be set C to 3. The optional output TOLSF may be used for this C purpose. (Note: If this condition is detected before C taking any steps, then an illegal input return C (ISTATE = -3) occurs instead.) C -3 means illegal input was detected, before taking any C integration steps. See written message for details. C Note: If the solver detects an infinite loop of calls C to the solver with illegal input, it will cause C the run to stop. C -4 means there were repeated error test failures on C one attempted step, before completing the requested C task, but the integration was successful as far as T. C The problem may have a singularity, or the input C may be inappropriate. C -5 means there were repeated convergence test failures on C one attempted step, before completing the requested C task, but the integration was successful as far as T. C This may be caused by an inaccurate Jacobian matrix, C if one is being used. C -6 means EWT(i) became zero for some i during the C integration. Pure relative error control (ATOL(i)=0.0) C was requested on a variable which has now vanished. C The integration was successful as far as T. C C Note: Since the normal output value of ISTATE is 2, C it does not need to be reset for normal continuation. C Also, since a negative input value of ISTATE will be C regarded as illegal, a negative output value requires the C user to change it, and possibly other input, before C calling the solver again. C C IOPT = An integer flag to specify whether or not any optional C input is being used on this call. Input only. C The optional input is listed separately below. C IOPT = 0 means no optional input is being used. C Default values will be used in all cases. C IOPT = 1 means optional input is being used. C C ZWORK = A double precision complex working array. C The length of ZWORK must be at least C NYH*(MAXORD + 1) + 2*NEQ + LWM where C NYH = the initial value of NEQ, C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a C smaller value is given as an optional input), C LWM = length of work space for matrix-related data: C LWM = 0 if MITER = 0, C LWM = 2*NEQ**2 if MITER = 1 or 2, and MF.gt.0, C LWM = NEQ**2 if MITER = 1 or 2, and MF.lt.0, C LWM = NEQ if MITER = 3, C LWM = (3*ML+2*MU+2)*NEQ if MITER = 4 or 5, and MF.gt.0, C LWM = (2*ML+MU+1)*NEQ if MITER = 4 or 5, and MF.lt.0. C (See the MF description for METH and MITER.) C Thus if MAXORD has its default value and NEQ is constant, C this length is: C 15*NEQ for MF = 10, C 15*NEQ + 2*NEQ**2 for MF = 11 or 12, C 15*NEQ + NEQ**2 for MF = -11 or -12, C 16*NEQ for MF = 13, C 17*NEQ + (3*ML+2*MU)*NEQ for MF = 14 or 15, C 16*NEQ + (2*ML+MU)*NEQ for MF = -14 or -15, C 8*NEQ for MF = 20, C 8*NEQ + 2*NEQ**2 for MF = 21 or 22, C 8*NEQ + NEQ**2 for MF = -21 or -22, C 9*NEQ for MF = 23, C 10*NEQ + (3*ML+2*MU)*NEQ for MF = 24 or 25. C 9*NEQ + (2*ML+MU)*NEQ for MF = -24 or -25. C C LZW = The length of the array ZWORK, as declared by the user. C (This will be checked by the solver.) C C RWORK = A real working array (double precision). C The length of RWORK must be at least 20 + NEQ. C The first 20 words of RWORK are reserved for conditional C and optional input and optional output. C C The following word in RWORK is a conditional input: C RWORK(1) = TCRIT = critical value of t which the solver C is not to overshoot. Required if ITASK is C 4 or 5, and ignored otherwise. (See ITASK.) C C LRW = The length of the array RWORK, as declared by the user. C (This will be checked by the solver.) C C IWORK = An integer work array. The length of IWORK must be at least C 30 if MITER = 0 or 3 (MF = 10, 13, 20, 23), or C 30 + NEQ otherwise (abs(MF) = 11,12,14,15,21,22,24,25). C The first 30 words of IWORK are reserved for conditional and C optional input and optional output. C C The following 2 words in IWORK are conditional input: C IWORK(1) = ML These are the lower and upper C IWORK(2) = MU half-bandwidths, respectively, of the C banded Jacobian, excluding the main diagonal. C The band is defined by the matrix locations C (i,j) with i-ML .le. j .le. i+MU. ML and MU C must satisfy 0 .le. ML,MU .le. NEQ-1. C These are required if MITER is 4 or 5, and C ignored otherwise. ML and MU may in fact be C the band parameters for a matrix to which C df/dy is only approximately equal. C C LIW = the length of the array IWORK, as declared by the user. C (This will be checked by the solver.) C C Note: The work arrays must not be altered between calls to ZVODE C for the same problem, except possibly for the conditional and C optional input, and except for the last 2*NEQ words of ZWORK and C the last NEQ words of RWORK. The latter space is used for internal C scratch space, and so is available for use by the user outside ZVODE C between calls, if desired (but not for use by F or JAC). C C JAC = The name of the user-supplied routine (MITER = 1 or 4) to C compute the Jacobian matrix, df/dy, as a function of C the scalar t and the vector y. It is to have the form C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, C RPAR, IPAR) C DOUBLE COMPLEX Y(NEQ), PD(NROWPD,NEQ) C DOUBLE PRECISION T C where NEQ, T, Y, ML, MU, and NROWPD are input and the array C PD is to be loaded with partial derivatives (elements of the C Jacobian matrix) in the output. PD must be given a first C dimension of NROWPD. T and Y have the same meaning as in C Subroutine F. C In the full matrix case (MITER = 1), ML and MU are C ignored, and the Jacobian is to be loaded into PD in C columnwise manner, with df(i)/dy(j) loaded into PD(i,j). C In the band matrix case (MITER = 4), the elements C within the band are to be loaded into PD in columnwise C manner, with diagonal lines of df/dy loaded into the rows C of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). C ML and MU are the half-bandwidth parameters. (See IWORK). C The locations in PD in the two triangular areas which C correspond to nonexistent matrix elements can be ignored C or loaded arbitrarily, as they are overwritten by ZVODE. C JAC need not provide df/dy exactly. A crude C approximation (possibly with a smaller bandwidth) will do. C In either case, PD is preset to zero by the solver, C so that only the nonzero elements need be loaded by JAC. C Each call to JAC is preceded by a call to F with the same C arguments NEQ, T, and Y. Thus to gain some efficiency, C intermediate quantities shared by both calculations may be C saved in a user COMMON block by F and not recomputed by JAC, C if desired. Also, JAC may alter the Y array, if desired. C JAC must be declared external in the calling program. C Subroutine JAC may access user-defined real/complex and C integer work arrays, RPAR and IPAR, whose dimensions are set C by the user in the calling program. C C MF = The method flag. Used only for input. The legal values of C MF are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, 25, C -11, -12, -14, -15, -21, -22, -24, -25. C MF is a signed two-digit integer, MF = JSV*(10*METH + MITER). C JSV = SIGN(MF) indicates the Jacobian-saving strategy: C JSV = 1 means a copy of the Jacobian is saved for reuse C in the corrector iteration algorithm. C JSV = -1 means a copy of the Jacobian is not saved C (valid only for MITER = 1, 2, 4, or 5). C METH indicates the basic linear multistep method: C METH = 1 means the implicit Adams method. C METH = 2 means the method based on backward C differentiation formulas (BDF-s). C MITER indicates the corrector iteration method: C MITER = 0 means functional iteration (no Jacobian matrix C is involved). C MITER = 1 means chord iteration with a user-supplied C full (NEQ by NEQ) Jacobian. C MITER = 2 means chord iteration with an internally C generated (difference quotient) full Jacobian C (using NEQ extra calls to F per df/dy value). C MITER = 3 means chord iteration with an internally C generated diagonal Jacobian approximation C (using 1 extra call to F per df/dy evaluation). C MITER = 4 means chord iteration with a user-supplied C banded Jacobian. C MITER = 5 means chord iteration with an internally C generated banded Jacobian (using ML+MU+1 extra C calls to F per df/dy evaluation). C If MITER = 1 or 4, the user must supply a subroutine JAC C (the name is arbitrary) as described above under JAC. C For other values of MITER, a dummy argument can be used. C C RPAR User-specified array used to communicate real or complex C parameters to user-supplied subroutines. If RPAR is an C array, it must be dimensioned in the user's calling program; C if it is unused or it is a scalar, then it need not be C dimensioned. The type of RPAR may be REAL, DOUBLE, COMPLEX, C or DOUBLE COMPLEX, depending on the user program's needs. C RPAR is not type-declared within ZVODE, but simply passed C (by address) to the user's F and JAC routines. C C IPAR User-specified array used to communicate integer parameter C to user-supplied subroutines. If IPAR is an array, it must C be dimensioned in the user's calling program. C----------------------------------------------------------------------- C Optional Input. C C The following is a list of the optional input provided for in the C call sequence. (See also Part ii.) For each such input variable, C this table lists its name as used in this documentation, its C location in the call sequence, its meaning, and the default value. C The use of any of this input requires IOPT = 1, and in that C case all of this input is examined. A value of zero for any C of these optional input variables will cause the default value to be C used. Thus to use a subset of the optional input, simply preload C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and C then set those of interest to nonzero values. C C NAME LOCATION MEANING AND DEFAULT VALUE C C H0 RWORK(5) The step size to be attempted on the first step. C The default value is determined by the solver. C C HMAX RWORK(6) The maximum absolute step size allowed. C The default value is infinite. C C HMIN RWORK(7) The minimum absolute step size allowed. C The default value is 0. (This lower bound is not C enforced on the final step before reaching TCRIT C when ITASK = 4 or 5.) C C MAXORD IWORK(5) The maximum order to be allowed. The default C value is 12 if METH = 1, and 5 if METH = 2. C If MAXORD exceeds the default value, it will C be reduced to the default value. C If MAXORD is changed during the problem, it may C cause the current order to be reduced. C C MXSTEP IWORK(6) Maximum number of (internally defined) steps C allowed during one call to the solver. C The default value is 500. C C MXHNIL IWORK(7) Maximum number of messages printed (per problem) C warning that T + H = T on a step (H = step size). C This must be positive to result in a non-default C value. The default value is 10. C C----------------------------------------------------------------------- C Optional Output. C C As optional additional output from ZVODE, the variables listed C below are quantities related to the performance of ZVODE C which are available to the user. These are communicated by way of C the work arrays, but also have internal mnemonic names as shown. C Except where stated otherwise, all of this output is defined C on any successful return from ZVODE, and on any return with C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return C (ISTATE = -3), they will be unchanged from their existing values C (if any), except possibly for TOLSF, LENZW, LENRW, and LENIW. C On any error return, output relevant to the error will be defined, C as noted below. C C NAME LOCATION MEANING C C HU RWORK(11) The step size in t last used (successfully). C C HCUR RWORK(12) The step size to be attempted on the next step. C C TCUR RWORK(13) The current value of the independent variable C which the solver has actually reached, i.e. the C current internal mesh point in t. In the output, C TCUR will always be at least as far from the C initial value of t as the current argument T, C but may be farther (if interpolation was done). C C TOLSF RWORK(14) A tolerance scale factor, greater than 1.0, C computed when a request for too much accuracy was C detected (ISTATE = -3 if detected at the start of C the problem, ISTATE = -2 otherwise). If ITOL is C left unaltered but RTOL and ATOL are uniformly C scaled up by a factor of TOLSF for the next call, C then the solver is deemed likely to succeed. C (The user may also ignore TOLSF and alter the C tolerance parameters in any other way appropriate.) C C NST IWORK(11) The number of steps taken for the problem so far. C C NFE IWORK(12) The number of f evaluations for the problem so far. C C NJE IWORK(13) The number of Jacobian evaluations so far. C C NQU IWORK(14) The method order last used (successfully). C C NQCUR IWORK(15) The order to be attempted on the next step. C C IMXER IWORK(16) The index of the component of largest magnitude in C the weighted local error vector ( e(i)/EWT(i) ), C on an error return with ISTATE = -4 or -5. C C LENZW IWORK(17) The length of ZWORK actually required. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C LENRW IWORK(18) The length of RWORK actually required. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C LENIW IWORK(19) The length of IWORK actually required. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C NLU IWORK(20) The number of matrix LU decompositions so far. C C NNI IWORK(21) The number of nonlinear (Newton) iterations so far. C C NCFN IWORK(22) The number of convergence failures of the nonlinear C solver so far. C C NETF IWORK(23) The number of error test failures of the integrator C so far. C C The following two arrays are segments of the ZWORK array which C may also be of interest to the user as optional output. C For each array, the table below gives its internal name, C its base address in ZWORK, and its description. C C NAME BASE ADDRESS DESCRIPTION C C YH 1 The Nordsieck history array, of size NYH by C (NQCUR + 1), where NYH is the initial value C of NEQ. For j = 0,1,...,NQCUR, column j+1 C of YH contains HCUR**j/factorial(j) times C the j-th derivative of the interpolating C polynomial currently representing the C solution, evaluated at t = TCUR. C C ACOR LENZW-NEQ+1 Array of size NEQ used for the accumulated C corrections on each step, scaled in the output C to represent the estimated local error in Y C on the last step. This is the vector e in C the description of the error control. It is C defined only on a successful return from ZVODE. C C----------------------------------------------------------------------- C Interrupting and Restarting C C If the integration of a given problem by ZVODE is to be C interrrupted and then later continued, such as when restarting C an interrupted run or alternating between two or more ODE problems, C the user should save, following the return from the last ZVODE call C prior to the interruption, the contents of the call sequence C variables and internal COMMON blocks, and later restore these C values before the next ZVODE call for that problem. To save C and restore the COMMON blocks, use subroutine ZVSRCO, as C described below in part ii. C C In addition, if non-default values for either LUN or MFLAG are C desired, an extra call to XSETUN and/or XSETF should be made just C before continuing the integration. See Part ii below for details. C C----------------------------------------------------------------------- C Part ii. Other Routines Callable. C C The following are optional calls which the user may make to C gain additional capabilities in conjunction with ZVODE. C (The routines XSETUN and XSETF are designed to conform to the C SLATEC error handling package.) C C FORM OF CALL FUNCTION C CALL XSETUN(LUN) Set the logical unit number, LUN, for C output of messages from ZVODE, if C the default is not desired. C The default value of LUN is 6. C C CALL XSETF(MFLAG) Set a flag to control the printing of C messages by ZVODE. C MFLAG = 0 means do not print. (Danger: C This risks losing valuable information.) C MFLAG = 1 means print (the default). C C Either of the above calls may be made at C any time and will take effect immediately. C C CALL ZVSRCO(RSAV,ISAV,JOB) Saves and restores the contents of C the internal COMMON blocks used by C ZVODE. (See Part iii below.) C RSAV must be a real array of length 51 C or more, and ISAV must be an integer C array of length 40 or more. C JOB=1 means save COMMON into RSAV/ISAV. C JOB=2 means restore COMMON from RSAV/ISAV. C ZVSRCO is useful if one is C interrupting a run and restarting C later, or alternating between two or C more problems solved with ZVODE. C C CALL ZVINDY(,,,,,) Provide derivatives of y, of various C (See below.) orders, at a specified point T, if C desired. It may be called only after C a successful return from ZVODE. C C The detailed instructions for using ZVINDY are as follows. C The form of the call is: C C CALL ZVINDY (T, K, ZWORK, NYH, DKY, IFLAG) C C The input parameters are: C C T = Value of independent variable where answers are desired C (normally the same as the T last returned by ZVODE). C For valid results, T must lie between TCUR - HU and TCUR. C (See optional output for TCUR and HU.) C K = Integer order of the derivative desired. K must satisfy C 0 .le. K .le. NQCUR, where NQCUR is the current order C (see optional output). The capability corresponding C to K = 0, i.e. computing y(T), is already provided C by ZVODE directly. Since NQCUR .ge. 1, the first C derivative dy/dt is always available with ZVINDY. C ZWORK = The history array YH. C NYH = Column length of YH, equal to the initial value of NEQ. C C The output parameters are: C C DKY = A double complex array of length NEQ containing the C computed value of the K-th derivative of y(t). C IFLAG = Integer flag, returned as 0 if K and T were legal, C -1 if K was illegal, and -2 if T was illegal. C On an error return, a message is also written. C----------------------------------------------------------------------- C Part iii. COMMON Blocks. C If ZVODE is to be used in an overlay situation, the user C must declare, in the primary overlay, the variables in: C (1) the call sequence to ZVODE, C (2) the two internal COMMON blocks C /ZVOD01/ of length 83 (50 double precision words C followed by 33 integer words), C /ZVOD02/ of length 9 (1 double precision word C followed by 8 integer words), C C If ZVODE is used on a system in which the contents of internal C COMMON blocks are not preserved between calls, the user should C declare the above two COMMON blocks in his calling program to insure C that their contents are preserved. C C----------------------------------------------------------------------- C Part iv. Optionally Replaceable Solver Routines. C C Below are descriptions of two routines in the ZVODE package which C relate to the measurement of errors. Either routine can be C replaced by a user-supplied version, if desired. However, since such C a replacement may have a major impact on performance, it should be C done only when absolutely necessary, and only with great caution. C (Note: The means by which the package version of a routine is C superseded by the user's version may be system-dependent.) C C (a) ZEWSET. C The following subroutine is called just before each internal C integration step, and sets the array of error weights, EWT, as C described under ITOL/RTOL/ATOL above: C SUBROUTINE ZEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) C where NEQ, ITOL, RTOL, and ATOL are as in the ZVODE call sequence, C YCUR contains the current (double complex) dependent variable vector, C and EWT is the array of weights set by ZEWSET. C C If the user supplies this subroutine, it must return in EWT(i) C (i = 1,...,NEQ) a positive quantity suitable for comparison with C errors in Y(i). The EWT array returned by ZEWSET is passed to the C ZVNORM routine (See below.), and also used by ZVODE in the computation C of the optional output IMXER, the diagonal Jacobian approximation, C and the increments for difference quotient Jacobians. C C In the user-supplied version of ZEWSET, it may be desirable to use C the current values of derivatives of y. Derivatives up to order NQ C are available from the history array YH, described above under C Optional Output. In ZEWSET, YH is identical to the YCUR array, C extended to NQ + 1 columns with a column length of NYH and scale C factors of h**j/factorial(j). On the first call for the problem, C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. C NYH is the initial value of NEQ. The quantities NQ, H, and NST C can be obtained by including in ZEWSET the statements: C DOUBLE PRECISION RVOD, H, HU C COMMON /ZVOD01/ RVOD(50), IVOD(33) C COMMON /ZVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C NQ = IVOD(28) C H = RVOD(21) C Thus, for example, the current value of dy/dt can be obtained as C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is C unnecessary when NST = 0). C C (b) ZVNORM. C The following is a real function routine which computes the weighted C root-mean-square norm of a vector v: C D = ZVNORM (N, V, W) C where: C N = the length of the vector, C V = double complex array of length N containing the vector, C W = real array of length N containing weights, C D = sqrt( (1/N) * sum(abs(V(i))*W(i))**2 ). C ZVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where C EWT is as set by subroutine ZEWSET. C C If the user supplies this function, it should return a non-negative C value of ZVNORM suitable for use in the error control in ZVODE. C None of the arguments should be altered by ZVNORM. C For example, a user-supplied ZVNORM routine might: C -substitute a max-norm of (V(i)*W(i)) for the rms-norm, or C -ignore some components of V in the norm, with the effect of C suppressing the error control on those components of Y. C----------------------------------------------------------------------- C REVISION HISTORY (YYYYMMDD) C 20060517 DATE WRITTEN, modified from DVODE of 20020430. C 20061227 Added note on use for analytic f. C----------------------------------------------------------------------- C Other Routines in the ZVODE Package. C C In addition to Subroutine ZVODE, the ZVODE package includes the C following subroutines and function routines: C ZVHIN computes an approximate step size for the initial step. C ZVINDY computes an interpolated value of the y vector at t = TOUT. C ZVSTEP is the core integrator, which does one step of the C integration and the associated error control. C ZVSET sets all method coefficients and test constants. C ZVNLSD solves the underlying nonlinear system -- the corrector. C ZVJAC computes and preprocesses the Jacobian matrix J = df/dy C and the Newton iteration matrix P = I - (h/l1)*J. C ZVSOL manages solution of linear system in chord iteration. C ZVJUST adjusts the history array on a change of order. C ZEWSET sets the error weight vector EWT before each step. C ZVNORM computes the weighted r.m.s. norm of a vector. C ZABSSQ computes the squared absolute value of a double complex z. C ZVSRCO is a user-callable routine to save and restore C the contents of the internal COMMON blocks. C ZACOPY is a routine to copy one two-dimensional array to another. C ZGEFA and ZGESL are routines from LINPACK for solving full C systems of linear algebraic equations. C ZGBFA and ZGBSL are routines from LINPACK for solving banded C linear systems. C DZSCAL scales a double complex array by a double prec. scalar. C DZAXPY adds a D.P. scalar times one complex vector to another. C ZCOPY is a basic linear algebra module from the BLAS. C DUMACH sets the unit roundoff of the machine. C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all C error messages and warnings. XERRWD is machine-dependent. C Note: ZVNORM, ZABSSQ, DUMACH, IXSAV, and IUMACH are function routines. C All the others are subroutines. C The intrinsic functions called with double precision complex arguments C are: ABS, DREAL, and DIMAG. All of these are expected to return C double precision real values. C C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block ZVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 4 NSLP, NYH C C Type declarations for labeled COMMON block ZVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C EXTERNAL ZVNLSD LOGICAL IHIT DOUBLE PRECISION ATOLI, BIG, EWTI, FOUR, H0, HMAX, HMX, HUN, ONE, 1 PT2, RH, RTOLI, SIZE, TCRIT, TNEXT, TOLSF, TP, TWO, ZERO INTEGER I, IER, IFLAG, IMXER, JCO, KGO, LENIW, LENJ, LENP, LENZW, 1 LENRW, LENWM, LF0, MBAND, MFA, ML, MORD, MU, MXHNL0, MXSTP0, 2 NITER, NSLAST CHARACTER(LEN=80) MSG C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION DUMACH, ZVNORM C DIMENSION MORD(2) C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to ZVODE. C----------------------------------------------------------------------- SAVE MORD, MXHNL0, MXSTP0 SAVE ZERO, ONE, TWO, FOUR, PT2, HUN C----------------------------------------------------------------------- C The following internal COMMON blocks contain variables which are C communicated between subroutines in the ZVODE package, or which are C to be saved between calls to ZVODE. C In each block, real variables precede integers. C The block /ZVOD01/ appears in subroutines ZVODE, ZVINDY, ZVSTEP, C ZVSET, ZVNLSD, ZVJAC, ZVSOL, ZVJUST and ZVSRCO. C The block /ZVOD02/ appears in subroutines ZVODE, ZVINDY, ZVSTEP, C ZVNLSD, ZVJAC, and ZVSRCO. C C The variables stored in the internal COMMON blocks are as follows: C C ACNRM = Weighted r.m.s. norm of accumulated correction vectors. C CCMXJ = Threshhold on DRC for updating the Jacobian. (See DRC.) C CONP = The saved value of TQ(5). C CRATE = Estimated corrector convergence rate constant. C DRC = Relative change in H*RL1 since last ZVJAC call. C EL = Real array of integration coefficients. See ZVSET. C ETA = Saved tentative ratio of new to old H. C ETAMAX = Saved maximum value of ETA to be allowed. C H = The step size. C HMIN = The minimum absolute value of the step size H to be used. C HMXI = Inverse of the maximum absolute value of H to be used. C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. C HNEW = The step size to be attempted on the next step. C HRL1 = Saved value of H*RL1. C HSCAL = Stepsize in scaling of YH array. C PRL1 = The saved value of RL1. C RC = Ratio of current H*RL1 to value on last ZVJAC call. C RL1 = The reciprocal of the coefficient EL(1). C SRUR = Sqrt(UROUND), used in difference quotient algorithms. C TAU = Real vector of past NQ step sizes, length 13. C TQ = A real vector of length 5 in which ZVSET stores constants C used for the convergence test, the error test, and the C selection of H at a new order. C TN = The independent variable, updated on each step taken. C UROUND = The machine unit roundoff. The smallest positive real number C such that 1.0 + UROUND .ne. 1.0 C ICF = Integer flag for convergence failure in ZVNLSD: C 0 means no failures. C 1 means convergence failure with out of date Jacobian C (recoverable error). C 2 means convergence failure with current Jacobian or C singular matrix (unrecoverable error). C INIT = Saved integer flag indicating whether initialization of the C problem has been done (INIT = 1) or not. C IPUP = Saved flag to signal updating of Newton matrix. C JCUR = Output flag from ZVJAC showing Jacobian status: C JCUR = 0 means J is not current. C JCUR = 1 means J is current. C JSTART = Integer flag used as input to ZVSTEP: C 0 means perform the first step. C 1 means take a new step continuing from the last. C -1 means take the next step with a new value of MAXORD, C HMIN, HMXI, N, METH, MITER, and/or matrix parameters. C On return, ZVSTEP sets JSTART = 1. C JSV = Integer flag for Jacobian saving, = sign(MF). C KFLAG = A completion code from ZVSTEP with the following meanings: C 0 the step was succesful. C -1 the requested error could not be achieved. C -2 corrector convergence could not be achieved. C -3, -4 fatal error in VNLS (can not occur here). C KUTH = Input flag to ZVSTEP showing whether H was reduced by the C driver. KUTH = 1 if H was reduced, = 0 otherwise. C L = Integer variable, NQ + 1, current order plus one. C LMAX = MAXORD + 1 (used for dimensioning). C LOCJS = A pointer to the saved Jacobian, whose storage starts at C WM(LOCJS), if JSV = 1. C LYH, LEWT, LACOR, LSAVF, LWM, LIWM = Saved integer pointers C to segments of ZWORK, RWORK, and IWORK. C MAXORD = The maximum order of integration method to be allowed. C METH/MITER = The method flags. See MF. C MSBJ = The maximum number of steps between J evaluations, = 50. C MXHNIL = Saved value of optional input MXHNIL. C MXSTEP = Saved value of optional input MXSTEP. C N = The number of first-order ODEs, = NEQ. C NEWH = Saved integer to flag change of H. C NEWQ = The method order to be used on the next step. C NHNIL = Saved counter for occurrences of T + H = T. C NQ = Integer variable, the current integration method order. C NQNYH = Saved value of NQ*NYH. C NQWAIT = A counter controlling the frequency of order changes. C An order change is about to be considered if NQWAIT = 1. C NSLJ = The number of steps taken as of the last Jacobian update. C NSLP = Saved value of NST as of last Newton matrix update. C NYH = Saved value of the initial value of NEQ. C HU = The step size in t last used. C NCFN = Number of nonlinear convergence failures so far. C NETF = The number of error test failures of the integrator so far. C NFE = The number of f evaluations for the problem so far. C NJE = The number of Jacobian evaluations so far. C NLU = The number of matrix LU decompositions so far. C NNI = Number of nonlinear iterations so far. C NQU = The method order last used. C NST = The number of steps taken for the problem so far. C----------------------------------------------------------------------- COMMON /ZVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), ETA, 1 ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU(13), TQ(5), TN, UROUND, 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 7 NSLP, NYH COMMON /ZVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA MORD(1) /12/, MORD(2) /5/, MXSTP0 /500/, MXHNL0 /10/ DATA ZERO /0.0D0/, ONE /1.0D0/, TWO /2.0D0/, FOUR /4.0D0/, 1 PT2 /0.2D0/, HUN /100.0D0/ C----------------------------------------------------------------------- C Block A. C This code block is executed on every call. C It tests ISTATE and ITASK for legality and branches appropriately. C If ISTATE .gt. 1 but the flag INIT shows that initialization has C not yet been done, an error return occurs. C If ISTATE = 1 and TOUT = T, return immediately. C----------------------------------------------------------------------- C KARLINE: INITIALISED IHIT TO AVOID COMPILER WARNINGS - SHOULD HAVE NO EFFEXT IHIT = .TRUE. IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 IF (ISTATE .EQ. 1) GO TO 10 IF (INIT .NE. 1) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) RETURN C----------------------------------------------------------------------- C Block B. C The next code block is executed for the initial call (ISTATE = 1), C or for a continuation call with parameter changes (ISTATE = 3). C It contains checking of all input and various initializations. C C First check legality of the non-optional input NEQ, ITOL, IOPT, C MF, ML, and MU. C----------------------------------------------------------------------- 20 IF (NEQ .LE. 0) GO TO 604 IF (ISTATE .EQ. 1) GO TO 25 IF (NEQ .GT. N) GO TO 605 25 N = NEQ IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 JSV = SIGN(1,MF) MFA = ABS(MF) METH = MFA/10 MITER = MFA - 10*METH IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 IF (MITER .LE. 3) GO TO 30 ML = IWORK(1) MU = IWORK(2) IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 30 CONTINUE C Next process and check the optional input. --------------------------- IF (IOPT .EQ. 1) GO TO 40 MAXORD = MORD(METH) MXSTEP = MXSTP0 MXHNIL = MXHNL0 IF (ISTATE .EQ. 1) H0 = ZERO HMXI = ZERO HMIN = ZERO GO TO 60 40 MAXORD = IWORK(5) IF (MAXORD .LT. 0) GO TO 611 IF (MAXORD .EQ. 0) MAXORD = 100 MAXORD = MIN(MAXORD,MORD(METH)) MXSTEP = IWORK(6) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .NE. 1) GO TO 50 H0 = RWORK(5) IF ((TOUT - T)*H0 .LT. ZERO) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. ZERO) GO TO 615 HMXI = ZERO IF (HMAX .GT. ZERO) HMXI = ONE/HMAX HMIN = RWORK(7) IF (HMIN .LT. ZERO) GO TO 616 C----------------------------------------------------------------------- C Set work array pointers and check lengths LZW, LRW, and LIW. C Pointers to segments of ZWORK, RWORK, and IWORK are named by prefixing C L to the name of the segment. E.g., segment YH starts at ZWORK(LYH). C Segments of ZWORK (in order) are denoted YH, WM, SAVF, ACOR. C Besides optional inputs/outputs, RWORK has only the segment EWT. C Within WM, LOCJS is the location of the saved Jacobian (JSV .gt. 0). C----------------------------------------------------------------------- 60 LYH = 1 IF (ISTATE .EQ. 1) NYH = N LWM = LYH + (MAXORD + 1)*NYH JCO = MAX(0,JSV) IF (MITER .EQ. 0) LENWM = 0 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN LENWM = (1 + JCO)*N*N LOCJS = N*N + 1 ENDIF IF (MITER .EQ. 3) LENWM = N IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN MBAND = ML + MU + 1 LENP = (MBAND + ML)*N LENJ = MBAND*N LENWM = LENP + JCO*LENJ LOCJS = LENP + 1 ENDIF LSAVF = LWM + LENWM LACOR = LSAVF + N LENZW = LACOR + N - 1 IWORK(17) = LENZW LEWT = 21 LENRW = 20 + N IWORK(18) = LENRW LIWM = 1 LENIW = 30 + N IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 30 IWORK(19) = LENIW IF (LENZW .GT. LZW) GO TO 628 IF (LENRW .GT. LRW) GO TO 617 IF (LENIW .GT. LIW) GO TO 618 C Check RTOL and ATOL for legality. ------------------------------------ RTOLI = RTOL(1) ATOLI = ATOL(1) DO 70 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. ZERO) GO TO 619 IF (ATOLI .LT. ZERO) GO TO 620 70 CONTINUE IF (ISTATE .EQ. 1) GO TO 100 C If ISTATE = 3, set flag to signal parameter changes to ZVSTEP. ------- JSTART = -1 IF (NQ .LE. MAXORD) GO TO 200 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- CALL ZCOPY (N, ZWORK(LWM), 1, ZWORK(LSAVF), 1) GO TO 200 C----------------------------------------------------------------------- C Block C. C The next block is for the initial call only (ISTATE = 1). C It contains all remaining initializations, the initial call to F, C and the calculation of the initial step size. C The error weights in EWT are inverted after being loaded. C----------------------------------------------------------------------- 100 UROUND = DUMACH() TN = T IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. ZERO) GO TO 625 IF (H0 .NE. ZERO .AND. (T + H0 - TCRIT)*H0 .GT. ZERO) 1 H0 = TCRIT - T 110 JSTART = 0 IF (MITER .GT. 0) SRUR = SQRT(UROUND) CCMXJ = PT2 MSBJ = 50 NHNIL = 0 NST = 0 NJE = 0 NNI = 0 NCFN = 0 NETF = 0 NLU = 0 NSLJ = 0 NSLAST = 0 HU = ZERO NQU = 0 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- LF0 = LYH + NYH CALL F (N, T, Y, ZWORK(LF0), RPAR, IPAR) NFE = 1 C Load the initial value vector in YH. --------------------------------- CALL ZCOPY (N, Y, 1, ZWORK(LYH), 1) C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- NQ = 1 H = ONE CALL ZEWSET (N, ITOL, RTOL, ATOL, ZWORK(LYH), RWORK(LEWT)) DO 120 I = 1,N IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 621 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) 120 CONTINUE IF (H0 .NE. ZERO) GO TO 180 C Call ZVHIN to set initial step size H0 to be attempted. -------------- CALL ZVHIN (N, T, ZWORK(LYH), ZWORK(LF0), F, RPAR, IPAR, TOUT, 1 UROUND, RWORK(LEWT), ITOL, ATOL, Y, ZWORK(LACOR), H0, 2 NITER, IER) NFE = NFE + NITER IF (IER .NE. 0) GO TO 622 C Adjust H0 if necessary to meet HMAX bound. --------------------------- 180 RH = ABS(H0)*HMXI IF (RH .GT. ONE) H0 = H0/RH C Load H with H0 and scale YH(*,2) by H0. ------------------------------ H = H0 CALL DZSCAL (N, H0, ZWORK(LF0), 1) GO TO 270 C----------------------------------------------------------------------- C Block D. C The next code block is for continuation calls only (ISTATE = 2 or 3) C and is to check stop conditions before taking a step. C----------------------------------------------------------------------- 200 NSLAST = NST KUTH = 0 IF (ITASK .EQ. 1) THEN GOTO 210 ELSE IF (ITASK .EQ. 2) THEN GOTO 250 ELSE IF (ITASK .EQ. 3) THEN GOTO 220 ELSE IF (ITASK .EQ. 4) THEN GOTO 230 ELSE IF (ITASK .EQ. 5) THEN GOTO 240 ENDIF C GO TO (210, 250, 220, 230, 240), ITASK 210 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 CALL ZVINDY (TOUT, 0, ZWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(ONE + HUN*UROUND) IF ((TP - TOUT)*H .GT. ZERO) GO TO 623 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 IF ((TCRIT - TOUT)*H .LT. ZERO) GO TO 625 IF ((TN - TOUT)*H .LT. ZERO) GO TO 245 CALL ZVINDY (TOUT, 0, ZWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 245 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + HNEW*(ONE + FOUR*UROUND) IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 H = (TCRIT - TN)*(ONE - FOUR*UROUND) KUTH = 1 C----------------------------------------------------------------------- C Block E. C The next block is normally executed for all calls and contains C the call to the one-step core integrator ZVSTEP. C C This is a looping point for the integration steps. C C First check for too many steps being taken, update EWT (if not at C start of problem), check for too much accuracy being requested, and C check for H below the roundoff level in T. C----------------------------------------------------------------------- 250 CONTINUE IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL ZEWSET (N, ITOL, RTOL, ATOL, ZWORK(LYH), RWORK(LEWT)) DO 260 I = 1,N IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 510 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) 260 CONTINUE 270 TOLSF = UROUND*ZVNORM (N, ZWORK(LYH), RWORK(LEWT)) IF (TOLSF .LE. ONE) GO TO 280 TOLSF = TOLSF*TWO IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 MSG = 'ZVODE-- Warning: internal T (=R1) and H (=R2) are' CALL XERRWD (MSG, 50, 101, 1, 0, 0, 0, 0, ZERO, ZERO) MSG=' such that in the machine, T + H = T on the next step ' CALL XERRWD (MSG, 60, 101, 1, 0, 0, 0, 0, ZERO, ZERO) MSG = ' (H = step size). solver will continue anyway' CALL XERRWD (MSG, 50, 101, 1, 0, 0, 0, 2, TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 MSG = 'ZVODE-- Above warning has been issued I1 times. ' CALL XERRWD (MSG, 50, 102, 1, 0, 0, 0, 0, ZERO, ZERO) MSG = ' it will not be issued again for this problem' CALL XERRWD (MSG, 50, 102, 1, 1, MXHNIL, 0, 0, ZERO, ZERO) 290 CONTINUE C----------------------------------------------------------------------- C CALL ZVSTEP (Y, YH, NYH, YH, EWT, SAVF, VSAV, ACOR, C WM, IWM, F, JAC, F, ZVNLSD, RPAR, IPAR) C----------------------------------------------------------------------- CALL ZVSTEP (Y, ZWORK(LYH), NYH, ZWORK(LYH), RWORK(LEWT), 1 ZWORK(LSAVF), Y, ZWORK(LACOR), ZWORK(LWM), IWORK(LIWM), 2 F, JAC, F, ZVNLSD, RPAR, IPAR) KGO = 1 - KFLAG C Branch on KFLAG. Note: In this version, KFLAG can not be set to -3. C KFLAG .eq. 0, -1, -2 IF (KGO .EQ. 1) THEN GOTO 300 ELSE IF (KGO .EQ. 2) THEN GOTO 530 ELSE IF (KGO .EQ. 3) THEN GOTO 540 ENDIF C GO TO (300, 530, 540), KGO C----------------------------------------------------------------------- C Block F. C The following block handles the case of a successful return from the C core integrator (KFLAG = 0). Test for stop conditions. C----------------------------------------------------------------------- 300 INIT = 1 KUTH = 0 IF (ITASK .EQ. 1) THEN GOTO 310 ELSE IF (ITASK .EQ. 2) THEN GOTO 400 ELSE IF (ITASK .EQ. 3) THEN GOTO 330 ELSE IF (ITASK .EQ. 4) THEN GOTO 340 ELSE IF (ITASK .EQ. 5) THEN GOTO 350 ENDIF C GO TO (310, 400, 330, 340, 350), ITASK C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 310 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 CALL ZVINDY (TOUT, 0, ZWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 330 IF ((TN - TOUT)*H .GE. ZERO) GO TO 400 GO TO 250 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 340 IF ((TN - TOUT)*H .LT. ZERO) GO TO 345 CALL ZVINDY (TOUT, 0, ZWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 345 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + HNEW*(ONE + FOUR*UROUND) IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 H = (TCRIT - TN)*(ONE - FOUR*UROUND) KUTH = 1 GO TO 250 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 350 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX C----------------------------------------------------------------------- C Block G. C The following block handles all successful returns from ZVODE. C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. C ISTATE is set to 2, and the optional output is loaded into the work C arrays before returning. C----------------------------------------------------------------------- 400 CONTINUE CALL ZCOPY (N, ZWORK(LYH), 1, Y, 1) T = TN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 IF (IHIT) T = TCRIT 420 ISTATE = 2 RWORK(11) = HU RWORK(12) = HNEW RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NEWQ IWORK(20) = NLU IWORK(21) = NNI IWORK(22) = NCFN IWORK(23) = NETF RETURN C----------------------------------------------------------------------- C Block H. C The following block handles all unsuccessful returns other than C those for illegal input. First the error message routine is called. C if there was an error test or convergence test failure, IMXER is set. C Then Y is loaded from YH, and T is set to TN. C The optional output is loaded into the work arrays before returning. C----------------------------------------------------------------------- C The maximum number of steps was taken before reaching TOUT. ---------- 500 MSG = 'ZVODE-- At current T (=R1), MXSTEP (=I1) steps ' CALL XERRWD (MSG, 50, 201, 1, 0, 0, 0, 0, ZERO, ZERO) MSG = ' taken on this call before reaching TOUT ' CALL XERRWD (MSG, 50, 201, 1, 1, MXSTEP, 0, 1, TN, ZERO) ISTATE = -1 GO TO 580 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 510 EWTI = RWORK(LEWT+I-1) MSG = 'ZVODE-- At T (=R1), EWT(I1) has become R2 .le. 0.' CALL XERRWD (MSG, 50, 202, 1, 1, I, 0, 2, TN, EWTI) ISTATE = -6 GO TO 580 C Too much accuracy requested for machine precision. ------------------- 520 MSG = 'ZVODE-- At T (=R1), too much accuracy requested ' CALL XERRWD (MSG, 50, 203, 1, 0, 0, 0, 0, ZERO, ZERO) MSG = ' for precision of machine: see TOLSF (=R2) ' CALL XERRWD (MSG, 50, 203, 1, 0, 0, 0, 2, TN, TOLSF) RWORK(14) = TOLSF ISTATE = -2 GO TO 580 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 530 MSG = 'ZVODE-- At T(=R1) and step size H(=R2), the error' CALL XERRWD (MSG, 50, 204, 1, 0, 0, 0, 0, ZERO, ZERO) MSG = ' test failed repeatedly or with abs(H) = HMIN' CALL XERRWD (MSG, 50, 204, 1, 0, 0, 0, 2, TN, H) ISTATE = -4 GO TO 560 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 540 MSG = 'ZVODE-- At T (=R1) and step size H (=R2), the ' CALL XERRWD (MSG, 50, 205, 1, 0, 0, 0, 0, ZERO, ZERO) MSG = ' corrector convergence failed repeatedly ' CALL XERRWD (MSG, 50, 205, 1, 0, 0, 0, 0, ZERO, ZERO) MSG = ' or with abs(H) = HMIN ' CALL XERRWD (MSG, 30, 205, 1, 0, 0, 0, 2, TN, H) ISTATE = -5 C Compute IMXER if relevant. ------------------------------------------- 560 BIG = ZERO IMXER = 1 DO 570 I = 1,N SIZE = ABS(ZWORK(I+LACOR-1))*RWORK(I+LEWT-1) IF (BIG .GE. SIZE) GO TO 570 BIG = SIZE IMXER = I 570 CONTINUE IWORK(16) = IMXER C Set Y vector, T, and optional output. -------------------------------- 580 CONTINUE CALL ZCOPY (N, ZWORK(LYH), 1, Y, 1) T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(20) = NLU IWORK(21) = NNI IWORK(22) = NCFN IWORK(23) = NETF RETURN C----------------------------------------------------------------------- C Block I. C The following block handles all error returns due to illegal input C (ISTATE = -3), as detected before calling the core integrator. C First the error message routine is called. If the illegal input C is a negative ISTATE, the run is aborted (apparent infinite loop). C----------------------------------------------------------------------- 601 MSG = 'ZVODE-- ISTATE (=I1) illegal ' CALL XERRWD (MSG, 30, 1, 1, 1, ISTATE, 0, 0, ZERO, ZERO) IF (ISTATE .LT. 0) GO TO 800 GO TO 700 602 MSG = 'ZVODE-- ITASK (=I1) illegal ' CALL XERRWD (MSG, 30, 2, 1, 1, ITASK, 0, 0, ZERO, ZERO) GO TO 700 603 MSG='ZVODE-- ISTATE (=I1) .gt. 1 but ZVODE not initialized ' CALL XERRWD (MSG, 60, 3, 1, 1, ISTATE, 0, 0, ZERO, ZERO) GO TO 700 604 MSG = 'ZVODE-- NEQ (=I1) .lt. 1 ' CALL XERRWD (MSG, 30, 4, 1, 1, NEQ, 0, 0, ZERO, ZERO) GO TO 700 605 MSG = 'ZVODE-- ISTATE = 3 and NEQ increased (I1 to I2) ' CALL XERRWD (MSG, 50, 5, 1, 2, N, NEQ, 0, ZERO, ZERO) GO TO 700 606 MSG = 'ZVODE-- ITOL (=I1) illegal ' CALL XERRWD (MSG, 30, 6, 1, 1, ITOL, 0, 0, ZERO, ZERO) GO TO 700 607 MSG = 'ZVODE-- IOPT (=I1) illegal ' CALL XERRWD (MSG, 30, 7, 1, 1, IOPT, 0, 0, ZERO, ZERO) GO TO 700 608 MSG = 'ZVODE-- MF (=I1) illegal ' CALL XERRWD (MSG, 30, 8, 1, 1, MF, 0, 0, ZERO, ZERO) GO TO 700 609 MSG = 'ZVODE-- ML (=I1) illegal: .lt.0 or .ge.NEQ (=I2)' CALL XERRWD (MSG, 50, 9, 1, 2, ML, NEQ, 0, ZERO, ZERO) GO TO 700 610 MSG = 'ZVODE-- MU (=I1) illegal: .lt.0 or .ge.NEQ (=I2)' CALL XERRWD (MSG, 50, 10, 1, 2, MU, NEQ, 0, ZERO, ZERO) GO TO 700 611 MSG = 'ZVODE-- MAXORD (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 11, 1, 1, MAXORD, 0, 0, ZERO, ZERO) GO TO 700 612 MSG = 'ZVODE-- MXSTEP (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 12, 1, 1, MXSTEP, 0, 0, ZERO, ZERO) GO TO 700 613 MSG = 'ZVODE-- MXHNIL (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 13, 1, 1, MXHNIL, 0, 0, ZERO, ZERO) GO TO 700 614 MSG = 'ZVODE-- TOUT (=R1) behind T (=R2) ' CALL XERRWD (MSG, 40, 14, 1, 0, 0, 0, 2, TOUT, T) MSG = ' integration direction is given by H0 (=R1) ' CALL XERRWD (MSG, 50, 14, 1, 0, 0, 0, 1, H0, ZERO) GO TO 700 615 MSG = 'ZVODE-- HMAX (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 15, 1, 0, 0, 0, 1, HMAX, ZERO) GO TO 700 616 MSG = 'ZVODE-- HMIN (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 16, 1, 0, 0, 0, 1, HMIN, ZERO) GO TO 700 617 CONTINUE MSG='ZVODE-- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 17, 1, 2, LENRW, LRW, 0, ZERO, ZERO) GO TO 700 618 CONTINUE MSG='ZVODE-- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' CALL XERRWD (MSG, 60, 18, 1, 2, LENIW, LIW, 0, ZERO, ZERO) GO TO 700 619 MSG = 'ZVODE-- RTOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 19, 1, 1, I, 0, 1, RTOLI, ZERO) GO TO 700 620 MSG = 'ZVODE-- ATOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 20, 1, 1, I, 0, 1, ATOLI, ZERO) GO TO 700 621 EWTI = RWORK(LEWT+I-1) MSG = 'ZVODE-- EWT(I1) is R1 .le. 0.0 ' CALL XERRWD (MSG, 40, 21, 1, 1, I, 0, 1, EWTI, ZERO) GO TO 700 622 CONTINUE MSG='ZVODE-- TOUT (=R1) too close to T(=R2) to start integration' CALL XERRWD (MSG, 60, 22, 1, 0, 0, 0, 2, TOUT, T) GO TO 700 623 CONTINUE MSG='ZVODE-- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' CALL XERRWD (MSG, 60, 23, 1, 1, ITASK, 0, 2, TOUT, TP) GO TO 700 624 CONTINUE MSG='ZVODE-- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' CALL XERRWD (MSG, 60, 24, 1, 0, 0, 0, 2, TCRIT, TN) GO TO 700 625 CONTINUE MSG='ZVODE-- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' CALL XERRWD (MSG, 60, 25, 1, 0, 0, 0, 2, TCRIT, TOUT) GO TO 700 626 MSG = 'ZVODE-- At start of problem, too much accuracy ' CALL XERRWD (MSG, 50, 26, 1, 0, 0, 0, 0, ZERO, ZERO) MSG=' requested for precision of machine: see TOLSF (=R1) ' CALL XERRWD (MSG, 60, 26, 1, 0, 0, 0, 1, TOLSF, ZERO) RWORK(14) = TOLSF GO TO 700 627 MSG='ZVODE-- Trouble from ZVINDY. ITASK = I1, TOUT = R1. ' CALL XERRWD (MSG, 60, 27, 1, 1, ITASK, 0, 1, TOUT, ZERO) GO TO 700 628 CONTINUE MSG='ZVODE-- ZWORK length needed, LENZW (=I1), exceeds LZW (=I2)' CALL XERRWD (MSG, 60, 17, 1, 2, LENZW, LZW, 0, ZERO, ZERO) C 700 CONTINUE ISTATE = -3 RETURN C 800 MSG = 'ZVODE-- Run aborted: apparent infinite loop ' CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, ZERO, ZERO) RETURN C----------------------- End of Subroutine ZVODE ----------------------- END *DECK ZVHIN SUBROUTINE ZVHIN (N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND, 1 EWT, ITOL, ATOL, Y, TEMP, H0, NITER, IER) EXTERNAL F COMPLEX(KIND=8) Y0, YDOT, Y, TEMP DOUBLE PRECISION T0, TOUT, UROUND, EWT, ATOL, H0 INTEGER N, IPAR, ITOL, NITER, IER DIMENSION Y0(*), YDOT(*), EWT(*), ATOL(*), Y(*), 1 TEMP(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call sequence input -- N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND, C EWT, ITOL, ATOL, Y, TEMP C Call sequence output -- H0, NITER, IER C COMMON block variables accessed -- None C C Subroutines called by ZVHIN: F C Function routines called by ZVHIN: ZVNORM C----------------------------------------------------------------------- C This routine computes the step size, H0, to be attempted on the C first step, when the user has not supplied a value for this. C C First we check that TOUT - T0 differs significantly from zero. Then C an iteration is done to approximate the initial second derivative C and this is used to define h from w.r.m.s.norm(h**2 * yddot / 2) = 1. C A bias factor of 1/2 is applied to the resulting h. C The sign of H0 is inferred from the initial values of TOUT and T0. C C Communication with ZVHIN is done with the following variables: C C N = Size of ODE system, input. C T0 = Initial value of independent variable, input. C Y0 = Vector of initial conditions, input. C YDOT = Vector of initial first derivatives, input. C F = Name of subroutine for right-hand side f(t,y), input. C RPAR, IPAR = User's real/complex and integer work arrays. C TOUT = First output value of independent variable C UROUND = Machine unit roundoff C EWT, ITOL, ATOL = Error weights and tolerance parameters C as described in the driver routine, input. C Y, TEMP = Work arrays of length N. C H0 = Step size to be attempted, output. C NITER = Number of iterations (and of f evaluations) to compute H0, C output. C IER = The error flag, returned with the value C IER = 0 if no trouble occurred, or C IER = -1 if TOUT and T0 are considered too close to proceed. C----------------------------------------------------------------------- C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION AFI, ATOLI, DELYI, H, HALF, HG, HLB, HNEW, HRAT, 1 HUB, HUN, PT1, T1, TDIST, TROUND, TWO, YDDNRM INTEGER I, ITER C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION ZVNORM C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE HALF, HUN, PT1, TWO DATA HALF /0.5D0/, HUN /100.0D0/, PT1 /0.1D0/, TWO /2.0D0/ C NITER = 0 TDIST = ABS(TOUT - T0) TROUND = UROUND*MAX(ABS(T0),ABS(TOUT)) IF (TDIST .LT. TWO*TROUND) GO TO 100 C C Set a lower bound on h based on the roundoff level in T0 and TOUT. --- HLB = HUN*TROUND C Set an upper bound on h based on TOUT-T0 and the initial Y and YDOT. - HUB = PT1*TDIST ATOLI = ATOL(1) DO 10 I = 1, N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) DELYI = PT1*ABS(Y0(I)) + ATOLI AFI = ABS(YDOT(I)) IF (AFI*HUB .GT. DELYI) HUB = DELYI/AFI 10 CONTINUE C C Set initial guess for h as geometric mean of upper and lower bounds. - ITER = 0 HG = SQRT(HLB*HUB) C If the bounds have crossed, exit with the mean value. ---------------- IF (HUB .LT. HLB) THEN H0 = HG GO TO 90 ENDIF C C Looping point for iteration. ----------------------------------------- 50 CONTINUE C Estimate the second derivative as a difference quotient in f. -------- H = SIGN (HG, TOUT - T0) T1 = T0 + H DO 60 I = 1, N Y(I) = Y0(I) + H*YDOT(I) 60 CONTINUE CALL F (N, T1, Y, TEMP, RPAR, IPAR) DO 70 I = 1, N TEMP(I) = (TEMP(I) - YDOT(I))/H 70 CONTINUE YDDNRM = ZVNORM (N, TEMP, EWT) C Get the corresponding new value of h. -------------------------------- IF (YDDNRM*HUB*HUB .GT. TWO) THEN HNEW = SQRT(TWO/YDDNRM) ELSE HNEW = SQRT(HG*HUB) ENDIF ITER = ITER + 1 C----------------------------------------------------------------------- C Test the stopping conditions. C Stop if the new and previous h values differ by a factor of .lt. 2. C Stop if four iterations have been done. Also, stop with previous h C if HNEW/HG .gt. 2 after first iteration, as this probably means that C the second derivative value is bad because of cancellation error. C----------------------------------------------------------------------- IF (ITER .GE. 4) GO TO 80 HRAT = HNEW/HG IF ( (HRAT .GT. HALF) .AND. (HRAT .LT. TWO) ) GO TO 80 IF ( (ITER .GE. 2) .AND. (HNEW .GT. TWO*HG) ) THEN HNEW = HG GO TO 80 ENDIF HG = HNEW GO TO 50 C C Iteration done. Apply bounds, bias factor, and sign. Then exit. ---- 80 H0 = HNEW*HALF IF (H0 .LT. HLB) H0 = HLB IF (H0 .GT. HUB) H0 = HUB 90 H0 = SIGN(H0, TOUT - T0) NITER = ITER IER = 0 RETURN C Error return for TOUT - T0 too small. -------------------------------- 100 IER = -1 RETURN C----------------------- End of Subroutine ZVHIN ----------------------- END *DECK ZVINDY SUBROUTINE ZVINDY (T, K, YH, LDYH, DKY, IFLAG) COMPLEX(KIND=8) YH, DKY DOUBLE PRECISION T INTEGER K, LDYH, IFLAG DIMENSION YH(LDYH,*), DKY(*) C----------------------------------------------------------------------- C Call sequence input -- T, K, YH, LDYH C Call sequence output -- DKY, IFLAG C COMMON block variables accessed: C /ZVOD01/ -- H, TN, UROUND, L, N, NQ C /ZVOD02/ -- HU C C Subroutines called by ZVINDY: DZSCAL, XERRWD C Function routines called by ZVINDY: None C----------------------------------------------------------------------- C ZVINDY computes interpolated values of the K-th derivative of the C dependent variable vector y, and stores it in DKY. This routine C is called within the package with K = 0 and T = TOUT, but may C also be called by the user for any K up to the current order. C (See detailed instructions in the usage documentation.) C----------------------------------------------------------------------- C The computed values in DKY are gotten by interpolation using the C Nordsieck history array YH. This array corresponds uniquely to a C vector-valued polynomial of degree NQCUR or less, and DKY is set C to the K-th derivative of this polynomial at T. C The formula for DKY is: C q C DKY(i) = sum c(j,K) * (T - TN)**(j-K) * H**(-j) * YH(i,j+1) C j=K C where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, TN = TCUR, H = HCUR. C The quantities NQ = NQCUR, L = NQ+1, N, TN, and H are C communicated by COMMON. The above sum is done in reverse order. C IFLAG is returned negative if either K or T is out of bounds. C C Discussion above and comments in driver explain all variables. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block ZVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 4 NSLP, NYH C C Type declarations for labeled COMMON block ZVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION C, HUN, R, S, TFUZZ, TN1, TP, ZERO INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 CHARACTER(LEN=80) MSG C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE HUN, ZERO C COMMON /ZVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), ETA, 1 ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU(13), TQ(5), TN, UROUND, 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 7 NSLP, NYH COMMON /ZVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA HUN /100.0D0/, ZERO /0.0D0/ C IFLAG = 0 IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 TFUZZ = HUN*UROUND*SIGN(ABS(TN) + ABS(HU), HU) TP = TN - HU - TFUZZ TN1 = TN + TFUZZ IF ((T-TP)*(T-TN1) .GT. ZERO) GO TO 90 C S = (T - TN)/H IC = 1 IF (K .EQ. 0) GO TO 15 JJ1 = L - K DO 10 JJ = JJ1, NQ IC = IC*JJ 10 CONTINUE 15 C = REAL(IC) DO 20 I = 1, N DKY(I) = C*YH(I,L) 20 CONTINUE IF (K .EQ. NQ) GO TO 55 JB2 = NQ - K DO 50 JB = 1, JB2 J = NQ - JB JP1 = J + 1 IC = 1 IF (K .EQ. 0) GO TO 35 JJ1 = JP1 - K DO 30 JJ = JJ1, J IC = IC*JJ 30 CONTINUE 35 C = REAL(IC) DO 40 I = 1, N DKY(I) = C*YH(I,JP1) + S*DKY(I) 40 CONTINUE 50 CONTINUE IF (K .EQ. 0) RETURN 55 R = H**(-K) CALL DZSCAL (N, R, DKY, 1) RETURN C 80 MSG = 'ZVINDY-- K (=I1) illegal ' CALL XERRWD (MSG, 30, 51, 1, 1, K, 0, 0, ZERO, ZERO) IFLAG = -1 RETURN 90 MSG = 'ZVINDY-- T (=R1) illegal ' CALL XERRWD (MSG, 30, 52, 1, 0, 0, 0, 1, T, ZERO) MSG=' T not in interval TCUR - HU (= R1) to TCUR (=R2) ' CALL XERRWD (MSG, 60, 52, 1, 0, 0, 0, 2, TP, TN) IFLAG = -2 RETURN C----------------------- End of Subroutine ZVINDY ---------------------- END *DECK ZVSTEP SUBROUTINE ZVSTEP (Y, YH, LDYH, YH1, EWT, SAVF, VSAV, ACOR, 1 WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR) EXTERNAL F, JAC, PSOL, VNLS COMPLEX(KIND=8) Y, YH, YH1, SAVF, VSAV, ACOR, WM DOUBLE PRECISION EWT INTEGER LDYH, IWM, IPAR DIMENSION Y(*), YH(LDYH,*), YH1(*), EWT(*), SAVF(*), VSAV(*), 1 ACOR(*), WM(*), IWM(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call sequence input -- Y, YH, LDYH, YH1, EWT, SAVF, VSAV, C ACOR, WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR C Call sequence output -- YH, ACOR, WM, IWM C COMMON block variables accessed: C /ZVOD01/ ACNRM, EL(13), H, HMIN, HMXI, HNEW, HSCAL, RC, TAU(13), C TQ(5), TN, JCUR, JSTART, KFLAG, KUTH, C L, LMAX, MAXORD, N, NEWQ, NQ, NQWAIT C /ZVOD02/ HU, NCFN, NETF, NFE, NQU, NST C C Subroutines called by ZVSTEP: F, DZAXPY, ZCOPY, DZSCAL, C ZVJUST, VNLS, ZVSET C Function routines called by ZVSTEP: ZVNORM C----------------------------------------------------------------------- C ZVSTEP performs one step of the integration of an initial value C problem for a system of ordinary differential equations. C ZVSTEP calls subroutine VNLS for the solution of the nonlinear system C arising in the time step. Thus it is independent of the problem C Jacobian structure and the type of nonlinear system solution method. C ZVSTEP returns a completion flag KFLAG (in COMMON). C A return with KFLAG = -1 or -2 means either ABS(H) = HMIN or 10 C consecutive failures occurred. On a return with KFLAG negative, C the values of TN and the YH array are as of the beginning of the last C step, and H is the last step size attempted. C C Communication with ZVSTEP is done with the following variables: C C Y = An array of length N used for the dependent variable vector. C YH = An LDYH by LMAX array containing the dependent variables C and their approximate scaled derivatives, where C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate C j-th derivative of y(i), scaled by H**j/factorial(j) C (j = 0,1,...,NQ). On entry for the first step, the first C two columns of YH must be set from the initial values. C LDYH = A constant integer .ge. N, the first dimension of YH. C N is the number of ODEs in the system. C YH1 = A one-dimensional array occupying the same space as YH. C EWT = An array of length N containing multiplicative weights C for local error measurements. Local errors in y(i) are C compared to 1.0/EWT(i) in various error tests. C SAVF = An array of working storage, of length N. C also used for input of YH(*,MAXORD+2) when JSTART = -1 C and MAXORD .lt. the current order NQ. C VSAV = A work array of length N passed to subroutine VNLS. C ACOR = A work array of length N, used for the accumulated C corrections. On a successful return, ACOR(i) contains C the estimated one-step local error in y(i). C WM,IWM = Complex and integer work arrays associated with matrix C operations in VNLS. C F = Dummy name for the user-supplied subroutine for f. C JAC = Dummy name for the user-supplied Jacobian subroutine. C PSOL = Dummy name for the subroutine passed to VNLS, for C possible use there. C VNLS = Dummy name for the nonlinear system solving subroutine, C whose real name is dependent on the method used. C RPAR, IPAR = User's real/complex and integer work arrays. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block ZVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 4 NSLP, NYH C C Type declarations for labeled COMMON block ZVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION ADDON, BIAS1,BIAS2,BIAS3, CNQUOT, DDN, DSM, DUP, 1 ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF, 2 ETAQ, ETAQM1, ETAQP1, FLOTL, ONE, ONEPSM, 3 R, THRESH, TOLD, ZERO INTEGER I, I1, I2, IBACK, J, JB, KFC, KFH, MXNCF, NCF, NFLAG C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION ZVNORM C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE ADDON, BIAS1, BIAS2, BIAS3, 1 ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF, ETAQ, ETAQM1, 2 KFC, KFH, MXNCF, ONEPSM, THRESH, ONE, ZERO C----------------------------------------------------------------------- COMMON /ZVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), ETA, 1 ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU(13), TQ(5), TN, UROUND, 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 7 NSLP, NYH COMMON /ZVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA KFC/-3/, KFH/-7/, MXNCF/10/ DATA ADDON /1.0D-6/, BIAS1 /6.0D0/, BIAS2 /6.0D0/, 1 BIAS3 /10.0D0/, ETACF /0.25D0/, ETAMIN /0.1D0/, 2 ETAMXF /0.2D0/, ETAMX1 /1.0D4/, ETAMX2 /10.0D0/, 3 ETAMX3 /10.0D0/, ONEPSM /1.00001D0/, THRESH /1.5D0/ DATA ONE/1.0D0/, ZERO/0.0D0/ C KFLAG = 0 TOLD = TN NCF = 0 JCUR = 0 NFLAG = 0 IF (JSTART .GT. 0) GO TO 20 IF (JSTART .EQ. -1) GO TO 100 C----------------------------------------------------------------------- C On the first call, the order is set to 1, and other variables are C initialized. ETAMAX is the maximum ratio by which H can be increased C in a single step. It is normally 10, but is larger during the C first step to compensate for the small initial H. If a failure C occurs (in corrector convergence or error test), ETAMAX is set to 1 C for the next increase. C----------------------------------------------------------------------- LMAX = MAXORD + 1 NQ = 1 L = 2 NQNYH = NQ*LDYH TAU(1) = H PRL1 = ONE RC = ZERO ETAMAX = ETAMX1 NQWAIT = 2 HSCAL = H GO TO 200 C----------------------------------------------------------------------- C Take preliminary actions on a normal continuation step (JSTART.GT.0). C If the driver changed H, then ETA must be reset and NEWH set to 1. C If a change of order was dictated on the previous step, then C it is done here and appropriate adjustments in the history are made. C On an order decrease, the history array is adjusted by ZVJUST. C On an order increase, the history array is augmented by a column. C On a change of step size H, the history array YH is rescaled. C----------------------------------------------------------------------- 20 CONTINUE IF (KUTH .EQ. 1) THEN ETA = MIN(ETA,H/HSCAL) NEWH = 1 ENDIF 50 IF (NEWH .EQ. 0) GO TO 200 IF (NEWQ .EQ. NQ) GO TO 150 IF (NEWQ .LT. NQ) THEN CALL ZVJUST (YH, LDYH, -1) NQ = NEWQ L = NQ + 1 NQWAIT = L GO TO 150 ENDIF IF (NEWQ .GT. NQ) THEN CALL ZVJUST (YH, LDYH, 1) NQ = NEWQ L = NQ + 1 NQWAIT = L GO TO 150 ENDIF C----------------------------------------------------------------------- C The following block handles preliminaries needed when JSTART = -1. C If N was reduced, zero out part of YH to avoid undefined references. C If MAXORD was reduced to a value less than the tentative order NEWQ, C then NQ is set to MAXORD, and a new H ratio ETA is chosen. C Otherwise, we take the same preliminary actions as for JSTART .gt. 0. C In any case, NQWAIT is reset to L = NQ + 1 to prevent further C changes in order for that many steps. C The new H ratio ETA is limited by the input H if KUTH = 1, C by HMIN if KUTH = 0, and by HMXI in any case. C Finally, the history array YH is rescaled. C----------------------------------------------------------------------- 100 CONTINUE LMAX = MAXORD + 1 IF (N .EQ. LDYH) GO TO 120 I1 = 1 + (NEWQ + 1)*LDYH I2 = (MAXORD + 1)*LDYH IF (I1 .GT. I2) GO TO 120 DO 110 I = I1, I2 YH1(I) = ZERO 110 CONTINUE 120 IF (NEWQ .LE. MAXORD) GO TO 140 FLOTL = REAL(LMAX) IF (MAXORD .LT. NQ-1) THEN DDN = ZVNORM (N, SAVF, EWT)/TQ(1) ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON) ENDIF IF (MAXORD .EQ. NQ .AND. NEWQ .EQ. NQ+1) ETA = ETAQ IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ+1) THEN ETA = ETAQM1 CALL ZVJUST (YH, LDYH, -1) ENDIF IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ) THEN DDN = ZVNORM (N, SAVF, EWT)/TQ(1) ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON) CALL ZVJUST (YH, LDYH, -1) ENDIF ETA = MIN(ETA,ONE) NQ = MAXORD L = LMAX 140 IF (KUTH .EQ. 1) ETA = MIN(ETA,ABS(H/HSCAL)) IF (KUTH .EQ. 0) ETA = MAX(ETA,HMIN/ABS(HSCAL)) ETA = ETA/MAX(ONE,ABS(HSCAL)*HMXI*ETA) NEWH = 1 NQWAIT = L IF (NEWQ .LE. MAXORD) GO TO 50 C Rescale the history array for a change in H by a factor of ETA. ------ 150 R = ONE DO 180 J = 2, L R = R*ETA CALL DZSCAL (N, R, YH(1,J), 1 ) 180 CONTINUE H = HSCAL*ETA HSCAL = H RC = RC*ETA NQNYH = NQ*LDYH C----------------------------------------------------------------------- C This section computes the predicted values by effectively C multiplying the YH array by the Pascal triangle matrix. C ZVSET is called to calculate all integration coefficients. C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. C----------------------------------------------------------------------- 200 TN = TN + H I1 = NQNYH + 1 DO 220 JB = 1, NQ I1 = I1 - LDYH DO 210 I = I1, NQNYH YH1(I) = YH1(I) + YH1(I+LDYH) 210 CONTINUE 220 CONTINUE CALL ZVSET RL1 = ONE/EL(2) RC = RC*(RL1/PRL1) PRL1 = RL1 C C Call the nonlinear system solver. ------------------------------------ C CALL VNLS (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM, 1 F, JAC, PSOL, NFLAG, RPAR, IPAR) C IF (NFLAG .EQ. 0) GO TO 450 C----------------------------------------------------------------------- C The VNLS routine failed to achieve convergence (NFLAG .NE. 0). C The YH array is retracted to its values before prediction. C The step size H is reduced and the step is retried, if possible. C Otherwise, an error exit is taken. C----------------------------------------------------------------------- NCF = NCF + 1 NCFN = NCFN + 1 ETAMAX = ONE TN = TOLD I1 = NQNYH + 1 DO 430 JB = 1, NQ I1 = I1 - LDYH DO 420 I = I1, NQNYH YH1(I) = YH1(I) - YH1(I+LDYH) 420 CONTINUE 430 CONTINUE IF (NFLAG .LT. -1) GO TO 680 IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 670 IF (NCF .EQ. MXNCF) GO TO 670 ETA = ETACF ETA = MAX(ETA,HMIN/ABS(H)) NFLAG = -1 GO TO 150 C----------------------------------------------------------------------- C The corrector has converged (NFLAG = 0). The local error test is C made and control passes to statement 500 if it fails. C----------------------------------------------------------------------- 450 CONTINUE DSM = ACNRM/TQ(2) IF (DSM .GT. ONE) GO TO 500 C----------------------------------------------------------------------- C After a successful step, update the YH and TAU arrays and decrement C NQWAIT. If NQWAIT is then 1 and NQ .lt. MAXORD, then ACOR is saved C for use in a possible order increase on the next step. C If ETAMAX = 1 (a failure occurred this step), keep NQWAIT .ge. 2. C----------------------------------------------------------------------- KFLAG = 0 NST = NST + 1 HU = H NQU = NQ DO 470 IBACK = 1, NQ I = L - IBACK TAU(I+1) = TAU(I) 470 CONTINUE TAU(1) = H DO 480 J = 1, L CALL DZAXPY (N, EL(J), ACOR, 1, YH(1,J), 1 ) 480 CONTINUE NQWAIT = NQWAIT - 1 IF ((L .EQ. LMAX) .OR. (NQWAIT .NE. 1)) GO TO 490 CALL ZCOPY (N, ACOR, 1, YH(1,LMAX), 1 ) CONP = TQ(5) 490 IF (ETAMAX .NE. ONE) GO TO 560 IF (NQWAIT .LT. 2) NQWAIT = 2 NEWQ = NQ NEWH = 0 ETA = ONE HNEW = H GO TO 690 C----------------------------------------------------------------------- C The error test failed. KFLAG keeps track of multiple failures. C Restore TN and the YH array to their previous values, and prepare C to try the step again. Compute the optimum step size for the C same order. After repeated failures, H is forced to decrease C more rapidly. C----------------------------------------------------------------------- 500 KFLAG = KFLAG - 1 NETF = NETF + 1 NFLAG = -2 TN = TOLD I1 = NQNYH + 1 DO 520 JB = 1, NQ I1 = I1 - LDYH DO 510 I = I1, NQNYH YH1(I) = YH1(I) - YH1(I+LDYH) 510 CONTINUE 520 CONTINUE IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 660 ETAMAX = ONE IF (KFLAG .LE. KFC) GO TO 530 C Compute ratio of new H to current H at the current order. ------------ FLOTL = REAL(L) ETA = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON) ETA = MAX(ETA,HMIN/ABS(H),ETAMIN) IF ((KFLAG .LE. -2) .AND. (ETA .GT. ETAMXF)) ETA = ETAMXF GO TO 150 C----------------------------------------------------------------------- C Control reaches this section if 3 or more consecutive failures C have occurred. It is assumed that the elements of the YH array C have accumulated errors of the wrong order. The order is reduced C by one, if possible. Then H is reduced by a factor of 0.1 and C the step is retried. After a total of 7 consecutive failures, C an exit is taken with KFLAG = -1. C----------------------------------------------------------------------- 530 IF (KFLAG .EQ. KFH) GO TO 660 IF (NQ .EQ. 1) GO TO 540 ETA = MAX(ETAMIN,HMIN/ABS(H)) CALL ZVJUST (YH, LDYH, -1) L = NQ NQ = NQ - 1 NQWAIT = L GO TO 150 540 ETA = MAX(ETAMIN,HMIN/ABS(H)) H = H*ETA HSCAL = H TAU(1) = H CALL F (N, TN, Y, SAVF, RPAR, IPAR) NFE = NFE + 1 DO 550 I = 1, N YH(I,2) = H*SAVF(I) 550 CONTINUE NQWAIT = 10 GO TO 200 C----------------------------------------------------------------------- C If NQWAIT = 0, an increase or decrease in order by one is considered. C Factors ETAQ, ETAQM1, ETAQP1 are computed by which H could C be multiplied at order q, q-1, or q+1, respectively. C The largest of these is determined, and the new order and C step size set accordingly. C A change of H or NQ is made only if H increases by at least a C factor of THRESH. If an order change is considered and rejected, C then NQWAIT is set to 2 (reconsider it after 2 steps). C----------------------------------------------------------------------- C Compute ratio of new H to current H at the current order. ------------ 560 FLOTL = REAL(L) ETAQ = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON) IF (NQWAIT .NE. 0) GO TO 600 NQWAIT = 2 ETAQM1 = ZERO IF (NQ .EQ. 1) GO TO 570 C Compute ratio of new H to current H at the current order less one. --- DDN = ZVNORM (N, YH(1,L), EWT)/TQ(1) ETAQM1 = ONE/((BIAS1*DDN)**(ONE/(FLOTL - ONE)) + ADDON) 570 ETAQP1 = ZERO IF (L .EQ. LMAX) GO TO 580 C Compute ratio of new H to current H at current order plus one. ------- CNQUOT = (TQ(5)/CONP)*(H/TAU(2))**L DO 575 I = 1, N SAVF(I) = ACOR(I) - CNQUOT*YH(I,LMAX) 575 CONTINUE DUP = ZVNORM (N, SAVF, EWT)/TQ(3) ETAQP1 = ONE/((BIAS3*DUP)**(ONE/(FLOTL + ONE)) + ADDON) 580 IF (ETAQ .GE. ETAQP1) GO TO 590 IF (ETAQP1 .GT. ETAQM1) GO TO 620 GO TO 610 590 IF (ETAQ .LT. ETAQM1) GO TO 610 600 ETA = ETAQ NEWQ = NQ GO TO 630 610 ETA = ETAQM1 NEWQ = NQ - 1 GO TO 630 620 ETA = ETAQP1 NEWQ = NQ + 1 CALL ZCOPY (N, ACOR, 1, YH(1,LMAX), 1) C Test tentative new H against THRESH, ETAMAX, and HMXI, then exit. ---- 630 IF (ETA .LT. THRESH .OR. ETAMAX .EQ. ONE) GO TO 640 ETA = MIN(ETA,ETAMAX) ETA = ETA/MAX(ONE,ABS(H)*HMXI*ETA) NEWH = 1 HNEW = H*ETA GO TO 690 640 NEWQ = NQ NEWH = 0 ETA = ONE HNEW = H GO TO 690 C----------------------------------------------------------------------- C All returns are made through this section. C On a successful return, ETAMAX is reset and ACOR is scaled. C----------------------------------------------------------------------- 660 KFLAG = -1 GO TO 720 670 KFLAG = -2 GO TO 720 680 IF (NFLAG .EQ. -2) KFLAG = -3 IF (NFLAG .EQ. -3) KFLAG = -4 GO TO 720 690 ETAMAX = ETAMX3 IF (NST .LE. 10) ETAMAX = ETAMX2 R = ONE/TQ(2) CALL DZSCAL (N, R, ACOR, 1) 720 JSTART = 1 RETURN C----------------------- End of Subroutine ZVSTEP ---------------------- END *DECK ZVSET SUBROUTINE ZVSET C----------------------------------------------------------------------- C Call sequence communication: None C COMMON block variables accessed: C /ZVOD01/ -- EL(13), H, TAU(13), TQ(5), L(= NQ + 1), C METH, NQ, NQWAIT C C Subroutines called by ZVSET: None C Function routines called by ZVSET: None C----------------------------------------------------------------------- C ZVSET is called by ZVSTEP and sets coefficients for use there. C C For each order NQ, the coefficients in EL are calculated by use of C the generating polynomial lambda(x), with coefficients EL(i). C lambda(x) = EL(1) + EL(2)*x + ... + EL(NQ+1)*(x**NQ). C For the backward differentiation formulas, C NQ-1 C lambda(x) = (1 + x/xi*(NQ)) * product (1 + x/xi(i) ) . C i = 1 C For the Adams formulas, C NQ-1 C (d/dx) lambda(x) = c * product (1 + x/xi(i) ) , C i = 1 C lambda(-1) = 0, lambda(0) = 1, C where c is a normalization constant. C In both cases, xi(i) is defined by C H*xi(i) = t sub n - t sub (n-i) C = H + TAU(1) + TAU(2) + ... TAU(i-1). C C C In addition to variables described previously, communication C with ZVSET uses the following: C TAU = A vector of length 13 containing the past NQ values C of H. C EL = A vector of length 13 in which vset stores the C coefficients for the corrector formula. C TQ = A vector of length 5 in which vset stores constants C used for the convergence test, the error test, and the C selection of H at a new order. C METH = The basic method indicator. C NQ = The current order. C L = NQ + 1, the length of the vector stored in EL, and C the number of columns of the YH array being used. C NQWAIT = A counter controlling the frequency of order changes. C An order change is about to be considered if NQWAIT = 1. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block ZVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 4 NSLP, NYH C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION AHATN0, ALPH0, CNQM1, CORTES, CSUM, ELP, EM, 1 EM0, FLOTI, FLOTL, FLOTNQ, HSUM, ONE, RXI, RXIS, S, SIX, 2 T1, T2, T3, T4, T5, T6, TWO, XI, ZERO INTEGER I, IBACK, J, JP1, NQM1, NQM2 C DIMENSION EM(13) C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE CORTES, ONE, SIX, TWO, ZERO C COMMON /ZVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), ETA, 1 ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU(13), TQ(5), TN, UROUND, 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 7 NSLP, NYH C DATA CORTES /0.1D0/ DATA ONE /1.0D0/, SIX /6.0D0/, TWO /2.0D0/, ZERO /0.0D0/ C FLOTL = REAL(L) NQM1 = NQ - 1 NQM2 = NQ - 2 IF (METH .EQ. 1) THEN GOTO 100 ELSE IF (METH .EQ. 2) THEN GOTO 200 ENDIF C GO TO (100, 200), METH C C Set coefficients for Adams methods. ---------------------------------- 100 IF (NQ .NE. 1) GO TO 110 EL(1) = ONE EL(2) = ONE TQ(1) = ONE TQ(2) = TWO TQ(3) = SIX*TQ(2) TQ(5) = ONE GO TO 300 110 HSUM = H EM(1) = ONE FLOTNQ = FLOTL - ONE DO 115 I = 2, L EM(I) = ZERO 115 CONTINUE DO 150 J = 1, NQM1 IF ((J .NE. NQM1) .OR. (NQWAIT .NE. 1)) GO TO 130 S = ONE CSUM = ZERO DO 120 I = 1, NQM1 CSUM = CSUM + S*EM(I)/REAL(I+1) S = -S 120 CONTINUE TQ(1) = EM(NQM1)/(FLOTNQ*CSUM) 130 RXI = H/HSUM DO 140 IBACK = 1, J I = (J + 2) - IBACK EM(I) = EM(I) + EM(I-1)*RXI 140 CONTINUE HSUM = HSUM + TAU(J) 150 CONTINUE C Compute integral from -1 to 0 of polynomial and of x times it. ------- S = ONE EM0 = ZERO CSUM = ZERO DO 160 I = 1, NQ FLOTI = REAL(I) EM0 = EM0 + S*EM(I)/FLOTI CSUM = CSUM + S*EM(I)/(FLOTI+ONE) S = -S 160 CONTINUE C In EL, form coefficients of normalized integrated polynomial. -------- S = ONE/EM0 EL(1) = ONE DO 170 I = 1, NQ EL(I+1) = S*EM(I)/REAL(I) 170 CONTINUE XI = HSUM/H TQ(2) = XI*EM0/CSUM TQ(5) = XI/EL(L) IF (NQWAIT .NE. 1) GO TO 300 C For higher order control constant, multiply polynomial by 1+x/xi(q). - RXI = ONE/XI DO 180 IBACK = 1, NQ I = (L + 1) - IBACK EM(I) = EM(I) + EM(I-1)*RXI 180 CONTINUE C Compute integral of polynomial. -------------------------------------- S = ONE CSUM = ZERO DO 190 I = 1, L CSUM = CSUM + S*EM(I)/REAL(I+1) S = -S 190 CONTINUE TQ(3) = FLOTL*EM0/CSUM GO TO 300 C C Set coefficients for BDF methods. ------------------------------------ 200 DO 210 I = 3, L EL(I) = ZERO 210 CONTINUE EL(1) = ONE EL(2) = ONE ALPH0 = -ONE AHATN0 = -ONE HSUM = H RXI = ONE RXIS = ONE IF (NQ .EQ. 1) GO TO 240 DO 230 J = 1, NQM2 C In EL, construct coefficients of (1+x/xi(1))*...*(1+x/xi(j+1)). ------ HSUM = HSUM + TAU(J) RXI = H/HSUM JP1 = J + 1 ALPH0 = ALPH0 - ONE/REAL(JP1) DO 220 IBACK = 1, JP1 I = (J + 3) - IBACK EL(I) = EL(I) + EL(I-1)*RXI 220 CONTINUE 230 CONTINUE ALPH0 = ALPH0 - ONE/REAL(NQ) RXIS = -EL(2) - ALPH0 HSUM = HSUM + TAU(NQM1) RXI = H/HSUM AHATN0 = -EL(2) - RXI DO 235 IBACK = 1, NQ I = (NQ + 2) - IBACK EL(I) = EL(I) + EL(I-1)*RXIS 235 CONTINUE 240 T1 = ONE - AHATN0 + ALPH0 T2 = ONE + REAL(NQ)*T1 TQ(2) = ABS(ALPH0*T2/T1) TQ(5) = ABS(T2/(EL(L)*RXI/RXIS)) IF (NQWAIT .NE. 1) GO TO 300 CNQM1 = RXIS/EL(L) T3 = ALPH0 + ONE/REAL(NQ) T4 = AHATN0 + RXI ELP = T3/(ONE - T4 + T3) TQ(1) = ABS(ELP/CNQM1) HSUM = HSUM + TAU(NQ) RXI = H/HSUM T5 = ALPH0 - ONE/REAL(NQ+1) T6 = AHATN0 - RXI ELP = T2/(ONE - T6 + T5) TQ(3) = ABS(ELP*RXI*(FLOTL + ONE)*T5) 300 TQ(4) = CORTES*TQ(2) RETURN C----------------------- End of Subroutine ZVSET ----------------------- END *DECK ZVJUST SUBROUTINE ZVJUST (YH, LDYH, IORD) COMPLEX(KIND=8) YH INTEGER LDYH, IORD DIMENSION YH(LDYH,*) C----------------------------------------------------------------------- C Call sequence input -- YH, LDYH, IORD C Call sequence output -- YH C COMMON block input -- NQ, METH, LMAX, HSCAL, TAU(13), N C COMMON block variables accessed: C /ZVOD01/ -- HSCAL, TAU(13), LMAX, METH, N, NQ, C C Subroutines called by ZVJUST: DZAXPY C Function routines called by ZVJUST: None C----------------------------------------------------------------------- C This subroutine adjusts the YH array on reduction of order, C and also when the order is increased for the stiff option (METH = 2). C Communication with ZVJUST uses the following: C IORD = An integer flag used when METH = 2 to indicate an order C increase (IORD = +1) or an order decrease (IORD = -1). C HSCAL = Step size H used in scaling of Nordsieck array YH. C (If IORD = +1, ZVJUST assumes that HSCAL = TAU(1).) C See References 1 and 2 for details. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block ZVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 4 NSLP, NYH C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION ALPH0, ALPH1, HSUM, ONE, PROD, T1, XI,XIOLD, ZERO INTEGER I, IBACK, J, JP1, LP1, NQM1, NQM2, NQP1 C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE ONE, ZERO C COMMON /ZVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), ETA, 1 ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU(13), TQ(5), TN, UROUND, 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 7 NSLP, NYH C DATA ONE /1.0D0/, ZERO /0.0D0/ C IF ((NQ .EQ. 2) .AND. (IORD .NE. 1)) RETURN NQM1 = NQ - 1 NQM2 = NQ - 2 IF (METH .EQ. 1) THEN GOTO 100 ELSE IF (METH .EQ. 2) THEN GOTO 200 ENDIF C GO TO (100, 200), METH C----------------------------------------------------------------------- C Nonstiff option... C Check to see if the order is being increased or decreased. C----------------------------------------------------------------------- 100 CONTINUE IF (IORD .EQ. 1) GO TO 180 C Order decrease. ------------------------------------------------------ DO 110 J = 1, LMAX EL(J) = ZERO 110 CONTINUE EL(2) = ONE HSUM = ZERO DO 130 J = 1, NQM2 C Construct coefficients of x*(x+xi(1))*...*(x+xi(j)). ----------------- HSUM = HSUM + TAU(J) XI = HSUM/HSCAL JP1 = J + 1 DO 120 IBACK = 1, JP1 I = (J + 3) - IBACK EL(I) = EL(I)*XI + EL(I-1) 120 CONTINUE 130 CONTINUE C Construct coefficients of integrated polynomial. --------------------- DO 140 J = 2, NQM1 EL(J+1) = REAL(NQ)*EL(J)/REAL(J) 140 CONTINUE C Subtract correction terms from YH array. ----------------------------- DO 170 J = 3, NQ DO 160 I = 1, N YH(I,J) = YH(I,J) - YH(I,L)*EL(J) 160 CONTINUE 170 CONTINUE RETURN C Order increase. ------------------------------------------------------ C Zero out next column in YH array. ------------------------------------ 180 CONTINUE LP1 = L + 1 DO 190 I = 1, N YH(I,LP1) = ZERO 190 CONTINUE RETURN C----------------------------------------------------------------------- C Stiff option... C Check to see if the order is being increased or decreased. C----------------------------------------------------------------------- 200 CONTINUE IF (IORD .EQ. 1) GO TO 300 C Order decrease. ------------------------------------------------------ DO 210 J = 1, LMAX EL(J) = ZERO 210 CONTINUE EL(3) = ONE HSUM = ZERO DO 230 J = 1,NQM2 C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- HSUM = HSUM + TAU(J) XI = HSUM/HSCAL JP1 = J + 1 DO 220 IBACK = 1, JP1 I = (J + 4) - IBACK EL(I) = EL(I)*XI + EL(I-1) 220 CONTINUE 230 CONTINUE C Subtract correction terms from YH array. ----------------------------- DO 250 J = 3,NQ DO 240 I = 1, N YH(I,J) = YH(I,J) - YH(I,L)*EL(J) 240 CONTINUE 250 CONTINUE RETURN C Order increase. ------------------------------------------------------ 300 DO 310 J = 1, LMAX EL(J) = ZERO 310 CONTINUE EL(3) = ONE ALPH0 = -ONE ALPH1 = ONE PROD = ONE XIOLD = ONE HSUM = HSCAL IF (NQ .EQ. 1) GO TO 340 DO 330 J = 1, NQM1 C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- JP1 = J + 1 HSUM = HSUM + TAU(JP1) XI = HSUM/HSCAL PROD = PROD*XI ALPH0 = ALPH0 - ONE/REAL(JP1) ALPH1 = ALPH1 + ONE/XI DO 320 IBACK = 1, JP1 I = (J + 4) - IBACK EL(I) = EL(I)*XIOLD + EL(I-1) 320 CONTINUE XIOLD = XI 330 CONTINUE 340 CONTINUE T1 = (-ALPH0 - ALPH1)/PROD C Load column L + 1 in YH array. --------------------------------------- LP1 = L + 1 DO 350 I = 1, N YH(I,LP1) = T1*YH(I,LMAX) 350 CONTINUE C Add correction terms to YH array. ------------------------------------ NQP1 = NQ + 1 DO 370 J = 3, NQP1 CALL DZAXPY (N, EL(J), YH(1,LP1), 1, YH(1,J), 1 ) 370 CONTINUE RETURN C----------------------- End of Subroutine ZVJUST ---------------------- END *DECK ZVNLSD SUBROUTINE ZVNLSD (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM, 1 F, JAC, PDUM, NFLAG, RPAR, IPAR) EXTERNAL F, JAC, PDUM COMPLEX(KIND=8) Y, YH, VSAV, SAVF, ACOR, WM DOUBLE PRECISION EWT INTEGER LDYH, IWM, NFLAG, IPAR DIMENSION Y(*), YH(LDYH,*), VSAV(*), SAVF(*), EWT(*), ACOR(*), 1 IWM(*), WM(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call sequence input -- Y, YH, LDYH, SAVF, EWT, ACOR, IWM, WM, C F, JAC, NFLAG, RPAR, IPAR C Call sequence output -- YH, ACOR, WM, IWM, NFLAG C COMMON block variables accessed: C /ZVOD01/ ACNRM, CRATE, DRC, H, RC, RL1, TQ(5), TN, ICF, C JCUR, METH, MITER, N, NSLP C /ZVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Subroutines called by ZVNLSD: F, DZAXPY, ZCOPY, DZSCAL, ZVJAC, ZVSOL C Function routines called by ZVNLSD: ZVNORM C----------------------------------------------------------------------- C Subroutine ZVNLSD is a nonlinear system solver, which uses functional C iteration or a chord (modified Newton) method. For the chord method C direct linear algebraic system solvers are used. Subroutine ZVNLSD C then handles the corrector phase of this integration package. C C Communication with ZVNLSD is done with the following variables. (For C more details, please see the comments in the driver subroutine.) C C Y = The dependent variable, a vector of length N, input. C YH = The Nordsieck (Taylor) array, LDYH by LMAX, input C and output. On input, it contains predicted values. C LDYH = A constant .ge. N, the first dimension of YH, input. C VSAV = Unused work array. C SAVF = A work array of length N. C EWT = An error weight vector of length N, input. C ACOR = A work array of length N, used for the accumulated C corrections to the predicted y vector. C WM,IWM = Complex and integer work arrays associated with matrix C operations in chord iteration (MITER .ne. 0). C F = Dummy name for user-supplied routine for f. C JAC = Dummy name for user-supplied Jacobian routine. C PDUM = Unused dummy subroutine name. Included for uniformity C over collection of integrators. C NFLAG = Input/output flag, with values and meanings as follows: C INPUT C 0 first call for this time step. C -1 convergence failure in previous call to ZVNLSD. C -2 error test failure in ZVSTEP. C OUTPUT C 0 successful completion of nonlinear solver. C -1 convergence failure or singular matrix. C -2 unrecoverable error in matrix preprocessing C (cannot occur here). C -3 unrecoverable error in solution (cannot occur C here). C RPAR, IPAR = User's real/complex and integer work arrays. C C IPUP = Own variable flag with values and meanings as follows: C 0, do not update the Newton matrix. C MITER .ne. 0, update Newton matrix, because it is the C initial step, order was changed, the error C test failed, or an update is indicated by C the scalar RC or step counter NST. C C For more details, see comments in driver subroutine. C----------------------------------------------------------------------- C Type declarations for labeled COMMON block ZVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 4 NSLP, NYH C C Type declarations for labeled COMMON block ZVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION CCMAX, CRDOWN, CSCALE, DCON, DEL, DELP, ONE, 1 RDIV, TWO, ZERO INTEGER I, IERPJ, IERSL, M, MAXCOR, MSBP C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION ZVNORM C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE CCMAX, CRDOWN, MAXCOR, MSBP, RDIV, ONE, TWO, ZERO C COMMON /ZVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), ETA, 1 ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU(13), TQ(5), TN, UROUND, 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 7 NSLP, NYH COMMON /ZVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA CCMAX /0.3D0/, CRDOWN /0.3D0/, MAXCOR /3/, MSBP /20/, 1 RDIV /2.0D0/ DATA ONE /1.0D0/, TWO /2.0D0/, ZERO /0.0D0/ C----------------------------------------------------------------------- C On the first step, on a change of method order, or after a C nonlinear convergence failure with NFLAG = -2, set IPUP = MITER C to force a Jacobian update when MITER .ne. 0. C----------------------------------------------------------------------- IF (JSTART .EQ. 0) NSLP = 0 IF (NFLAG .EQ. 0) ICF = 0 IF (NFLAG .EQ. -2) IPUP = MITER IF ( (JSTART .EQ. 0) .OR. (JSTART .EQ. -1) ) IPUP = MITER C If this is functional iteration, set CRATE .eq. 1 and drop to 220 IF (MITER .EQ. 0) THEN CRATE = ONE GO TO 220 ENDIF C----------------------------------------------------------------------- C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. C When RC differs from 1 by more than CCMAX, IPUP is set to MITER C to force ZVJAC to be called, if a Jacobian is involved. C In any case, ZVJAC is called at least every MSBP steps. C----------------------------------------------------------------------- DRC = ABS(RC-ONE) IF (DRC .GT. CCMAX .OR. NST .GE. NSLP+MSBP) IPUP = MITER C----------------------------------------------------------------------- C Up to MAXCOR corrector iterations are taken. A convergence test is C made on the r.m.s. norm of each correction, weighted by the error C weight vector EWT. The sum of the corrections is accumulated in the C vector ACOR(i). The YH array is not altered in the corrector loop. C----------------------------------------------------------------------- 220 M = 0 DELP = ZERO CALL ZCOPY (N, YH(1,1), 1, Y, 1 ) CALL F (N, TN, Y, SAVF, RPAR, IPAR) NFE = NFE + 1 IF (IPUP .LE. 0) GO TO 250 C----------------------------------------------------------------------- C If indicated, the matrix P = I - h*rl1*J is reevaluated and C preprocessed before starting the corrector iteration. IPUP is set C to 0 as an indicator that this has been done. C----------------------------------------------------------------------- CALL ZVJAC (Y, YH, LDYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, IERPJ, 1 RPAR, IPAR) IPUP = 0 RC = ONE DRC = ZERO CRATE = ONE NSLP = NST C If matrix is singular, take error return to force cut in step size. -- IF (IERPJ .NE. 0) GO TO 430 250 DO 260 I = 1,N ACOR(I) = ZERO 260 CONTINUE C This is a looping point for the corrector iteration. ----------------- 270 IF (MITER .NE. 0) GO TO 350 C----------------------------------------------------------------------- C In the case of functional iteration, update Y directly from C the result of the last function evaluation. C----------------------------------------------------------------------- DO 280 I = 1,N SAVF(I) = RL1*(H*SAVF(I) - YH(I,2)) 280 CONTINUE DO 290 I = 1,N Y(I) = SAVF(I) - ACOR(I) 290 CONTINUE DEL = ZVNORM (N, Y, EWT) DO 300 I = 1,N Y(I) = YH(I,1) + SAVF(I) 300 CONTINUE CALL ZCOPY (N, SAVF, 1, ACOR, 1) GO TO 400 C----------------------------------------------------------------------- C In the case of the chord method, compute the corrector error, C and solve the linear system with that as right-hand side and C P as coefficient matrix. The correction is scaled by the factor C 2/(1+RC) to account for changes in h*rl1 since the last ZVJAC call. C----------------------------------------------------------------------- 350 DO 360 I = 1,N Y(I) = (RL1*H)*SAVF(I) - (RL1*YH(I,2) + ACOR(I)) 360 CONTINUE CALL ZVSOL (WM, IWM, Y, IERSL) NNI = NNI + 1 IF (IERSL .GT. 0) GO TO 410 IF (METH .EQ. 2 .AND. RC .NE. ONE) THEN CSCALE = TWO/(ONE + RC) CALL DZSCAL (N, CSCALE, Y, 1) ENDIF DEL = ZVNORM (N, Y, EWT) CALL DZAXPY (N, ONE, Y, 1, ACOR, 1) DO 380 I = 1,N Y(I) = YH(I,1) + ACOR(I) 380 CONTINUE C----------------------------------------------------------------------- C Test for convergence. If M .gt. 0, an estimate of the convergence C rate constant is stored in CRATE, and this is used in the test. C----------------------------------------------------------------------- 400 IF (M .NE. 0) CRATE = MAX(CRDOWN*CRATE,DEL/DELP) DCON = DEL*MIN(ONE,CRATE)/TQ(4) IF (DCON .LE. ONE) GO TO 450 M = M + 1 IF (M .EQ. MAXCOR) GO TO 410 IF (M .GE. 2 .AND. DEL .GT. RDIV*DELP) GO TO 410 DELP = DEL CALL F (N, TN, Y, SAVF, RPAR, IPAR) NFE = NFE + 1 GO TO 270 C 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 ICF = 1 IPUP = MITER GO TO 220 C 430 CONTINUE NFLAG = -1 ICF = 2 IPUP = MITER RETURN C C Return for successful step. ------------------------------------------ 450 NFLAG = 0 JCUR = 0 ICF = 0 IF (M .EQ. 0) ACNRM = DEL IF (M .GT. 0) ACNRM = ZVNORM (N, ACOR, EWT) RETURN C----------------------- End of Subroutine ZVNLSD ---------------------- END *DECK ZVJAC SUBROUTINE ZVJAC (Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, F, JAC, 1 IERPJ, RPAR, IPAR) EXTERNAL F, JAC COMPLEX(KIND=8) Y, YH, FTEM, SAVF, WM DOUBLE PRECISION EWT INTEGER LDYH, IWM, IERPJ, IPAR DIMENSION Y(*), YH(LDYH,*), EWT(*), FTEM(*), SAVF(*), 1 WM(*), IWM(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call sequence input -- Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, C F, JAC, RPAR, IPAR C Call sequence output -- WM, IWM, IERPJ C COMMON block variables accessed: C /ZVOD01/ CCMXJ, DRC, H, HRL1, RL1, SRUR, TN, UROUND, ICF, JCUR, C LOCJS, MITER, MSBJ, N, NSLJ C /ZVOD02/ NFE, NST, NJE, NLU C C Subroutines called by ZVJAC: F, JAC, ZACOPY, ZCOPY, ZGBFA, ZGEFA, C DZSCAL C Function routines called by ZVJAC: ZVNORM C----------------------------------------------------------------------- C ZVJAC is called by ZVNLSD to compute and process the matrix C P = I - h*rl1*J , where J is an approximation to the Jacobian. C Here J is computed by the user-supplied routine JAC if C MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5. C If MITER = 3, a diagonal approximation to J is used. C If JSV = -1, J is computed from scratch in all cases. C If JSV = 1 and MITER = 1, 2, 4, or 5, and if the saved value of J is C considered acceptable, then P is constructed from the saved J. C J is stored in wm and replaced by P. If MITER .ne. 3, P is then C subjected to LU decomposition in preparation for later solution C of linear systems with P as coefficient matrix. This is done C by ZGEFA if MITER = 1 or 2, and by ZGBFA if MITER = 4 or 5. C C Communication with ZVJAC is done with the following variables. (For C more details, please see the comments in the driver subroutine.) C Y = Vector containing predicted values on entry. C YH = The Nordsieck array, an LDYH by LMAX array, input. C LDYH = A constant .ge. N, the first dimension of YH, input. C EWT = An error weight vector of length N. C SAVF = Array containing f evaluated at predicted y, input. C WM = Complex work space for matrices. In the output, it C contains the inverse diagonal matrix if MITER = 3 and C the LU decomposition of P if MITER is 1, 2 , 4, or 5. C Storage of the saved Jacobian starts at WM(LOCJS). C IWM = Integer work space containing pivot information, C starting at IWM(31), if MITER is 1, 2, 4, or 5. C IWM also contains band parameters ML = IWM(1) and C MU = IWM(2) if MITER is 4 or 5. C F = Dummy name for the user-supplied subroutine for f. C JAC = Dummy name for the user-supplied Jacobian subroutine. C RPAR, IPAR = User's real/complex and integer work arrays. C RL1 = 1/EL(2) (input). C IERPJ = Output error flag, = 0 if no trouble, 1 if the P C matrix is found to be singular. C JCUR = Output flag to indicate whether the Jacobian matrix C (or approximation) is now current. C JCUR = 0 means J is not current. C JCUR = 1 means J is current. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block ZVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 4 NSLP, NYH C C Type declarations for labeled COMMON block ZVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C COMPLEX(KIND=8) DI, R1, YI, YJ, YJJ DOUBLE PRECISION CON, FAC, ONE, PT1, R, R0, THOU, ZERO INTEGER I, I1, I2, IER, II, J, J1, JJ, JOK, LENP, MBA, MBAND, 1 MEB1, MEBAND, ML, ML1, MU, NP1 C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION ZVNORM C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this subroutine. C----------------------------------------------------------------------- SAVE ONE, PT1, THOU, ZERO C----------------------------------------------------------------------- COMMON /ZVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), ETA, 1 ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU(13), TQ(5), TN, UROUND, 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 7 NSLP, NYH COMMON /ZVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA ONE /1.0D0/, THOU /1000.0D0/, ZERO /0.0D0/, PT1 /0.1D0/ C IERPJ = 0 HRL1 = H*RL1 C See whether J should be evaluated (JOK = -1) or not (JOK = 1). ------- JOK = JSV IF (JSV .EQ. 1) THEN IF (NST .EQ. 0 .OR. NST .GT. NSLJ+MSBJ) JOK = -1 IF (ICF .EQ. 1 .AND. DRC .LT. CCMXJ) JOK = -1 IF (ICF .EQ. 2) JOK = -1 ENDIF C End of setting JOK. -------------------------------------------------- C IF (JOK .EQ. -1 .AND. MITER .EQ. 1) THEN C If JOK = -1 and MITER = 1, call JAC to evaluate Jacobian. ------------ NJE = NJE + 1 NSLJ = NST JCUR = 1 LENP = N*N DO 110 I = 1,LENP WM(I) = ZERO 110 CONTINUE CALL JAC (N, TN, Y, 0, 0, WM, N, RPAR, IPAR) IF (JSV .EQ. 1) CALL ZCOPY (LENP, WM, 1, WM(LOCJS), 1) ENDIF C IF (JOK .EQ. -1 .AND. MITER .EQ. 2) THEN C If MITER = 2, make N calls to F to approximate the Jacobian. --------- NJE = NJE + 1 NSLJ = NST JCUR = 1 FAC = ZVNORM (N, SAVF, EWT) R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC IF (R0 .EQ. ZERO) R0 = ONE J1 = 0 DO 230 J = 1,N YJ = Y(J) R = MAX(SRUR*ABS(YJ),R0/EWT(J)) Y(J) = Y(J) + R FAC = ONE/R CALL F (N, TN, Y, FTEM, RPAR, IPAR) DO 220 I = 1,N WM(I+J1) = (FTEM(I) - SAVF(I))*FAC 220 CONTINUE Y(J) = YJ J1 = J1 + N 230 CONTINUE NFE = NFE + N LENP = N*N IF (JSV .EQ. 1) CALL ZCOPY (LENP, WM, 1, WM(LOCJS), 1) ENDIF C IF (JOK .EQ. 1 .AND. (MITER .EQ. 1 .OR. MITER .EQ. 2)) THEN JCUR = 0 LENP = N*N CALL ZCOPY (LENP, WM(LOCJS), 1, WM, 1) ENDIF C IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN C Multiply Jacobian by scalar, add identity, and do LU decomposition. -- CON = -HRL1 CALL DZSCAL (LENP, CON, WM, 1) J = 1 NP1 = N + 1 DO 250 I = 1,N WM(J) = WM(J) + ONE J = J + NP1 250 CONTINUE NLU = NLU + 1 CALL ZGEFA (WM, N, N, IWM(31), IER) IF (IER .NE. 0) IERPJ = 1 RETURN ENDIF C End of code block for MITER = 1 or 2. -------------------------------- C IF (MITER .EQ. 3) THEN C If MITER = 3, construct a diagonal approximation to J and P. --------- NJE = NJE + 1 JCUR = 1 R = RL1*PT1 DO 310 I = 1,N Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) 310 CONTINUE CALL F (N, TN, Y, WM, RPAR, IPAR) NFE = NFE + 1 DO 320 I = 1,N R1 = H*SAVF(I) - YH(I,2) DI = PT1*R1 - H*(WM(I) - SAVF(I)) WM(I) = ONE IF (ABS(R1) .LT. UROUND/EWT(I)) GO TO 320 IF (ABS(DI) .EQ. ZERO) GO TO 330 WM(I) = PT1*R1/DI 320 CONTINUE RETURN 330 IERPJ = 1 RETURN ENDIF C End of code block for MITER = 3. ------------------------------------- C C Set constants for MITER = 4 or 5. ------------------------------------ ML = IWM(1) MU = IWM(2) ML1 = ML + 1 MBAND = ML + MU + 1 MEBAND = MBAND + ML LENP = MEBAND*N C IF (JOK .EQ. -1 .AND. MITER .EQ. 4) THEN C If JOK = -1 and MITER = 4, call JAC to evaluate Jacobian. ------------ NJE = NJE + 1 NSLJ = NST JCUR = 1 DO 410 I = 1,LENP WM(I) = ZERO 410 CONTINUE CALL JAC (N, TN, Y, ML, MU, WM(ML1), MEBAND, RPAR, IPAR) IF (JSV .EQ. 1) 1 CALL ZACOPY (MBAND, N, WM(ML1), MEBAND, WM(LOCJS), MBAND) ENDIF C IF (JOK .EQ. -1 .AND. MITER .EQ. 5) THEN C If MITER = 5, make ML+MU+1 calls to F to approximate the Jacobian. --- NJE = NJE + 1 NSLJ = NST JCUR = 1 MBA = MIN(MBAND,N) MEB1 = MEBAND - 1 FAC = ZVNORM (N, SAVF, EWT) R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC IF (R0 .EQ. ZERO) R0 = ONE DO 560 J = 1,MBA DO 530 I = J,N,MBAND YI = Y(I) R = MAX(SRUR*ABS(YI),R0/EWT(I)) Y(I) = Y(I) + R 530 CONTINUE CALL F (N, TN, Y, FTEM, RPAR, IPAR) DO 550 JJ = J,N,MBAND Y(JJ) = YH(JJ,1) YJJ = Y(JJ) R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) FAC = ONE/R I1 = MAX(JJ-MU,1) I2 = MIN(JJ+ML,N) II = JJ*MEB1 - ML DO 540 I = I1,I2 WM(II+I) = (FTEM(I) - SAVF(I))*FAC 540 CONTINUE 550 CONTINUE 560 CONTINUE NFE = NFE + MBA IF (JSV .EQ. 1) 1 CALL ZACOPY (MBAND, N, WM(ML1), MEBAND, WM(LOCJS), MBAND) ENDIF C IF (JOK .EQ. 1) THEN JCUR = 0 CALL ZACOPY (MBAND, N, WM(LOCJS), MBAND, WM(ML1), MEBAND) ENDIF C C Multiply Jacobian by scalar, add identity, and do LU decomposition. CON = -HRL1 CALL DZSCAL (LENP, CON, WM, 1 ) II = MBAND DO 580 I = 1,N WM(II) = WM(II) + ONE II = II + MEBAND 580 CONTINUE NLU = NLU + 1 CALL ZGBFA (WM, MEBAND, N, ML, MU, IWM(31), IER) IF (IER .NE. 0) IERPJ = 1 RETURN C End of code block for MITER = 4 or 5. -------------------------------- C C----------------------- End of Subroutine ZVJAC ----------------------- END *DECK ZACOPY SUBROUTINE ZACOPY (NROW, NCOL, A, NROWA, B, NROWB) COMPLEX(KIND=8) A, B INTEGER NROW, NCOL, NROWA, NROWB DIMENSION A(NROWA,NCOL), B(NROWB,NCOL) C----------------------------------------------------------------------- C Call sequence input -- NROW, NCOL, A, NROWA, NROWB C Call sequence output -- B C COMMON block variables accessed -- None C C Subroutines called by ZACOPY: ZCOPY C Function routines called by ZACOPY: None C----------------------------------------------------------------------- C This routine copies one rectangular array, A, to another, B, C where A and B may have different row dimensions, NROWA and NROWB. C The data copied consists of NROW rows and NCOL columns. C----------------------------------------------------------------------- INTEGER IC C DO 20 IC = 1,NCOL CALL ZCOPY (NROW, A(1,IC), 1, B(1,IC), 1) 20 CONTINUE C RETURN C----------------------- End of Subroutine ZACOPY ---------------------- END *DECK ZVSOL SUBROUTINE ZVSOL (WM, IWM, X, IERSL) COMPLEX(KIND=8) WM, X INTEGER IWM, IERSL DIMENSION WM(*), IWM(*), X(*) C----------------------------------------------------------------------- C Call sequence input -- WM, IWM, X C Call sequence output -- X, IERSL C COMMON block variables accessed: C /ZVOD01/ -- H, HRL1, RL1, MITER, N C C Subroutines called by ZVSOL: ZGESL, ZGBSL C Function routines called by ZVSOL: None C----------------------------------------------------------------------- C This routine manages the solution of the linear system arising from C a chord iteration. It is called if MITER .ne. 0. C If MITER is 1 or 2, it calls ZGESL to accomplish this. C If MITER = 3 it updates the coefficient H*RL1 in the diagonal C matrix, and then computes the solution. C If MITER is 4 or 5, it calls ZGBSL. C Communication with ZVSOL uses the following variables: C WM = Real work space containing the inverse diagonal matrix if C MITER = 3 and the LU decomposition of the matrix otherwise. C IWM = Integer work space containing pivot information, starting at C IWM(31), if MITER is 1, 2, 4, or 5. IWM also contains band C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. C X = The right-hand side vector on input, and the solution vector C on output, of length N. C IERSL = Output flag. IERSL = 0 if no trouble occurred. C IERSL = 1 if a singular matrix arose with MITER = 3. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block ZVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 4 NSLP, NYH C C Type declarations for local variables -------------------------------- C COMPLEX(KIND=8) DI DOUBLE PRECISION ONE, PHRL1, R, ZERO INTEGER I, MEBAND, ML, MU C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE ONE, ZERO C COMMON /ZVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), ETA, 1 ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU(13), TQ(5), TN, UROUND, 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 7 NSLP, NYH C DATA ONE /1.0D0/, ZERO /0.0D0/ C IERSL = 0 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN GOTO 100 ELSE IF (MITER .EQ. 3) THEN GOTO 300 ELSE IF (MITER .LE. 5) THEN GOTO 400 ENDIF C GO TO (100, 100, 300, 400, 400), MITER 100 CALL ZGESL (WM, N, N, IWM(31), X, 0) RETURN C 300 PHRL1 = HRL1 HRL1 = H*RL1 IF (HRL1 .EQ. PHRL1) GO TO 330 R = HRL1/PHRL1 DO 320 I = 1,N DI = ONE - R*(ONE - ONE/WM(I)) IF (ABS(DI) .EQ. ZERO) GO TO 390 WM(I) = ONE/DI 320 CONTINUE C 330 DO 340 I = 1,N X(I) = WM(I)*X(I) 340 CONTINUE RETURN 390 IERSL = 1 RETURN C 400 ML = IWM(1) MU = IWM(2) MEBAND = 2*ML + MU + 1 CALL ZGBSL (WM, MEBAND, N, ML, MU, IWM(31), X, 0) RETURN C----------------------- End of Subroutine ZVSOL ----------------------- END *DECK ZVSRCO SUBROUTINE ZVSRCO (RSAV, ISAV, JOB) DOUBLE PRECISION RSAV INTEGER ISAV, JOB DIMENSION RSAV(*), ISAV(*) C----------------------------------------------------------------------- C Call sequence input -- RSAV, ISAV, JOB C Call sequence output -- RSAV, ISAV C COMMON block variables accessed -- All of /ZVOD01/ and /ZVOD02/ C C Subroutines/functions called by ZVSRCO: None C----------------------------------------------------------------------- C This routine saves or restores (depending on JOB) the contents of the C COMMON blocks ZVOD01 and ZVOD02, which are used internally by ZVODE. C C RSAV = real array of length 51 or more. C ISAV = integer array of length 41 or more. C JOB = flag indicating to save or restore the COMMON blocks: C JOB = 1 if COMMON is to be saved (written to RSAV/ISAV). C JOB = 2 if COMMON is to be restored (read from RSAV/ISAV). C A call with JOB = 2 presumes a prior call with JOB = 1. C----------------------------------------------------------------------- DOUBLE PRECISION RVOD1, RVOD2 INTEGER IVOD1, IVOD2 INTEGER I, LENIV1, LENIV2, LENRV1, LENRV2 C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE LENRV1, LENIV1, LENRV2, LENIV2 C COMMON /ZVOD01/ RVOD1(50), IVOD1(33) COMMON /ZVOD02/ RVOD2(1), IVOD2(8) DATA LENRV1/50/, LENIV1/33/, LENRV2/1/, LENIV2/8/ C IF (JOB .EQ. 2) GO TO 100 DO 10 I = 1,LENRV1 RSAV(I) = RVOD1(I) 10 CONTINUE DO 15 I = 1,LENRV2 RSAV(LENRV1+I) = RVOD2(I) 15 CONTINUE C DO 20 I = 1,LENIV1 ISAV(I) = IVOD1(I) 20 CONTINUE DO 25 I = 1,LENIV2 ISAV(LENIV1+I) = IVOD2(I) 25 CONTINUE C RETURN C 100 CONTINUE DO 110 I = 1,LENRV1 RVOD1(I) = RSAV(I) 110 CONTINUE DO 115 I = 1,LENRV2 RVOD2(I) = RSAV(LENRV1+I) 115 CONTINUE C DO 120 I = 1,LENIV1 IVOD1(I) = ISAV(I) 120 CONTINUE DO 125 I = 1,LENIV2 IVOD2(I) = ISAV(LENIV1+I) 125 CONTINUE C RETURN C----------------------- End of Subroutine ZVSRCO ---------------------- END *DECK ZEWSET SUBROUTINE ZEWSET (N, ITOL, RTOL, ATOL, YCUR, EWT) C***BEGIN PROLOGUE ZEWSET C***SUBSIDIARY C***PURPOSE Set error weight vector. C***TYPE DOUBLE PRECISION (SEWSET-S, DEWSET-D, ZEWSET-Z) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C This subroutine sets the error weight vector EWT according to C EWT(i) = RTOL(i)*ABS(YCUR(i)) + ATOL(i), i = 1,...,N, C with the subscript on RTOL and/or ATOL possibly replaced by 1 above, C depending on the value of ITOL. C C***SEE ALSO DLSODE C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 060502 DATE WRITTEN, modified from DEWSET of 930809. C***END PROLOGUE ZEWSET COMPLEX(KIND=8) YCUR DOUBLE PRECISION RTOL, ATOL, EWT INTEGER N, ITOL INTEGER I DIMENSION RTOL(*), ATOL(*), YCUR(N), EWT(N) C C***FIRST EXECUTABLE STATEMENT ZEWSET IF (ITOL .EQ. 1) THEN GOTO 10 ELSE IF (ITOL .EQ. 2) THEN GOTO 20 ELSE IF (ITOL .EQ. 3) THEN GOTO 30 ELSE IF (ITOL .EQ. 4) THEN GOTO 40 ENDIF C GO TO (10, 20, 30, 40), ITOL 10 CONTINUE DO 15 I = 1,N EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(1) 15 CONTINUE RETURN 20 CONTINUE DO 25 I = 1,N EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(I) 25 CONTINUE RETURN 30 CONTINUE DO 35 I = 1,N EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(1) 35 CONTINUE RETURN 40 CONTINUE DO 45 I = 1,N EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I) 45 CONTINUE RETURN C----------------------- END OF SUBROUTINE ZEWSET ---------------------- END *DECK ZVNORM DOUBLE PRECISION FUNCTION ZVNORM (N, V, W) C***BEGIN PROLOGUE ZVNORM C***SUBSIDIARY C***PURPOSE Weighted root-mean-square vector norm. C***TYPE DOUBLE COMPLEX (SVNORM-S, DVNORM-D, ZVNORM-Z) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C This function routine computes the weighted root-mean-square norm C of the vector of length N contained in the double complex array V, C with weights contained in the array W of length N: C ZVNORM = SQRT( (1/N) * SUM( abs(V(i))**2 * W(i)**2 ) C The squared absolute value abs(v)**2 is computed by ZABSSQ. C C***SEE ALSO DLSODE C***ROUTINES CALLED ZABSSQ C***REVISION HISTORY (YYMMDD) C 060502 DATE WRITTEN, modified from DVNORM of 930809. C***END PROLOGUE ZVNORM COMPLEX(KIND=8) V DOUBLE PRECISION W, SUM, ZABSSQ INTEGER N, I DIMENSION V(N), W(N) C C***FIRST EXECUTABLE STATEMENT ZVNORM SUM = 0.0D0 DO 10 I = 1,N SUM = SUM + ZABSSQ(V(I)) * W(I)**2 10 CONTINUE ZVNORM = SQRT(SUM/N) RETURN C----------------------- END OF FUNCTION ZVNORM ------------------------ END *DECK ZABSSQ DOUBLE PRECISION FUNCTION ZABSSQ(Z) C***BEGIN PROLOGUE ZABSSQ C***SUBSIDIARY C***PURPOSE Squared absolute value of a double complex number. C***TYPE DOUBLE PRECISION (ZABSSQ-Z) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C This function routine computes the square of the absolute value of C a double precision complex number Z, C ZABSSQ = DREAL(Z)**2 * DIMAG(Z)**2 C***REVISION HISTORY (YYMMDD) C 060502 DATE WRITTEN. C***END PROLOGUE ZABSSQ COMPLEX(KIND=8) Z ZABSSQ = DREAL(Z)**2 + DIMAG(Z)**2 RETURN C----------------------- END OF FUNCTION ZABSSQ ------------------------ END *DECK DZSCAL SUBROUTINE DZSCAL(N, DA, ZX, INCX) C***BEGIN PROLOGUE DZSCAL C***SUBSIDIARY C***PURPOSE Scale a double complex vector by a double prec. constant. C***TYPE DOUBLE PRECISION (DZSCAL-Z) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C Scales a double complex vector by a double precision constant. C Minor modification of BLAS routine ZSCAL. C***REVISION HISTORY (YYMMDD) C 060530 DATE WRITTEN. C***END PROLOGUE DZSCAL COMPLEX(KIND=8) ZX(*) DOUBLE PRECISION DA INTEGER I,INCX,IX,N C IF( N.LE.0 .OR. INCX.LE.0 )RETURN IF(INCX.EQ.1)GO TO 20 C Code for increment not equal to 1 IX = 1 DO 10 I = 1,N ZX(IX) = DA*ZX(IX) IX = IX + INCX 10 CONTINUE RETURN C Code for increment equal to 1 20 DO 30 I = 1,N ZX(I) = DA*ZX(I) 30 CONTINUE RETURN END *DECK DZAXPY SUBROUTINE DZAXPY(N, DA, ZX, INCX, ZY, INCY) C***BEGIN PROLOGUE DZAXPY C***PURPOSE Real constant times a complex vector plus a complex vector. C***TYPE DOUBLE PRECISION (DZAXPY-Z) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C Add a D.P. real constant times a complex vector to a complex vector. C Minor modification of BLAS routine ZAXPY. C***REVISION HISTORY (YYMMDD) C 060530 DATE WRITTEN. C***END PROLOGUE DZAXPY COMPLEX(KIND=8) ZX(*),ZY(*) DOUBLE PRECISION DA INTEGER I,INCX,INCY,IX,IY,N IF(N.LE.0)RETURN IF (ABS(DA) .EQ. 0.0D0) RETURN IF (INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C Code for unequal increments or equal increments not equal to 1 IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N ZY(IY) = ZY(IY) + DA*ZX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C Code for both increments equal to 1 20 DO 30 I = 1,N ZY(I) = ZY(I) + DA*ZX(I) 30 CONTINUE RETURN END subroutine zgesl(a,lda,n,ipvt,b,job) integer lda,n,ipvt(1),job COMPLEX(KIND=8) a(lda,*),b(*) c c zgesl solves the COMPLEX(KIND=8) system c a * x = b or ctrans(a) * x = b c using the factors computed by zgeco or zgefa. c c on entry c c a COMPLEX(KIND=8)(lda, n) c the output from zgeco or zgefa. c c lda integer c the leading dimension of the array a . c c n integer c the order of the matrix a . c c ipvt integer(n) c the pivot vector from zgeco or zgefa. c c b COMPLEX(KIND=8)(n) c the right hand side vector. c c job integer c = 0 to solve a*x = b , c = nonzero to solve ctrans(a)*x = b where c ctrans(a) is the conjugate transpose. c c on return c c b the solution vector x . c c error condition c c a division by zero will occur if the input factor contains a c zero on the diagonal. technically this indicates singularity c but it is often caused by improper arguments or improper c setting of lda . it will not occur if the subroutines are c called correctly and if zgeco has set rcond .gt. 0.0 c or zgefa has set info .eq. 0 . c c to compute inverse(a) * c where c is a matrix c with p columns c call zgeco(a,lda,n,ipvt,rcond,z) c if (rcond is too small) go to ... c do 10 j = 1, p c call zgesl(a,lda,n,ipvt,c(1,j),0) c 10 continue c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas zaxpy,zdotc c fortran dconjg c c internal variables c COMPLEX(KIND=8) zdotc,t integer k,kb,l,nm1 C KS double precision dreal,dimag C KS COMPLEX(KIND=8) zdumr,zdumi C KS dreal(zdumr) = zdumr C KS dimag(zdumi) = (0.0d0,-1.0d0)*zdumi c nm1 = n - 1 if (job .ne. 0) go to 50 c c job = 0 , solve a * x = b c first solve l*y = b c if (nm1 .lt. 1) go to 30 do 20 k = 1, nm1 l = ipvt(k) t = b(l) if (l .eq. k) go to 10 b(l) = b(k) b(k) = t 10 continue call zaxpy(n-k,t,a(k+1,k),1,b(k+1),1) 20 continue 30 continue c c now solve u*x = y c do 40 kb = 1, n k = n + 1 - kb b(k) = b(k)/a(k,k) t = -b(k) call zaxpy(k-1,t,a(1,k),1,b(1),1) 40 continue go to 100 50 continue c c job = nonzero, solve ctrans(a) * x = b c first solve ctrans(u)*y = b c do 60 k = 1, n t = zdotc(k-1,a(1,k),1,b(1),1) b(k) = (b(k) - t)/dconjg(a(k,k)) 60 continue c c now solve ctrans(l)*x = y c if (nm1 .lt. 1) go to 90 do 80 kb = 1, nm1 k = n - kb b(k) = b(k) + zdotc(n-k,a(k+1,k),1,b(k+1),1) l = ipvt(k) if (l .eq. k) go to 70 t = b(l) b(l) = b(k) b(k) = t 70 continue 80 continue 90 continue 100 continue return end subroutine zgbfa(abd,lda,n,ml,mu,ipvt,info) integer lda,n,ml,mu,ipvt(*),info COMPLEX(KIND=8) abd(lda,*) c c zgbfa factors a COMPLEX(KIND=8) band matrix by elimination. c c zgbfa is usually called by zgbco, but it can be called c directly with a saving in time if rcond is not needed. c c on entry c c abd COMPLEX(KIND=8)(lda, n) c contains the matrix in band storage. the columns c of the matrix are stored in the columns of abd and c the diagonals of the matrix are stored in rows c ml+1 through 2*ml+mu+1 of abd . c see the comments below for details. c c lda integer c the leading dimension of the array abd . c lda must be .ge. 2*ml + mu + 1 . c c n integer c the order of the original matrix. c c ml integer c number of diagonals below the main diagonal. c 0 .le. ml .lt. n . c c mu integer c number of diagonals above the main diagonal. c 0 .le. mu .lt. n . c more efficient if ml .le. mu . c on return c c abd an upper triangular matrix in band storage and c the multipliers which were used to obtain it. c the factorization can be written a = l*u where c l is a product of permutation and unit lower c triangular matrices and u is upper triangular. c c ipvt integer(n) c an integer vector of pivot indices. c c info integer c = 0 normal value. c = k if u(k,k) .eq. 0.0 . this is not an error c condition for this subroutine, but it does c indicate that zgbsl will divide by zero if c called. use rcond in zgbco for a reliable c indication of singularity. c c band storage c c if a is a band matrix, the following program segment c will set up the input. c c ml = (band width below the diagonal) c mu = (band width above the diagonal) c m = ml + mu + 1 c do 20 j = 1, n c i1 = max0(1, j-mu) c i2 = min0(n, j+ml) c do 10 i = i1, i2 c k = i - j + m c abd(k,j) = a(i,j) c 10 continue c 20 continue c c this uses rows ml+1 through 2*ml+mu+1 of abd . c in addition, the first ml rows in abd are used for c elements generated during the triangularization. c the total number of rows needed in abd is 2*ml+mu+1 . c the ml+mu by ml+mu upper left triangle and the c ml by ml lower right triangle are not referenced. c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas zaxpy,zscal,izamax c fortran dabs,max0,min0 c c internal variables c COMPLEX(KIND=8) t integer i,izamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 c CKS COMPLEX(KIND=8) zdum double precision cabs1 C double precision dreal,dimag C COMPLEX(KIND=8) zdumr,zdumi C dreal(zdumr) = zdumr C dimag(zdumi) = (0.0d0,-1.0d0)*zdumi CKS cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) c m = ml + mu + 1 info = 0 c c zero initial fill-in columns c j0 = mu + 2 j1 = min0(n,m) - 1 if (j1 .lt. j0) go to 30 do 20 jz = j0, j1 i0 = m + 1 - jz do 10 i = i0, ml abd(i,jz) = (0.0d0,0.0d0) 10 continue 20 continue 30 continue jz = j1 ju = 0 c c gaussian elimination with partial pivoting c nm1 = n - 1 if (nm1 .lt. 1) go to 130 do 120 k = 1, nm1 kp1 = k + 1 c c zero next fill-in column c jz = jz + 1 if (jz .gt. n) go to 50 if (ml .lt. 1) go to 50 do 40 i = 1, ml abd(i,jz) = (0.0d0,0.0d0) 40 continue 50 continue c c find l = pivot index c lm = min0(ml,n-k) l = izamax(lm+1,abd(m,k),1) + m - 1 ipvt(k) = l + k - m c c zero pivot implies this column already triangularized c if (cabs1(abd(l,k)) .eq. 0.0d0) go to 100 c c interchange if necessary c if (l .eq. m) go to 60 t = abd(l,k) abd(l,k) = abd(m,k) abd(m,k) = t 60 continue c c compute multipliers c t = -(1.0d0,0.0d0)/abd(m,k) call zscal(lm,t,abd(m+1,k),1) c c row elimination with column indexing c ju = min0(max0(ju,mu+ipvt(k)),n) mm = m if (ju .lt. kp1) go to 90 do 80 j = kp1, ju l = l - 1 mm = mm - 1 t = abd(l,j) if (l .eq. mm) go to 70 abd(l,j) = abd(mm,j) abd(mm,j) = t 70 continue call zaxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1) 80 continue 90 continue go to 110 100 continue info = k 110 continue 120 continue 130 continue ipvt(n) = n if (cabs1(abd(m,n)) .eq. 0.0d0) info = n return end subroutine zgbsl(abd,lda,n,ml,mu,ipvt,b,job) integer lda,n,ml,mu,ipvt(1),job COMPLEX(KIND=8) abd(lda,*),b(*) c c zgbsl solves the COMPLEX(KIND=8) band system c a * x = b or ctrans(a) * x = b c using the factors computed by zgbco or zgbfa. c c on entry c c abd COMPLEX(KIND=8)(lda, n) c the output from zgbco or zgbfa. c c lda integer c the leading dimension of the array abd . c c n integer c the order of the original matrix. c c ml integer c number of diagonals below the main diagonal. c c mu integer c number of diagonals above the main diagonal. c c ipvt integer(n) c the pivot vector from zgbco or zgbfa. c c b COMPLEX(KIND=8)(n) c the right hand side vector. c c job integer c = 0 to solve a*x = b , c = nonzero to solve ctrans(a)*x = b , where c ctrans(a) is the conjugate transpose. c c on return c c b the solution vector x . c c error condition c c a division by zero will occur if the input factor contains a c zero on the diagonal. technically this indicates singularity c but it is often caused by improper arguments or improper c setting of lda . it will not occur if the subroutines are c called correctly and if zgbco has set rcond .gt. 0.0 c or zgbfa has set info .eq. 0 . c c to compute inverse(a) * c where c is a matrix c with p columns c call zgbco(abd,lda,n,ml,mu,ipvt,rcond,z) c if (rcond is too small) go to ... c do 10 j = 1, p c call zgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0) c 10 continue c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas zaxpy,zdotc c fortran dconjg,min0 c c internal variables c COMPLEX(KIND=8) zdotc,t integer k,kb,l,la,lb,lm,m,nm1 C double precision dreal,dimag C COMPLEX(KIND=8) zdumr,zdumi C dreal(zdumr) = zdumr C dimag(zdumi) = (0.0d0,-1.0d0)*zdumi c m = mu + ml + 1 nm1 = n - 1 if (job .ne. 0) go to 50 c c job = 0 , solve a * x = b c first solve l*y = b c if (ml .eq. 0) go to 30 if (nm1 .lt. 1) go to 30 do 20 k = 1, nm1 lm = min0(ml,n-k) l = ipvt(k) t = b(l) if (l .eq. k) go to 10 b(l) = b(k) b(k) = t 10 continue call zaxpy(lm,t,abd(m+1,k),1,b(k+1),1) 20 continue 30 continue c c now solve u*x = y c do 40 kb = 1, n k = n + 1 - kb b(k) = b(k)/abd(m,k) lm = min0(k,m) - 1 la = m - lm lb = k - lm t = -b(k) call zaxpy(lm,t,abd(la,k),1,b(lb),1) 40 continue go to 100 50 continue c c job = nonzero, solve ctrans(a) * x = b c first solve ctrans(u)*y = b c do 60 k = 1, n lm = min0(k,m) - 1 la = m - lm lb = k - lm t = zdotc(lm,abd(la,k),1,b(lb),1) b(k) = (b(k) - t)/dconjg(abd(m,k)) 60 continue c c now solve ctrans(l)*x = y c if (ml .eq. 0) go to 90 if (nm1 .lt. 1) go to 90 do 80 kb = 1, nm1 k = n - kb lm = min0(ml,n-k) b(k) = b(k) + zdotc(lm,abd(m+1,k),1,b(k+1),1) l = ipvt(k) if (l .eq. k) go to 70 t = b(l) b(l) = b(k) b(k) = t 70 continue 80 continue 90 continue 100 continue return end C KARLINE: created true functions out of these statement functions C Thomas: removed function definitions for dreal and dimag, C they were already existing. C We may consider to use 'real' and 'imag' consistently for C future versions. double precision function cabs1(zdum) complex (kind = 8), intent (in) :: zdum cabs1 = dabs(dreal(zdum)) + dabs(dimag(zdum)) end function C KARLINE: end new functions subroutine zgefa(a,lda,n,ipvt,info) integer lda,n,ipvt(*),info COMPLEX(KIND=8) a(lda,*) c c zgefa factors a COMPLEX(KIND=8) matrix by gaussian elimination. c c zgefa is usually called by zgeco, but it can be called c directly with a saving in time if rcond is not needed. c (time for zgeco) = (1 + 9/n)*(time for zgefa) . c c on entry c c a COMPLEX(KIND=8)(lda, n) c the matrix to be factored. c c lda integer c the leading dimension of the array a . c c n integer c the order of the matrix a . c c on return c c a an upper triangular matrix and the multipliers c which were used to obtain it. c the factorization can be written a = l*u where c l is a product of permutation and unit lower c triangular matrices and u is upper triangular. c c ipvt integer(n) c an integer vector of pivot indices. c c info integer c = 0 normal value. c = k if u(k,k) .eq. 0.0 . this is not an error c condition for this subroutine, but it does c indicate that zgesl or zgedi will divide by zero c if called. use rcond in zgeco for a reliable c indication of singularity. c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas zaxpy,zscal,izamax c fortran dabs c c internal variables c COMPLEX(KIND=8) t integer izamax,j,k,kp1,l,nm1 c C KS COMPLEX(KIND=8) zdum double precision cabs1 C double precision dreal,dimag C KS COMPLEX(KIND=8) zdumr,zdumi C Karline: next three statement functions replaced with true functions above C dreal(zdumr) = zdumr C dimag(zdumi) = (0.0d0,-1.0d0)*zdumi C cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) c c gaussian elimination with partial pivoting c info = 0 nm1 = n - 1 if (nm1 .lt. 1) go to 70 do 60 k = 1, nm1 kp1 = k + 1 c c find l = pivot index c l = izamax(n-k+1,a(k,k),1) + k - 1 ipvt(k) = l c c zero pivot implies this column already triangularized c if (cabs1(a(l,k)) .eq. 0.0d0) go to 40 c c interchange if necessary c if (l .eq. k) go to 10 t = a(l,k) a(l,k) = a(k,k) a(k,k) = t 10 continue c c compute multipliers c t = -(1.0d0,0.0d0)/a(k,k) call zscal(n-k,t,a(k+1,k),1) c c row elimination with column indexing c do 30 j = kp1, n t = a(l,j) if (l .eq. k) go to 20 a(l,j) = a(k,j) a(k,j) = t 20 continue call zaxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) 30 continue go to 50 40 continue info = k 50 continue 60 continue 70 continue ipvt(n) = n if (cabs1(a(n,n)) .eq. 0.0d0) info = n return end deSolve/src/twoDmap.c0000644000176000001440000001323613136461013014254 0ustar ripleyusers/* --------------------------------------------------------------------* SPARSITY of 2-D and 3-D reaction-transport problems with mapping the states that are present have a value > 0 in vector 'ipres' ipres contains the actual number of state variable, after applying the mask , e.g. ipres(20) = 10 means that the element 20 in the original 2D matrix is the 10th element, after applying the mask -------------------------------------------------------------------- */ #include #include #include #include #include "deSolve.h" void sparsity2Dmap (SEXP Type, int* iwork, int neq, int liw) { int nspec, nx, ny, bndx, bndy, Nt, ij, isp, i, j, k, l, m; int totN, *ipres, Mnew; nspec = INTEGER(Type)[1]; /* number components*/ nx = INTEGER(Type)[2]; /* dimension x*/ ny = INTEGER(Type)[3]; /* dimension y*/ bndx = INTEGER(Type)[4]; /* cyclic boundary x*/ bndy = INTEGER(Type)[5]; /* cyclic boundary y*/ totN = INTEGER(Type)[7]; /* Total state variables in original 2D matrix*/ ipres = (int *) R_alloc(totN, sizeof(int)); for (j=0; j < totN; j++) ipres[j] = INTEGER(Type)[j+8]; Nt = nx*ny; ij = 31 + neq; iwork[30] = 1; m = 1; for( i = 0; i < nspec; i++) { isp = i*Nt; for( j = 0; j < nx; j++) { for( k = 0; k < ny; k++) { if (ij > liw-8-nspec) error("not enough memory allocated in iwork - increase liw %i ",liw); Mnew = ipres[m-1]; if (Mnew > 0) { interactmap (&ij, liw, iwork, ipres, m); if (k < ny-1) interactmap (&ij, liw, iwork, ipres, m+1); if (j < nx-1) interactmap (&ij, liw, iwork, ipres, m+ny); if (j > 0) interactmap (&ij, liw, iwork, ipres, m-ny); if (k > 0) interactmap (&ij, liw, iwork, ipres, m-1); if (bndx == 1) { if (j == 0) interactmap (&ij, liw, iwork, ipres, isp+(nx-1)*ny+k+1); if (j == nx-1) interactmap (&ij, liw, iwork, ipres, isp+k+1); } if (bndy == 1) { if (k == 0) interactmap (&ij, liw, iwork, ipres, isp+(j+1)*ny); if (k == ny-1) interactmap (&ij, liw, iwork, ipres, isp + j*ny +1); } for(l = 0; l < nspec; l++) if (l != i) interactmap (&ij, liw, iwork, ipres, l*Nt+j*ny+k+1); iwork[30+Mnew] = ij-30-neq; } m = m+1; } } } } void interactmap (int *ij, int nnz, int *iwork, int *ipres, int ival) { /* check if not yet present for current state */ if (ipres[ival-1] > 0) { if (*ij > nnz) error ("not enough memory allocated in iwork - increase liw %i ", nnz); iwork[(*ij)++] = ipres[ival-1]; } } /*==================================================*/ /* an element in C-array A(I,J,K), i=0,dim(1)-1 etc... is positioned at j*dim(2)*dim(3) + k*dim(3) + l + 1 in FORTRAN VECTOR! includes check on validity dimens and boundary are reversed ... */ void sparsity3Dmap (SEXP Type, int* iwork, int neq, int liw) { int nspec, nx, ny, nz, bndx, bndy, bndz, Nt, ij, isp, i, j, k, l, m, ll; int totN, *ipres, Mnew; nspec = INTEGER(Type)[1]; nx = INTEGER(Type)[2]; ny = INTEGER(Type)[3]; nz = INTEGER(Type)[4]; bndx = INTEGER(Type)[5]; bndy = INTEGER(Type)[6]; bndz = INTEGER(Type)[7]; totN = INTEGER(Type)[9]; /* Total state variables in original 3D matrix*/ ipres = (int *) R_alloc(totN, sizeof(int)); for (j=0; j < totN; j++) {ipres[j] = INTEGER(Type)[j+10]; } Nt = nx*ny*nz; ij = 31+neq; iwork[30] = 1; m = 1; for( i = 0; i < nspec; i++) { isp = i*Nt; for( j = 0; j < nx; j++) { for( k = 0; k < ny; k++) { for( ll = 0; ll < nz; ll++) { if (ij > liw-6-nspec) error ("not enough memory allocated in iwork - increase liw %i ", liw); Mnew = ipres[m-1]; if (Mnew > 0) { interactmap (&ij, liw, iwork, ipres, m); if (ll < nz-1) interactmap (&ij, liw, iwork, ipres, m+1); else if (bndz == 1) interactmap (&ij, liw, iwork, ipres, isp + j*ny*nz + k*nz + 1); if (k < ny-1) interactmap (&ij, liw, iwork, ipres, m+nz); else if (bndy == 1) interactmap (&ij, liw, iwork, ipres, isp + j*ny*nz + ll + 1); if (j < nx-1) interactmap (&ij, liw, iwork, ipres, m+ny*nz); else if (bndx == 1) interactmap (&ij, liw, iwork, ipres, isp + k*nz + ll + 1); if (j > 0) interactmap (&ij, liw, iwork, ipres, m-ny*nz); else if (bndx == 1) interactmap (&ij, liw, iwork, ipres, isp+(nx-1)*ny*nz+k*nz+ll+1); if (k > 0) interactmap (&ij, liw, iwork, ipres, m-nz); else if (bndy == 1) interactmap (&ij, liw, iwork, ipres, isp + j*ny*nz+(ny-1)*nz+ll+1); if (ll > 0) interactmap (&ij, liw, iwork, ipres, m-1); else if (bndz == 1) interactmap (&ij, liw, iwork, ipres, isp + j*ny*nz+k*nz+nz); for(l = 0; l < nspec; l++) if (l != i) interactmap (&ij, liw, iwork, ipres, l*Nt+j*ny*nz+k*nz+ll+1); iwork[30+Mnew] = ij-30-neq; } m = m+1; } } } } } deSolve/src/ex_Aquaphy.c0000644000176000001440000001536613136461013014753 0ustar ripleyusers/* file ex_aquaphy.c The Aquaphy algal model -------- ex_Aquaphy.c -> ex_Aquaphy.dll ------ compile in R with: system("gcc -shared -o Aquaphy Aquaphy") or with system("R CMD SHLIB ex_Aquaphy") */ #include static double parms[19]; #define maxPhotoSynt parms[0] #define rMortPHY parms[1] #define alpha parms[2] #define pExudation parms[3] #define maxProteinSynt parms[4] #define ksDIN parms[5] #define minpLMW parms[6] #define maxpLMW parms[7] #define minQuotum parms[8] #define maxStorage parms[9] #define respirationRate parms[10] #define pResp parms[11] #define catabolismRate parms[12] #define dilutionRate parms[13] #define rNCProtein parms[14] #define inputDIN parms[15] #define rChlN parms[16] #define parMean parms[17] #define dayLength parms[18] static double forcs[1]; #define Light forcs[0] #define DIN y[0] #define PROTEIN y[1] #define RESERVE y[2] #define LMW y[3] #define dDIN ydot[0] #define dPROTEIN ydot[1] #define dRESERVE ydot[2] #define dLMW ydot[3] #define PAR out[0] #define TotalN out[1] #define PhotoSynthesis out[2] #define NCratio out[3] #define ChlCratio out[4] #define Chlorophyll out[5] /*======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= c Initialise parameter common block c======================================================================= */ void iniaqua(void (* odeparms)(int *, double *)) { int N=19; odeparms(&N, parms); } /* c======================================================================= c Initialise forcing function common block c======================================================================= */ void initaqforc(void (* odeforc)(int *, double *)) { int N=1; odeforc(&N, forcs); } /* c======================================================================= c Algal dynamics - light an on-off function c======================================================================= */ void aquaphy (int *neq, double *t, double *y, double *ydot, double *out, int *ip) { double PhytoC,PhytoN,PartLMW,Limfac,Exudation,MonodQuotum,hourofday, ProteinSynthesis,Storage,Respiration,Catabolism; if(ip[0] < 6) error("nout should at least be 6"); /* PAR, on-off function depending on the hour within a day*/ hourofday = fmod(*t,24.0); if (hourofday < dayLength) PAR = parMean; else PAR = 0.0; /* the output variables - all components contain carbon only proteins contain nitrogen */ PhytoC = PROTEIN + RESERVE + LMW; PhytoN = PROTEIN * rNCProtein; NCratio = PhytoN / PhytoC; Chlorophyll = PhytoN * rChlN; TotalN = PhytoN + DIN; ChlCratio = Chlorophyll / PhytoC; /* the rates, in mmol/hr */ PartLMW = LMW / PhytoC; Limfac = fmin(1.0,(maxpLMW -PartLMW)/(maxpLMW-minpLMW)); Limfac = fmax(0.0,Limfac); PhotoSynthesis = maxPhotoSynt*Limfac * (1.0-exp(alpha*PAR/maxPhotoSynt)) * PROTEIN; Exudation = pExudation * PhotoSynthesis; MonodQuotum = fmax(0.0,LMW / PROTEIN - minQuotum); ProteinSynthesis= maxProteinSynt*MonodQuotum * DIN / (DIN+ksDIN) * PROTEIN; Storage = maxStorage *MonodQuotum * PROTEIN; Respiration = respirationRate * LMW + pResp * ProteinSynthesis; Catabolism = catabolismRate * RESERVE; /* the rates of change of state variables; includes dilution effects (last term) */ dLMW = PhotoSynthesis + Catabolism - Exudation - Storage - Respiration - ProteinSynthesis - dilutionRate * LMW; dRESERVE = Storage - Catabolism - dilutionRate * RESERVE; dPROTEIN = ProteinSynthesis - dilutionRate * PROTEIN; dDIN = -ProteinSynthesis * rNCProtein - dilutionRate * (DIN - inputDIN); } /* Algal dynamics with forcings c======================================================================= */ void aquaphyforc (int *neq, double *t, double *y, double *ydot, double *out, int *ip) { double PhytoC,PhytoN,PartLMW,Limfac,Exudation,MonodQuotum, ProteinSynthesis,Storage,Respiration,Catabolism; if(ip[0] < 6) error("nout should at least be 6"); PAR = Light; /* the output variables - all components contain carbon only proteins contain nitrogen */ PhytoC = PROTEIN + RESERVE + LMW; PhytoN = PROTEIN * rNCProtein; NCratio = PhytoN / PhytoC; Chlorophyll = PhytoN * rChlN; TotalN = PhytoN + DIN; ChlCratio = Chlorophyll / PhytoC; /* the rates, in mmol/hr */ PartLMW = LMW / PhytoC; Limfac = fmin(1.0,(maxpLMW -PartLMW)/(maxpLMW-minpLMW)); Limfac = fmax(0.0,Limfac); PhotoSynthesis = maxPhotoSynt*Limfac * (1.0-exp(alpha*PAR/maxPhotoSynt)) * PROTEIN; Exudation = pExudation * PhotoSynthesis; MonodQuotum = fmax(0.0,LMW / PROTEIN - minQuotum); ProteinSynthesis= maxProteinSynt*MonodQuotum * DIN / (DIN+ksDIN) * PROTEIN; Storage = maxStorage *MonodQuotum * PROTEIN; Respiration = respirationRate * LMW + pResp * ProteinSynthesis; Catabolism = catabolismRate * RESERVE; /* the rates of change of state variables; includes dilution effects (last term) */ dLMW = PhotoSynthesis + Catabolism - Exudation - Storage - Respiration - ProteinSynthesis - dilutionRate * LMW; dRESERVE = Storage - Catabolism - dilutionRate * RESERVE; dPROTEIN = ProteinSynthesis - dilutionRate * PROTEIN; dDIN = -ProteinSynthesis * rNCProtein - dilutionRate * (DIN - inputDIN); } deSolve/src/brent.c0000644000176000001440000000643513136461013013756 0ustar ripleyusers/* brent's rootfinding method, based on R_Zeroin_2, itself based on NETLIB c/brent.shar */ /************************************************************************* * C math library * function ZEROIN - obtain a function zero within the given range * * Input * double zeroin(ax,bx,f,info,Tol,Maxit) * double ax; Root will be seeked for within * double bx; a range [ax,bx] * double (f)(double x, void *info); Name of the function whose zero * will be seeked for * double *rw; int *iw; Additional real and integer vector * double tol; Acceptable tolerance for the root * int maxit; Max. iterations * * * Output * Zeroin returns an estimate for the root with accuracy * 4*EPSILON*abs(x) + tol * * Algorithm * G.Forsythe, M.Malcolm, C.Moler, Computer methods for mathematical * computations. M., Mir, 1980, p.180 of the Russian edition ************************************************************************ */ #include #include #include #define EPSILON DBL_EPSILON double brent( /* An estimate of the root */ double ax, /* Left border | of the range */ double bx, /* Right border| the root is seeked*/ double fa, double fb, /* f(a), f(b) */ double f (double x, double *rw, int *iw), /* Function under investigation */ double *rw, int *iw, double tol, /* Acceptable tolerance */ int maxit) /* Max # of iterations */ { double a,b,c, fc; a = ax; b = bx; c = a; fc = fa; maxit = maxit + 1; /* First test if we have a root at an endpoint */ if(fa == 0.0) return a; if(fb == 0.0) return b; /* Main iteration loop */ while(maxit--) { double prev_step = b-a; double tol_act; /* Actual tolerance */ double p; /* Interpolation step in the form p/q; */ double q; double new_step; /* Step at this iteration */ if( fabs(fc) < fabs(fb) ){ /* Swap data for b to be the */ a = b; b = c; c = a; /* best approximation */ fa=fb; fb=fc; fc=fa; } tol_act = 2*EPSILON*fabs(b) + tol/2; new_step = (c-b)/2; if( fabs(new_step) <= tol_act || fb == (double)0 ) return b; /* Decide if the interpolation can be tried */ if( fabs(prev_step) >= tol_act && fabs(fa) > fabs(fb) ) { register double t1,cb,t2; cb = c-b; if( a == c ) { /* linear interpolation*/ t1 = fb/fa; p = cb*t1; q = 1.0 - t1; } else { /* Quadric inverse interpolation*/ q = fa/fc; t1 = fb/fc; t2 = fb/fa; p = t2 * ( cb*q*(q-t1) - (b-a)*(t1-1.0) ); q = (q-1.0) * (t1-1.0) * (t2-1.0); } if( p > (double)0 ) q = -q; else p = -p; if( p < (0.75*cb*q-fabs(tol_act*q)/2) && p < fabs(prev_step*q/2) ) new_step = p/q; } if( fabs(new_step) < tol_act) { /* Adjust step to be not less than tol*/ if( new_step > (double)0 ) new_step = tol_act; else new_step = -tol_act; } a = b; fa = fb; /* Save the previous approx. */ b += new_step; fb = f (b, rw, iw); if( (fb > 0 && fc > 0) || (fb < 0 && fc < 0) ) { c = a; fc = fa; /* Adjust c to have a sign opposite to that of b */ } } /* failed! */ return b; } deSolve/src/call_euler.c0000644000176000001440000001445313274246375014771 0ustar ripleyusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >=2 */ /* Euler Fixed Step Integrator */ /* (special version with less overhead than the general solution) */ /*==========================================================================*/ #include "rk_util.h" #include "externalptr.h" SEXP call_euler(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc, SEXP Parms, SEXP Nout, SEXP Rho, SEXP Verbose, SEXP Rpar, SEXP Ipar, SEXP Flist) { /* Initialization */ int nprot = 0; double *tt = NULL, *xs = NULL; double *tmp, *FF, *out; SEXP R_f, R_y0, R_yout; double *f, *y0, *yout; double t, dt; int i = 0, j=0, it=0, nt = 0, neq=0; int isForcing; /*------------------------------------------------------------------------*/ /* Processing of Arguments */ /*------------------------------------------------------------------------*/ PROTECT(Times = AS_NUMERIC(Times)); nprot++; tt = NUMERIC_POINTER(Times); nt = length(Times); PROTECT(Xstart = AS_NUMERIC(Xstart)); nprot++; xs = NUMERIC_POINTER(Xstart); neq = length(Xstart); tmp = (double *) R_alloc(neq, sizeof(double)); FF = (double *) R_alloc(neq, sizeof(double)); int nout = INTEGER(Nout)[0]; /* n of global outputs if func is in a DLL */ int verbose = INTEGER(Verbose)[0]; /*------------------------------------------------------------------------*/ /* timesteps (for advection computation in ReacTran) */ /*------------------------------------------------------------------------*/ for (i = 0; i < 2; i++) timesteps[i] = tt[1] - tt[0]; /*------------------------------------------------------------------------*/ /* DLL, ipar, rpar (for compatibility with lsoda) */ /*------------------------------------------------------------------------*/ int isDll = FALSE; int lrpar= 0, lipar = 0; int *ipar = NULL; if (inherits(Func, "NativeSymbol")) { /* function is a dll */ isDll = TRUE; if (nout > 0) isOut = TRUE; lrpar = nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ isDll = FALSE; isOut = FALSE; lipar = 3; /* in lsoda = 1; */ lrpar = nout; /* in lsoda = 1; */ } out = (double *) R_alloc(lrpar, sizeof(double)); ipar = (int *) R_alloc(lipar, sizeof(int)); ipar[0] = nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; if (isDll == 1) { /* other elements of ipar are set in R-function lsodx via argument *ipar* */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* out: first nout elements of out are reserved for output variables other elements are set via argument *rpar* */ for (j = 0; j < nout; j++) out[j] = 0.0; for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j]; } /*------------------------------------------------------------------------*/ /* Allocation of Workspace */ /*------------------------------------------------------------------------*/ PROTECT(R_y0 = allocVector(REALSXP, neq)); nprot++; PROTECT(R_f = allocVector(REALSXP, neq)); nprot++; y0 = REAL(R_y0); f = REAL(R_f); /* matrix for holding the outputs */ PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); nprot++; yout = REAL(R_yout); /* attribute that stores state information, similar to lsoda */ SEXP R_istate; int *istate; PROTECT(R_istate = allocVector(INTSXP, 22)); nprot++; istate = INTEGER(R_istate); istate[0] = 0; /* assume succesful return */ for (i = 0; i < 22; i++) istate[i] = 0; /*------------------------------------------------------------------------*/ /* Initialization of Parameters (for DLL functions) */ /*------------------------------------------------------------------------*/ if (Initfunc != NA_STRING) { if (inherits(Initfunc, "NativeSymbol")) { init_func_type *initializer; PROTECT(de_gparms = Parms); nprot++; initializer = (init_func_type *) R_ExternalPtrAddrFn_(Initfunc); initializer(Initdeparms); } } isForcing = initForcings(Flist); /*------------------------------------------------------------------------*/ /* Initialization of Integration Loop */ /*------------------------------------------------------------------------*/ yout[0] = tt[0]; /* initial time */ for (i = 0; i < neq; i++) { y0[i] = xs[i]; yout[(i + 1) * nt] = y0[i]; } /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ for (it = 0; it < nt - 1; it++) { t = tt[it]; dt = tt[it + 1] - t; timesteps[0] = timesteps[1]; timesteps[1] = dt; if (verbose) Rprintf("Time steps = %d / %d time = %e\n", it + 1, nt, t); derivs(Func, t, y0, Parms, Rho, f, out, 0, neq, ipar, isDll, isForcing); for (i = 0; i < neq; i++) { y0[i] = y0[i] + dt * f[i]; } /* store outputs */ if (it < nt) { yout[it + 1] = t + dt; for (i = 0; i < neq; i++) yout[it + 1 + nt * (1 + i)] = y0[i]; } } /* end of main loop */ /*------------------------------------------------------------------------*/ /* call derivs again to get global outputs */ /*------------------------------------------------------------------------*/ if(nout > 0) { for (int j = 0; j < nt; j++) { t = yout[j]; for (i = 0; i < neq; i++) tmp[i] = yout[j + nt * (1 + i)]; derivs(Func, t, tmp, Parms, Rho, FF, out, -1, neq, ipar, isDll, isForcing); for (i = 0; i < nout; i++) { yout[j + nt * (1 + neq + i)] = out[i]; } } } /* attach diagnostic information (codes are compatible to lsoda) */ setIstate(R_yout, R_istate, istate, it, 1, 0, 1, 0); timesteps[0] = 0; timesteps[1] = 0; UNPROTECT(nprot); return(R_yout); } deSolve/src/radau5.f0000644000176000001440000013357013572134421014035 0ustar ripleyusersC------------------------------------------------------------------------ C COPYRIGHT DISCLAIMER: C Copyright (c) 2004, Ernst Hairer C Redistribution and use in source and binary forms, with or without C modification, are permitted provided that the following conditions are C met: C - Redistributions of source code must retain the above copyright C notice, this list of conditions and the following disclaimer. C - Redistributions in binary form must reproduce the above copyright C notice, this list of conditions and the following disclaimer in the C documentation and/or other materials provided with the distribution. C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS **AS C IS** AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A C PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR C CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, C EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, C PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR C PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF C LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING C NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS C SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. C------------------------------------------------------------------------ C Adapted for use in R package deSolve by the deSolve authors. C C KS: write statements rewritten C Francesca Mazzia: small changes to avoid overflow SUBROUTINE RADAU5(N,FCN,X,Y,XEND,H, & RTOL,ATOL,ITOL, & JAC ,IJAC,MLJAC,MUJAC, & MAS ,IMAS,MLMAS,MUMAS, & SOLOUT,IOUT, & WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID) C ---------------------------------------------------------- C NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC) C SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS C M*Y'=F(X,Y). C THE SYSTEM CAN BE (LINEARLY) IMPLICIT (MASS-MATRIX M .NE. I) C OR EXPLICIT (M=I). C THE METHOD USED IS AN IMPLICIT RUNGE-KUTTA METHOD (RADAU IIA) C OF ORDER 5 WITH STEP SIZE CONTROL AND CONTINUOUS OUTPUT. C CF. SECTION IV.8 C C AUTHORS: E. HAIRER AND G. WANNER C UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES C CH-1211 GENEVE 24, SWITZERLAND C E-MAIL: Ernst.Hairer@math.unige.ch C Gerhard.Wanner@math.unige.ch C C THIS CODE IS PART OF THE BOOK: C E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL C EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. C SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS 14, C SPRINGER-VERLAG 1991, SECOND EDITION 1996. C C VERSION OF JULY 9, 1996 C (latest small correction: January 18, 2002) C C INPUT PARAMETERS C ---------------- C N DIMENSION OF THE SYSTEM C C FCN NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE C VALUE OF F(X,Y): C SUBROUTINE FCN(N,X,Y,F,RPAR,IPAR) C DOUBLE PRECISION X,Y(N),F(N) C F(1)=... ETC. C RPAR, IPAR (SEE BELOW) C C X INITIAL X-VALUE C C Y(N) INITIAL VALUES FOR Y C C XEND FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE) C C H INITIAL STEP SIZE GUESS; C FOR STIFF EQUATIONS WITH INITIAL TRANSIENT, C H=1.D0/(NORM OF F'), USUALLY 1.D-3 OR 1.D-5, IS GOOD. C THIS CHOICE IS NOT VERY IMPORTANT, THE STEP SIZE IS C QUICKLY ADAPTED. (IF H=0.D0, THE CODE PUTS H=1.D-6). C C RTOL,ATOL RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY C CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N. C C ITOL SWITCH FOR RTOL AND ATOL: C ITOL=0: BOTH RTOL AND ATOL ARE SCALARS. C THE CODE KEEPS, ROUGHLY, THE LOCAL ERROR OF C Y(I) BELOW RTOL*ABS(Y(I))+ATOL C ITOL=1: BOTH RTOL AND ATOL ARE VECTORS. C THE CODE KEEPS THE LOCAL ERROR OF Y(I) BELOW C RTOL(I)*ABS(Y(I))+ATOL(I). C C JAC NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES C THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO Y C (THIS ROUTINE IS ONLY CALLED IF IJAC=1; SUPPLY C A DUMMY SUBROUTINE IN THE CASE IJAC=0). C FOR IJAC=1, THIS SUBROUTINE MUST HAVE THE FORM C SUBROUTINE JAC(N,X,Y,DFY,LDFY,RPAR,IPAR) C DOUBLE PRECISION X,Y(N),DFY(LDFY,N) C DFY(1,1)= ... C LDFY, THE COLUMN-LENGTH OF THE ARRAY, IS C FURNISHED BY THE CALLING PROGRAM. C IF (MLJAC.EQ.N) THE JACOBIAN IS SUPPOSED TO C BE FULL AND THE PARTIAL DERIVATIVES ARE C STORED IN DFY AS C DFY(I,J) = PARTIAL F(I) / PARTIAL Y(J) C ELSE, THE JACOBIAN IS TAKEN AS BANDED AND C THE PARTIAL DERIVATIVES ARE STORED C DIAGONAL-WISE AS C DFY(I-J+MUJAC+1,J) = PARTIAL F(I) / PARTIAL Y(J). C C IJAC SWITCH FOR THE COMPUTATION OF THE JACOBIAN: C IJAC=0: JACOBIAN IS COMPUTED INTERNALLY BY FINITE C DIFFERENCES, SUBROUTINE "JAC" IS NEVER CALLED. C IJAC=1: JACOBIAN IS SUPPLIED BY SUBROUTINE JAC. C C MLJAC SWITCH FOR THE BANDED STRUCTURE OF THE JACOBIAN: C MLJAC=N: JACOBIAN IS A FULL MATRIX. THE LINEAR C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. C 0<=MLJAC= NUMBER OF NON-ZERO DIAGONALS BELOW C THE MAIN DIAGONAL). C C MUJAC UPPER BANDWITH OF JACOBIAN MATRIX (>= NUMBER OF NON- C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). C NEED NOT BE DEFINED IF MLJAC=N. C C ---- MAS,IMAS,MLMAS, AND MUMAS HAVE ANALOG MEANINGS ----- C ---- FOR THE "MASS MATRIX" (THE MATRIX "M" OF SECTION IV.8): - C C MAS NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE MASS- C MATRIX M. C IF IMAS=0, THIS MATRIX IS ASSUMED TO BE THE IDENTITY C MATRIX AND NEEDS NOT TO BE DEFINED; C SUPPLY A DUMMY SUBROUTINE IN THIS CASE. C IF IMAS=1, THE SUBROUTINE MAS IS OF THE FORM C SUBROUTINE MAS(N,AM,LMAS,RPAR,IPAR) C DOUBLE PRECISION AM(LMAS,N) C AM(1,1)= .... C IF (MLMAS.EQ.N) THE MASS-MATRIX IS STORED C AS FULL MATRIX LIKE C AM(I,J) = M(I,J) C ELSE, THE MATRIX IS TAKEN AS BANDED AND STORED C DIAGONAL-WISE AS C AM(I-J+MUMAS+1,J) = M(I,J). C C IMAS GIVES INFORMATION ON THE MASS-MATRIX: C IMAS=0: M IS SUPPOSED TO BE THE IDENTITY C MATRIX, MAS IS NEVER CALLED. C IMAS=1: MASS-MATRIX IS SUPPLIED. C C MLMAS SWITCH FOR THE BANDED STRUCTURE OF THE MASS-MATRIX: C MLMAS=N: THE FULL MATRIX CASE. THE LINEAR C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. C 0<=MLMAS= NUMBER OF NON-ZERO DIAGONALS BELOW C THE MAIN DIAGONAL). C MLMAS IS SUPPOSED TO BE .LE. MLJAC. C C MUMAS UPPER BANDWITH OF MASS-MATRIX (>= NUMBER OF NON- C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). C NEED NOT BE DEFINED IF MLMAS=N. C MUMAS IS SUPPOSED TO BE .LE. MUJAC. C C SOLOUT NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE C NUMERICAL SOLUTION DURING INTEGRATION. C IF IOUT=1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP. C SUPPLY A DUMMY SUBROUTINE IF IOUT=0. C IT MUST HAVE THE FORM C SUBROUTINE SOLOUT (NR,XOLD,X,Y,CONT,LRC,N, C RPAR,IPAR,IRTRN) C DOUBLE PRECISION X,Y(N),CONT(LRC) C .... C SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH C GRID-POINT "X" (THEREBY THE INITIAL VALUE IS C THE FIRST GRID-POINT). C "XOLD" IS THE PRECEEDING GRID-POINT. C "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN C IS SET <0, RADAU5 RETURNS TO THE CALLING PROGRAM. C C ----- CONTINUOUS OUTPUT: ----- C DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION C FOR THE INTERVAL [XOLD,X] IS AVAILABLE THROUGH C THE FUNCTION C >>> CONTR5(I,S,CONT,LRC) <<< C WHICH PROVIDES AN APPROXIMATION TO THE I-TH C COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE C S SHOULD LIE IN THE INTERVAL [XOLD,X]. C DO NOT CHANGE THE ENTRIES OF CONT(LRC), IF THE C DENSE OUTPUT FUNCTION IS USED. C C IOUT SWITCH FOR CALLING THE SUBROUTINE SOLOUT: C IOUT=0: SUBROUTINE IS NEVER CALLED C IOUT=1: SUBROUTINE IS AVAILABLE FOR OUTPUT. C C WORK ARRAY OF WORKING SPACE OF LENGTH "LWORK". C WORK(1), WORK(2),.., WORK(20) SERVE AS PARAMETERS C FOR THE CODE. FOR STANDARD USE OF THE CODE C WORK(1),..,WORK(20) MUST BE SET TO ZERO BEFORE C CALLING. SEE BELOW FOR A MORE SOPHISTICATED USE. C WORK(21),..,WORK(LWORK) SERVE AS WORKING SPACE C FOR ALL VECTORS AND MATRICES. C "LWORK" MUST BE AT LEAST C N*(LJAC+LMAS+3*LE+12)+20 C WHERE C LJAC=N IF MLJAC=N (FULL JACOBIAN) C LJAC=MLJAC+MUJAC+1 IF MLJAC0 THEN "LWORK" MUST BE AT LEAST C N*(LJAC+12)+(N-M1)*(LMAS+3*LE)+20 C WHERE IN THE DEFINITIONS OF LJAC, LMAS AND LE THE C NUMBER N CAN BE REPLACED BY N-M1. C C LWORK DECLARED LENGTH OF ARRAY "WORK". C C IWORK INTEGER WORKING SPACE OF LENGTH "LIWORK". C IWORK(1),IWORK(2),...,IWORK(20) SERVE AS PARAMETERS C FOR THE CODE. FOR STANDARD USE, SET IWORK(1),.., C IWORK(20) TO ZERO BEFORE CALLING. C IWORK(21),...,IWORK(LIWORK) SERVE AS WORKING AREA. C "LIWORK" MUST BE AT LEAST 3*N+20. C C LIWORK DECLARED LENGTH OF ARRAY "IWORK". C C RPAR, IPAR REAL AND INTEGER PARAMETERS (OR PARAMETER ARRAYS) WHICH C CAN BE USED FOR COMMUNICATION BETWEEN YOUR CALLING C PROGRAM AND THE FCN, JAC, MAS, SOLOUT SUBROUTINES. C C ---------------------------------------------------------------------- C C SOPHISTICATED SETTING OF PARAMETERS C ----------------------------------- C SEVERAL PARAMETERS OF THE CODE ARE TUNED TO MAKE IT WORK C WELL. THEY MAY BE DEFINED BY SETTING WORK(1),... C AS WELL AS IWORK(1),... DIFFERENT FROM ZERO. C FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES: C C IWORK(1) IF IWORK(1).NE.0, THE CODE TRANSFORMS THE JACOBIAN C MATRIX TO HESSENBERG FORM. THIS IS PARTICULARLY C ADVANTAGEOUS FOR LARGE SYSTEMS WITH FULL JACOBIAN. C IT DOES NOT WORK FOR BANDED JACOBIAN (MLJAC 1. C THE FUNCTION-SUBROUTINE SHOULD BE WRITTEN SUCH THAT C THE INDEX 1,2,3 VARIABLES APPEAR IN THIS ORDER. C IN ESTIMATING THE ERROR THE INDEX 2 VARIABLES ARE C MULTIPLIED BY H, THE INDEX 3 VARIABLES BY H**2. C C IWORK(5) DIMENSION OF THE INDEX 1 VARIABLES (MUST BE > 0). FOR C ODE'S THIS EQUALS THE DIMENSION OF THE SYSTEM. C DEFAULT IWORK(5)=N. C C IWORK(6) DIMENSION OF THE INDEX 2 VARIABLES. DEFAULT IWORK(6)=0. C C IWORK(7) DIMENSION OF THE INDEX 3 VARIABLES. DEFAULT IWORK(7)=0. C C IWORK(8) SWITCH FOR STEP SIZE STRATEGY C IF IWORK(8).EQ.1 MOD. PREDICTIVE CONTROLLER (GUSTAFSSON) C IF IWORK(8).EQ.2 CLASSICAL STEP SIZE CONTROL C THE DEFAULT VALUE (FOR IWORK(8)=0) IS IWORK(8)=1. C THE CHOICE IWORK(8).EQ.1 SEEMS TO PRODUCE SAFER RESULTS; C FOR SIMPLE PROBLEMS, THE CHOICE IWORK(8).EQ.2 PRODUCES C OFTEN SLIGHTLY FASTER RUNS C C IF THE DIFFERENTIAL SYSTEM HAS THE SPECIAL STRUCTURE THAT C Y(I)' = Y(I+M2) FOR I=1,...,M1, C WITH M1 A MULTIPLE OF M2, A SUBSTANTIAL GAIN IN COMPUTERTIME C CAN BE ACHIEVED BY SETTING THE PARAMETERS IWORK(9) AND IWORK(10). C E.G., FOR SECOND ORDER SYSTEMS P'=V, V'=G(P,V), WHERE P AND V ARE C VECTORS OF DIMENSION N/2, ONE HAS TO PUT M1=M2=N/2. C FOR M1>0 SOME OF THE INPUT PARAMETERS HAVE DIFFERENT MEANINGS: C - JAC: ONLY THE ELEMENTS OF THE NON-TRIVIAL PART OF THE C JACOBIAN HAVE TO BE STORED C IF (MLJAC.EQ.N-M1) THE JACOBIAN IS SUPPOSED TO BE FULL C DFY(I,J) = PARTIAL F(I+M1) / PARTIAL Y(J) C FOR I=1,N-M1 AND J=1,N. C ELSE, THE JACOBIAN IS BANDED ( M1 = M2 * MM ) C DFY(I-J+MUJAC+1,J+K*M2) = PARTIAL F(I+M1) / PARTIAL Y(J+K*M2) C FOR I=1,MLJAC+MUJAC+1 AND J=1,M2 AND K=0,MM. C - MLJAC: MLJAC=N-M1: IF THE NON-TRIVIAL PART OF THE JACOBIAN IS FULL C 0<=MLJAC1.0D0 IF (WORK(1).EQ.0.0D0) THEN UROUND=1.0D-16 ELSE UROUND=WORK(1) IF (UROUND.LE.1.0D-19.OR.UROUND.GE.1.0D0) THEN CALL rprintfd1( & ' COEFFICIENTS HAVE 20 DIGITS, UROUND= %g'//char(0), WORK(1)) ARRET=.TRUE. END IF END IF C -------- CHECK AND CHANGE THE TOLERANCES EXPM=2.0D0/3.0D0 IF (ITOL.EQ.0) THEN IF (ATOL(1).LE.0.D0.OR.RTOL(1).LE.10.D0*UROUND) THEN CALL rprintf( ' TOLERANCES ARE TOO SMALL'//char(0)) ARRET=.TRUE. ELSE QUOT=ATOL(1)/RTOL(1) RTOL(1)=0.1D0*RTOL(1)**EXPM ATOL(1)=RTOL(1)*QUOT END IF ELSE DO I=1,N IF (ATOL(I).LE.0.D0.OR.RTOL(I).LE.10.D0*UROUND) THEN CALL rprintfi1( ' TOLERANCES (%i) ARE TOO SMALL' & //char(0), I) ARRET=.TRUE. ELSE QUOT=ATOL(I)/RTOL(I) RTOL(I)=0.1D0*RTOL(I)**EXPM ATOL(I)=RTOL(I)*QUOT END IF END DO END IF C -------- NMAX , THE MAXIMAL NUMBER OF STEPS ----- IF (IWORK(2).EQ.0) THEN NMAX=100000 ELSE NMAX=IWORK(2) IF (NMAX.LE.0) THEN CALL rprintfi1(' WRONG INPUT IWORK(2)= %i' & // char(0), IWORK(2)) ARRET=.TRUE. END IF END IF C -------- NIT MAXIMAL NUMBER OF NEWTON ITERATIONS IF (IWORK(3).EQ.0) THEN NIT=7 ELSE NIT=IWORK(3) IF (NIT.LE.0) THEN CALL rprintfi1(' CURIOUS INPUT IWORK(3)= %i' & // char(0), IWORK(3)) ARRET=.TRUE. END IF END IF C -------- STARTN SWITCH FOR STARTING VALUES OF NEWTON ITERATIONS IF(IWORK(4).EQ.0)THEN STARTN=.FALSE. ELSE STARTN=.TRUE. END IF C -------- PARAMETER FOR DIFFERENTIAL-ALGEBRAIC COMPONENTS NIND1=IWORK(5) NIND2=IWORK(6) NIND3=IWORK(7) IF (NIND1.EQ.0) NIND1=N IF (NIND1+NIND2+NIND3.NE.N) THEN call rprintfi3( &' CURIOUS INPUT FOR IWORK(5,6,7)= %i, %i, %i' //char(0), & NIND1, NIND2, NIND3) ARRET=.TRUE. END IF C -------- PRED STEP SIZE CONTROL IF(IWORK(8).LE.1)THEN PRED=.TRUE. ELSE PRED=.FALSE. END IF C -------- PARAMETER FOR SECOND ORDER EQUATIONS M1=IWORK(9) M2=IWORK(10) NM1=N-M1 IF (M1.EQ.0) M2=N IF (M2.EQ.0) M2=M1 IF (M1.LT.0.OR.M2.LT.0.OR.M1+M2.GT.N) THEN CALL rprintfi2(' CURIOUS INPUT FOR IWORK(9,10)= %i, %i' & // char(0), M1, M2) ARRET=.TRUE. END IF C --------- SAFE SAFETY FACTOR IN STEP SIZE PREDICTION IF (WORK(2).EQ.0.0D0) THEN SAFE=0.9D0 ELSE SAFE=WORK(2) IF (SAFE.LE.0.001D0.OR.SAFE.GE.1.0D0) THEN Call rprintfd1(' CURIOUS INPUT FOR WORK(2)= %g' & // char(0), WORK(2)) ARRET=.TRUE. END IF END IF C ------ THET DECIDES WHETHER THE JACOBIAN SHOULD BE RECOMPUTED; IF (WORK(3).EQ.0.D0) THEN THET=0.001D0 ELSE THET=WORK(3) IF (THET.GE.1.0D0) THEN Call rprintfd1(' CURIOUS INPUT FOR WORK(3)= %g' & // char(0), WORK(3)) ARRET=.TRUE. END IF END IF C --- FNEWT STOPPING CRITERION FOR NEWTON'S METHOD, USUALLY CHOSEN <1. TOLST=RTOL(1) IF (WORK(4).EQ.0.D0) THEN FNEWT=MAX(10*UROUND/TOLST,MIN(0.03D0,TOLST**0.5D0)) ELSE FNEWT=WORK(4) IF (FNEWT.LE.UROUND/TOLST) THEN Call rprintfd1(' CURIOUS INPUT FOR WORK(4)= %g' & // char(0), WORK(4)) ARRET=.TRUE. END IF END IF C --- QUOT1 AND QUOT2: IF QUOT1 < HNEW/HOLD < QUOT2, STEP SIZE = CONST. IF (WORK(5).EQ.0.D0) THEN QUOT1=1.D0 ELSE QUOT1=WORK(5) END IF IF (WORK(6).EQ.0.D0) THEN QUOT2=1.2D0 ELSE QUOT2=WORK(6) END IF IF (QUOT1.GT.1.0D0.OR.QUOT2.LT.1.0D0) THEN CALL rprintfd2(' CURIOUS INPUT FOR WORK(5,6)= %g, %g' & // char(0), QUOT1, QUOT2) ARRET=.TRUE. END IF C -------- MAXIMAL STEP SIZE IF (WORK(7).EQ.0.D0) THEN HMAX=XEND-X ELSE HMAX=WORK(7) END IF C ------- FACL,FACR PARAMETERS FOR STEP SIZE SELECTION IF(WORK(8).EQ.0.D0)THEN FACL=5.D0 ELSE FACL=1.D0/WORK(8) END IF IF(WORK(9).EQ.0.D0)THEN FACR=1.D0/8.0D0 ELSE FACR=1.D0/WORK(9) END IF IF (FACL.LT.1.0D0.OR.FACR.GT.1.0D0) THEN CALL rprintfd2(' CURIOUS INPUT WORK(8,9)= %g, %g' & // char(0), WORK(8), WORK(9)) ARRET=.TRUE. END IF C *** *** *** *** *** *** *** *** *** *** *** *** *** C COMPUTATION OF ARRAY ENTRIES C *** *** *** *** *** *** *** *** *** *** *** *** *** C ---- IMPLICIT, BANDED OR NOT ? IMPLCT=IMAS.NE.0 JBAND=MLJAC.LT.NM1 C -------- COMPUTATION OF THE ROW-DIMENSIONS OF THE 2-ARRAYS --- C -- JACOBIAN AND MATRICES E1, E2 IF (JBAND) THEN LDJAC=MLJAC+MUJAC+1 LDE1=MLJAC+LDJAC ELSE MLJAC=NM1 MUJAC=NM1 LDJAC=NM1 LDE1=NM1 END IF C -- MASS MATRIX IF (IMPLCT) THEN IF (MLMAS.NE.NM1) THEN LDMAS=MLMAS+MUMAS+1 IF (JBAND) THEN IJOB=4 ELSE IJOB=3 END IF ELSE MUMAS=NM1 LDMAS=NM1 IJOB=5 END IF C ------ BANDWITH OF "MAS" NOT SMALLER THAN BANDWITH OF "JAC" IF (MLMAS.GT.MLJAC.OR.MUMAS.GT.MUJAC) THEN CALL rprintf( & 'BANDWITH OF "MAS" NOT SMALLER THAN BANDWITH OF "JAC"' & // char(0)) ARRET=.TRUE. END IF ELSE LDMAS=0 IF (JBAND) THEN IJOB=2 ELSE IJOB=1 IF (N.GT.2.AND.IWORK(1).NE.0) IJOB=7 END IF END IF LDMAS2=MAX(1,LDMAS) C ------ HESSENBERG OPTION ONLY FOR EXPLICIT EQU. WITH FULL JACOBIAN IF ((IMPLCT.OR.JBAND).AND.IJOB.EQ.7) THEN CALL rprintf( &' HESSENBERG OPTION ONLY FOR EXPLICIT EQUATIONS & WITH FULL JACOBIAN' // char(0)) ARRET=.TRUE. END IF C ------- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK ----- IEZ1=21 IEZ2=IEZ1+N IEZ3=IEZ2+N IEY0=IEZ3+N IESCAL=IEY0+N IEF1=IESCAL+N IEF2=IEF1+N IEF3=IEF2+N IECON=IEF3+N IEJAC=IECON+4*N IEMAS=IEJAC+N*LDJAC IEE1=IEMAS+NM1*LDMAS IEE2R=IEE1+NM1*LDE1 IEE2I=IEE2R+NM1*LDE1 C ------ TOTAL STORAGE REQUIREMENT ----------- ISTORE=IEE2I+NM1*LDE1-1 IF(ISTORE.GT.LWORK)THEN CALL rprintfi1( & ' INSUFFICIENT STORAGE FOR WORK, MIN. LWORK= %i' & // char(0), ISTORE) ARRET=.TRUE. END IF C ------- ENTRY POINTS FOR INTEGER WORKSPACE ----- IEIP1=21 IEIP2=IEIP1+NM1 IEIPH=IEIP2+NM1 C --------- TOTAL REQUIREMENT --------------- ISTORE=IEIPH+NM1-1 IF (ISTORE.GT.LIWORK) THEN CALL rprintfi1( & ' INSUFF. STORAGE FOR IWORK, MIN. LIWORK= %i' & // char(0), ISTORE) ARRET=.TRUE. END IF C ------ WHEN A FAIL HAS OCCURED, WE RETURN WITH IDID=-1 IF (ARRET) THEN IDID=-1 RETURN END IF C -------- CALL TO CORE INTEGRATOR ------------ CALL RADCOR(N,FCN,X,Y,XEND,HMAX,H,RTOL,ATOL,ITOL, & JAC,IJAC,MLJAC,MUJAC,MAS,MLMAS,MUMAS,SOLOUT,IOUT,IDID, & NMAX,UROUND,SAFE,THET,FNEWT,QUOT1,QUOT2,NIT,IJOB,STARTN, & NIND1,NIND2,NIND3,PRED,FACL,FACR,M1,M2,NM1, & IMPLCT,JBAND,LDJAC,LDE1,LDMAS2,WORK(IEZ1),WORK(IEZ2), & WORK(IEZ3),WORK(IEY0),WORK(IESCAL),WORK(IEF1),WORK(IEF2), & WORK(IEF3),WORK(IEJAC),WORK(IEE1),WORK(IEE2R),WORK(IEE2I), & WORK(IEMAS),IWORK(IEIP1),IWORK(IEIP2),IWORK(IEIPH), & WORK(IECON),NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL,RPAR,IPAR) IWORK(14)=NFCN IWORK(15)=NJAC IWORK(16)=NSTEP IWORK(17)=NACCPT IWORK(18)=NREJCT IWORK(19)=NDEC IWORK(20)=NSOL C -------- RESTORE TOLERANCES EXPM=1.0D0/EXPM IF (ITOL.EQ.0) THEN QUOT=ATOL(1)/RTOL(1) RTOL(1)=(10.0D0*RTOL(1))**EXPM ATOL(1)=RTOL(1)*QUOT ELSE DO I=1,N QUOT=ATOL(I)/RTOL(I) RTOL(I)=(10.0D0*RTOL(I))**EXPM ATOL(I)=RTOL(I)*QUOT END DO END IF C ----------- RETURN ----------- RETURN END C C END OF SUBROUTINE RADAU5 C C *********************************************************** C SUBROUTINE RADCOR(N,FCN,X,Y,XEND,HMAX,H,RTOL,ATOL,ITOL, & JAC,IJAC,MLJAC,MUJAC,MAS,MLMAS,MUMAS,SOLOUT,IOUT,IDID, & NMAX,UROUND,SAFE,THET,FNEWT,QUOT1,QUOT2,NIT,IJOB,STARTN, & NIND1,NIND2,NIND3,PRED,FACL,FACR,M1,M2,NM1, & IMPLCT,BANDED,LDJAC,LDE1,LDMAS,Z1,Z2,Z3, & Y0,SCAL,F1,F2,F3,FJAC,E1,E2R,E2I,FMAS,IP1,IP2,IPHES, & CONT,NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL,RPAR,IPAR) C ---------------------------------------------------------- C CORE INTEGRATOR FOR RADAU5 C PARAMETERS SAME AS IN RADAU5 WITH WORKSPACE ADDED C ---------------------------------------------------------- C DECLARATIONS C ---------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION Y(N),Z1(N),Z2(N),Z3(N),Y0(N),SCAL(N),F1(N),F2(N),F3(N) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1),CONT(4*N) DIMENSION E1(LDE1,NM1),E2R(LDE1,NM1),E2I(LDE1,NM1) DIMENSION ATOL(*),RTOL(*),RPAR(*),IPAR(*) INTEGER IP1(NM1),IP2(NM1),IPHES(NM1) COMMON /CONRA5/NN,NN2,NN3,NN4,XSOL,HSOL,C2M1,C1M1 COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG LOGICAL REJECT,FIRST,IMPLCT,BANDED,CALJAC,STARTN,CALHES LOGICAL INDEX1,INDEX2,INDEX3,LAST,PRED EXTERNAL FCN C *** *** *** *** *** *** *** C INITIALISATIONS C *** *** *** *** *** *** *** C --------- DUPLIFY N FOR COMMON BLOCK CONT ----- C KARLINE: INITIALISE THQOLD ande HACC to avoid warnings - should have no effect THQOLD = 1.D0 HACC = 1.D0 ERRACC = 1.D0 DYNOLD = 1.D0 NN=N NN2=2*N NN3=3*N LRC=4*N C -------- CHECK THE INDEX OF THE PROBLEM ----- INDEX1=NIND1.NE.0 INDEX2=NIND2.NE.0 INDEX3=NIND3.NE.0 C ------- COMPUTE MASS MATRIX FOR IMPLICIT CASE ---------- IF (IMPLCT) CALL MAS(NM1,FMAS,LDMAS,RPAR,IPAR) C ---------- CONSTANTS --------- SQ6=DSQRT(6.D0) C1=(4.D0-SQ6)/10.D0 C2=(4.D0+SQ6)/10.D0 C1M1=C1-1.D0 C2M1=C2-1.D0 C1MC2=C1-C2 DD1=-(13.D0+7.D0*SQ6)/3.D0 DD2=(-13.D0+7.D0*SQ6)/3.D0 DD3=-1.D0/3.D0 U1=(6.D0+81.D0**(1.D0/3.D0)-9.D0**(1.D0/3.D0))/30.D0 ALPH=(12.D0-81.D0**(1.D0/3.D0)+9.D0**(1.D0/3.D0))/60.D0 BETA=(81.D0**(1.D0/3.D0)+9.D0**(1.D0/3.D0))*DSQRT(3.D0)/60.D0 CNO=ALPH**2+BETA**2 U1=1.0D0/U1 ALPH=ALPH/CNO BETA=BETA/CNO T11=9.1232394870892942792D-02 T12=-0.14125529502095420843D0 T13=-3.0029194105147424492D-02 T21=0.24171793270710701896D0 T22=0.20412935229379993199D0 T23=0.38294211275726193779D0 T31=0.96604818261509293619D0 TI11=4.3255798900631553510D0 TI12=0.33919925181580986954D0 TI13=0.54177053993587487119D0 TI21=-4.1787185915519047273D0 TI22=-0.32768282076106238708D0 TI23=0.47662355450055045196D0 TI31=-0.50287263494578687595D0 TI32=2.5719269498556054292D0 TI33=-0.59603920482822492497D0 IF (M1.GT.0) IJOB=IJOB+10 POSNEG=SIGN(1.D0,XEND-X) HMAXN=MIN(ABS(HMAX),ABS(XEND-X)) IF (ABS(H).LE.10.D0*UROUND) H=1.0D-6 H=MIN(ABS(H),HMAXN) H=SIGN(H,POSNEG) HOLD=H REJECT=.FALSE. FIRST=.TRUE. LAST=.FALSE. IF ((X+H*1.0001D0-XEND)*POSNEG.GE.0.D0) THEN H=XEND-X LAST=.TRUE. END IF HOPT=H FACCON=1.D0 CFAC=SAFE*(1+2*NIT) NSING=0 XOLD=X IF (IOUT.NE.0) THEN IRTRN=1 NRSOL=1 XOSOL=XOLD XSOL=X DO I=1,N CONT(I)=Y(I) END DO NSOLU=N HSOL=HOLD CALL SOLOUT(NRSOL,XOSOL,XSOL,Y,CONT,LRC,NSOLU, & RPAR,IPAR,IRTRN) IF (IRTRN.LT.0) GOTO 179 END IF MLE=MLJAC MUE=MUJAC MBJAC=MLJAC+MUJAC+1 MBB=MLMAS+MUMAS+1 MDIAG=MLE+MUE+1 MDIFF=MLE+MUE-MUMAS MBDIAG=MUMAS+1 N2=2*N N3=3*N IF (ITOL.EQ.0) THEN DO I=1,N SCAL(I)=ATOL(1)+RTOL(1)*ABS(Y(I)) END DO ELSE DO I=1,N SCAL(I)=ATOL(I)+RTOL(I)*ABS(Y(I)) END DO END IF HHFAC=H CALL FCN(N,X,Y,Y0,RPAR,IPAR) NFCN=NFCN+1 C --- BASIC INTEGRATION STEP 10 CONTINUE C *** *** *** *** *** *** *** C COMPUTATION OF THE JACOBIAN C *** *** *** *** *** *** *** NJAC=NJAC+1 IF (IJAC.EQ.0) THEN C --- COMPUTE JACOBIAN MATRIX NUMERICALLY IF (BANDED) THEN C --- JACOBIAN IS BANDED MUJACP=MUJAC+1 MD=MIN(MBJAC,M2) DO MM=1,M1/M2+1 DO K=1,MD J=K+(MM-1)*M2 12 F1(J)=Y(J) F2(J)=DSQRT(UROUND*MAX(1.D-5,ABS(Y(J)))) Y(J)=Y(J)+F2(J) J=J+MD IF (J.LE.MM*M2) GOTO 12 CALL FCN(N,X,Y,CONT,RPAR,IPAR) J=K+(MM-1)*M2 J1=K LBEG=MAX(1,J1-MUJAC)+M1 14 LEND=MIN(M2,J1+MLJAC)+M1 Y(J)=F1(J) MUJACJ=MUJACP-J1-M1 DO L=LBEG,LEND FJAC(L+MUJACJ,J)=(CONT(L)-Y0(L))/F2(J) END DO J=J+MD J1=J1+MD LBEG=LEND+1 IF (J.LE.MM*M2) GOTO 14 END DO NFCN=NFCN+MD END DO ELSE C --- JACOBIAN IS FULL DO I=1,N YSAFE=Y(I) DELT=DSQRT(UROUND*MAX(1.D-5,ABS(YSAFE))) Y(I)=YSAFE+DELT CALL FCN(N,X,Y,CONT,RPAR,IPAR) DO J=M1+1,N FJAC(J-M1,I)=(CONT(J)-Y0(J))/DELT END DO Y(I)=YSAFE END DO NFCN=NFCN+N END IF ELSE C --- COMPUTE JACOBIAN MATRIX ANALYTICALLY CALL JAC(N,X,Y,MLJAC,MUJAC,FJAC,LDJAC,RPAR,IPAR) END IF CALJAC=.TRUE. CALHES=.TRUE. 20 CONTINUE C --- COMPUTE THE MATRICES E1 AND E2 AND THEIR DECOMPOSITIONS FAC1=U1/H ALPHN=ALPH/H BETAN=BETA/H CALL DECOMR(N,FJAC,LDJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,FAC1,E1,LDE1,IP1,IER,IJOB,CALHES,IPHES) IF (IER.NE.0) GOTO 78 CALL DECOMC(N,FJAC,LDJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,ALPHN,BETAN,E2R,E2I,LDE1,IP2,IER,IJOB) IF (IER.NE.0) GOTO 78 NDEC=NDEC+1 30 CONTINUE NSTEP=NSTEP+1 IF (NSTEP.GT.NMAX) GOTO 178 IF (0.1D0*ABS(H).LE.ABS(X)*UROUND) GOTO 177 IF (INDEX2) THEN DO I=NIND1+1,NIND1+NIND2 SCAL(I)=SCAL(I)/HHFAC END DO END IF IF (INDEX3) THEN DO I=NIND1+NIND2+1,NIND1+NIND2+NIND3 SCAL(I)=SCAL(I)/(HHFAC*HHFAC) END DO END IF XPH=X+H C *** *** *** *** *** *** *** C STARTING VALUES FOR NEWTON ITERATION C *** *** *** *** *** *** *** IF (FIRST.OR.STARTN) THEN DO I=1,N Z1(I)=0.D0 Z2(I)=0.D0 Z3(I)=0.D0 F1(I)=0.D0 F2(I)=0.D0 F3(I)=0.D0 END DO ELSE C3Q=H/HOLD C1Q=C1*C3Q C2Q=C2*C3Q DO I=1,N AK1=CONT(I+N) AK2=CONT(I+N2) AK3=CONT(I+N3) Z1I=C1Q*(AK1+(C1Q-C2M1)*(AK2+(C1Q-C1M1)*AK3)) Z2I=C2Q*(AK1+(C2Q-C2M1)*(AK2+(C2Q-C1M1)*AK3)) Z3I=C3Q*(AK1+(C3Q-C2M1)*(AK2+(C3Q-C1M1)*AK3)) Z1(I)=Z1I Z2(I)=Z2I Z3(I)=Z3I F1(I)=TI11*Z1I+TI12*Z2I+TI13*Z3I F2(I)=TI21*Z1I+TI22*Z2I+TI23*Z3I F3(I)=TI31*Z1I+TI32*Z2I+TI33*Z3I END DO END IF C *** *** *** *** *** *** *** C LOOP FOR THE SIMPLIFIED NEWTON ITERATION C *** *** *** *** *** *** *** NEWT=0 C--- December, 2011 FRANCESCA MAZZIA added this line to avoid owerflow DYNO = 1.0d0 FACCON=MAX(FACCON,UROUND)**0.8D0 THETA=ABS(THET) 40 CONTINUE IF (NEWT.GE.NIT) GOTO 78 C--- December, 2011 FRANCESCA MAZZIA added this line to avoid owerflow IF ( .NOT. (DYNO .GT. 0.0d0) ) GOTO 78 C --- COMPUTE THE RIGHT-HAND SIDE DO I=1,N CONT(I)=Y(I)+Z1(I) END DO CALL FCN(N,X+C1*H,CONT,Z1,RPAR,IPAR) DO I=1,N CONT(I)=Y(I)+Z2(I) END DO CALL FCN(N,X+C2*H,CONT,Z2,RPAR,IPAR) DO I=1,N CONT(I)=Y(I)+Z3(I) END DO CALL FCN(N,XPH,CONT,Z3,RPAR,IPAR) NFCN=NFCN+3 C --- SOLVE THE LINEAR SYSTEMS DO I=1,N A1=Z1(I) A2=Z2(I) A3=Z3(I) Z1(I)=TI11*A1+TI12*A2+TI13*A3 Z2(I)=TI21*A1+TI22*A2+TI23*A3 Z3(I)=TI31*A1+TI32*A2+TI33*A3 END DO CALL SLVRAD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,FAC1,ALPHN,BETAN,E1,E2R,E2I,LDE1,Z1,Z2,Z3, & F1,F2,F3,CONT,IP1,IP2,IPHES,IER,IJOB) NSOL=NSOL+1 NEWT=NEWT+1 DYNO=0.D0 DO I=1,N DENOM=SCAL(I) DYNO=DYNO+(Z1(I)/DENOM)**2+(Z2(I)/DENOM)**2 & +(Z3(I)/DENOM)**2 END DO DYNO=DSQRT(DYNO/N3) C --- BAD CONVERGENCE OR NUMBER OF ITERATIONS TO LARGE IF (NEWT.GT.1.AND.NEWT.LT.NIT) THEN THQ=DYNO/DYNOLD IF (NEWT.EQ.2) THEN THETA=THQ ELSE THETA=SQRT(THQ*THQOLD) END IF THQOLD=THQ IF (THETA.LT.0.99D0) THEN FACCON=THETA/(1.0D0-THETA) DYTH=FACCON*DYNO*THETA**(NIT-1-NEWT)/FNEWT IF (DYTH.GE.1.0D0) THEN QNEWT=DMAX1(1.0D-4,DMIN1(20.0D0,DYTH)) HHFAC=.8D0*QNEWT**(-1.0D0/(4.0D0+NIT-1-NEWT)) H=HHFAC*H REJECT=.TRUE. LAST=.FALSE. IF (CALJAC) GOTO 20 GOTO 10 END IF ELSE GOTO 78 END IF END IF DYNOLD=MAX(DYNO,UROUND) DO I=1,N F1I=F1(I)+Z1(I) F2I=F2(I)+Z2(I) F3I=F3(I)+Z3(I) F1(I)=F1I F2(I)=F2I F3(I)=F3I Z1(I)=T11*F1I+T12*F2I+T13*F3I Z2(I)=T21*F1I+T22*F2I+T23*F3I Z3(I)=T31*F1I+ F2I END DO IF (FACCON*DYNO.GT.FNEWT) GOTO 40 C --- ERROR ESTIMATION CALL ESTRAD (N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & H,DD1,DD2,DD3,FCN,NFCN,Y0,Y,IJOB,X,M1,M2,NM1, & E1,LDE1,Z1,Z2,Z3,CONT,F1,F2,IP1,IPHES,SCAL,ERR, & FIRST,REJECT,FAC1,RPAR,IPAR) C --- COMPUTATION OF HNEW C --- WE REQUIRE .2<=HNEW/H<=8. FAC=MIN(SAFE,CFAC/(NEWT+2*NIT)) QUOT=MAX(FACR,MIN(FACL,ERR**.25D0/FAC)) HNEW=H/QUOT C *** *** *** *** *** *** *** C IS THE ERROR SMALL ENOUGH ? C *** *** *** *** *** *** *** IF (ERR.LT.1.D0) THEN C --- STEP IS ACCEPTED FIRST=.FALSE. NACCPT=NACCPT+1 IF (PRED) THEN C --- PREDICTIVE CONTROLLER OF GUSTAFSSON IF (NACCPT.GT.1) THEN FACGUS=(HACC/H)*(ERR**2/ERRACC)**0.25D0/SAFE FACGUS=MAX(FACR,MIN(FACL,FACGUS)) QUOT=MAX(QUOT,FACGUS) HNEW=H/QUOT END IF HACC=H ERRACC=MAX(1.0D-2,ERR) END IF XOLD=X HOLD=H X=XPH DO I=1,N Y(I)=Y(I)+Z3(I) Z2I=Z2(I) Z1I=Z1(I) CONT(I+N)=(Z2I-Z3(I))/C2M1 AK=(Z1I-Z2I)/C1MC2 ACONT3=Z1I/C1 ACONT3=(AK-ACONT3)/C2 CONT(I+N2)=(AK-CONT(I+N))/C1M1 CONT(I+N3)=CONT(I+N2)-ACONT3 END DO IF (ITOL.EQ.0) THEN DO I=1,N SCAL(I)=ATOL(1)+RTOL(1)*ABS(Y(I)) END DO ELSE DO I=1,N SCAL(I)=ATOL(I)+RTOL(I)*ABS(Y(I)) END DO END IF IF (IOUT.NE.0) THEN NRSOL=NACCPT+1 XSOL=X XOSOL=XOLD DO I=1,N CONT(I)=Y(I) END DO NSOLU=N HSOL=HOLD CALL SOLOUT(NRSOL,XOSOL,XSOL,Y,CONT,LRC,NSOLU, & RPAR,IPAR,IRTRN) IF (IRTRN.LT.0) GOTO 179 END IF CALJAC=.FALSE. IF (LAST) THEN H=HOPT IDID=1 RETURN END IF CALL FCN(N,X,Y,Y0,RPAR,IPAR) NFCN=NFCN+1 HNEW=POSNEG*MIN(ABS(HNEW),HMAXN) HOPT=HNEW HOPT=MIN(H,HNEW) IF (REJECT) HNEW=POSNEG*MIN(ABS(HNEW),ABS(H)) REJECT=.FALSE. IF ((X+HNEW/QUOT1-XEND)*POSNEG.GE.0.D0) THEN H=XEND-X LAST=.TRUE. ELSE QT=HNEW/H HHFAC=H IF (THETA.LE.THET.AND.QT.GE.QUOT1.AND.QT.LE.QUOT2) GOTO 30 H=HNEW END IF HHFAC=H IF (THETA.LE.THET) GOTO 20 GOTO 10 ELSE C --- STEP IS REJECTED REJECT=.TRUE. LAST=.FALSE. IF (FIRST) THEN H=H*0.1D0 HHFAC=0.1D0 ELSE HHFAC=HNEW/H H=HNEW END IF IF (NACCPT.GE.1) NREJCT=NREJCT+1 IF (CALJAC) GOTO 20 GOTO 10 END IF C --- UNEXPECTED STEP-REJECTION 78 CONTINUE IF (IER.NE.0) THEN NSING=NSING+1 IF (NSING.GE.5) GOTO 176 END IF H=H*0.5D0 HHFAC=0.5D0 REJECT=.TRUE. LAST=.FALSE. IF (CALJAC) GOTO 20 GOTO 10 C --- FAIL EXIT 176 CONTINUE CALL rprintfd1(' EXIT OF RADAU5 AT X= %g' // char(0), X) CALL rprintfi1(' MATRIX IS REPEATEDLY SINGULAR, IER= %i' & //char(0), IER) IDID=-4 RETURN 177 CONTINUE CALL rprintfd1(' EXIT OF RADAU5 AT X= %g' // char(0), X) CALL rprintfd1(' STEP SIZE T0O SMALL, H= %g' // char(0), H) IDID=-3 RETURN 178 CONTINUE CALL rprintfd1(' EXIT OF RADAU5 AT X= %g'//char(0), X ) CALL rprintfi1(' MORE THAN NMAX (I1),STEPS ARE NEEDED %i' & //char(0), NMAX) IDID=-2 RETURN C --- EXIT CAUSED BY SOLOUT 179 CONTINUE C karline: toggled this off C WRITE(MSG,979)X C CALL rprint(MSG) C 979 FORMAT(' EXIT OF RADAU5 AT X=',E18.4) IDID=2 RETURN END C C END OF SUBROUTINE RADCOR C C *********************************************************** C SUBROUTINE CONTR5(NEQ,X,CONT,LRC, RES) C ---------------------------------------------------------- C THIS FUNCTION CAN BE USED FOR CONINUOUS OUTPUT. IT PROVIDES AN C APPROXIMATION TO THE SOLUTION AT X. C IT GIVES THE VALUE OF THE COLLOCATION POLYNOMIAL, DEFINED FOR C THE LAST SUCCESSFULLY COMPUTED STEP (BY RADAU5). C ---------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION CONT(LRC) DOUBLE PRECISION RES(NEQ) INTEGER I COMMON /CONRA5/NN,NN2,NN3,NN4,XSOL,HSOL,C2M1,C1M1 S=(X-XSOL)/HSOL DO I = 1,NEQ RES(I)=CONT(I)+S*(CONT(I+NN)+(S-C2M1)*(CONT(I+NN2) & +(S-C1M1)*CONT(I+NN3))) ENDDO RETURN END C C END OF FUNCTION CONTR5 -KARLINE changed to SUBROUTINE THAT RETURNS ALL C C *********************************************************** C SUBROUTINE GETCONRA(RCONRA) C ---------------------------------------------------------- C THIS FUNCTION CAN BE USED FOR STANDALONE CONINUOUS OUTPUT. C IT RETURNS THE VALUES OF COMMON CONRA as used in CONTR5 C ---------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION RCONRA(2) COMMON /CONRA5/NN,NN2,NN3,NN4,XSOL,HSOL,C2M1,C1M1 RCONRA(1) = XSOL RCONRA(2) = HSOL RETURN END C C END OF FUNCTION CONTR5 -KARLINE changed to SUBROUTINE C C *********************************************************** SUBROUTINE CONTR5ALONE(I, NEQ,X,CONT,LRC, RCONRA, RES, Itype) C ---------------------------------------------------------- C THIS FUNCTION CAN BE USED FOR STANDALONE CONINUOUS OUTPUT. C IT PROVIDES AN APPROXIMATION TO THE Ith SOLUTION AT X. C IT GIVES THE VALUE OF THE COLLOCATION POLYNOMIAL, DEFINED FOR C THE LAST SUCCESSFULLY COMPUTED STEP (BY RADAU5). C ---------------------------------------------------------- IMPLICIT NONE INTEGER LRC, NEQ, Itype DOUBLE PRECISION RCONRA(2),CONT(LRC), RES,X DOUBLE PRECISION XSOL,HSOL,C2M1,C1M1,SQ6,C1,C2,S INTEGER I, NN, NN2, NN3, NN4 NN = NEQ NN2 = NEQ*2 NN3 = NEQ*3 NN4 = NEQ*4 XSOL = RCONRA(1) HSOL = RCONRA(2) SQ6=DSQRT(6.D0) C1=(4.D0-SQ6)/10.D0 C2=(4.D0+SQ6)/10.D0 C1M1=C1-1.D0 C2M1=C2-1.D0 S=(X-XSOL)/HSOL IF(IType .eq. 1) THEN ! value RES=CONT(I)+S*(CONT(I+NN)+(S-C2M1)*(CONT(I+NN2) & +(S-C1M1)*CONT(I+NN3))) ELSE ! derivative.... RES=1.d0/HSOL*(CONT(I+NN)-C2M1*CONT(I+NN2)+C2M1*C1M1*CONT(I+NN3) & + 2*S*(CONT(I+NN2)-CONT(I+NN3)*C2M1-CONT(I+NN3)*C1M1) & + 3*S*S*CONT(I+NN3) ) ENDIF RETURN END deSolve/src/opkda1.f0000644000176000001440000106604413572134421014035 0ustar ripleyusersC The code in this file is was taken from C https://www.netlib.org/odepack/ C Original author: Hindmarsh, Alan C., (LLNL) C Adapted for use in R package deSolve by the deSolve authors. C *DECK DUMACH DOUBLE PRECISION FUNCTION DUMACH () C***BEGIN PROLOGUE DUMACH C***PURPOSE Compute the unit roundoff of the machine. C***CATEGORY R1 C***TYPE DOUBLE PRECISION (RUMACH-S, DUMACH-D) C***KEYWORDS MACHINE CONSTANTS C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C *Usage: C DOUBLE PRECISION A, DUMACH C A = DUMACH() C C *Function Return Values: C A : the unit roundoff of the machine. C C *Description: C The unit roundoff is defined as the smallest positive machine C number u such that 1.0 + u .ne. 1.0. This is computed by DUMACH C in a machine-independent manner. C C***REFERENCES (NONE) C***ROUTINES CALLED DUMSUM C***REVISION HISTORY (YYYYMMDD) C 19930216 DATE WRITTEN C 19930818 Added SLATEC-format prologue. (FNF) C 20030707 Added DUMSUM to force normal storage of COMP. (ACH) C***END PROLOGUE DUMACH C DOUBLE PRECISION U, COMP C***FIRST EXECUTABLE STATEMENT DUMACH U = 1.0D0 10 U = U*0.5D0 CALL DUMSUM(1.0D0, U, COMP) IF (COMP .NE. 1.0D0) GO TO 10 DUMACH = U*2.0D0 RETURN C----------------------- End of Function DUMACH ------------------------ END SUBROUTINE DUMSUM(A,B,C) C Routine to force normal storing of A + B, for DUMACH. DOUBLE PRECISION A, B, C C = A + B RETURN END *DECK DCFODE SUBROUTINE DCFODE (METH, ELCO, TESCO) C***BEGIN PROLOGUE DCFODE C***SUBSIDIARY C***PURPOSE Set ODE integrator coefficients. C***TYPE DOUBLE PRECISION (SCFODE-S, DCFODE-D) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C DCFODE is called by the integrator routine to set coefficients C needed there. The coefficients for the current method, as C given by the value of METH, are set for all orders and saved. C The maximum order assumed here is 12 if METH = 1 and 5 if METH = 2. C (A smaller value of the maximum order is also allowed.) C DCFODE is called once at the beginning of the problem, C and is not called again unless and until METH is changed. C C The ELCO array contains the basic method coefficients. C The coefficients el(i), 1 .le. i .le. nq+1, for the method of C order nq are stored in ELCO(i,nq). They are given by a genetrating C polynomial, i.e., C l(x) = el(1) + el(2)*x + ... + el(nq+1)*x**nq. C For the implicit Adams methods, l(x) is given by C dl/dx = (x+1)*(x+2)*...*(x+nq-1)/factorial(nq-1), l(-1) = 0. C For the BDF methods, l(x) is given by C l(x) = (x+1)*(x+2)* ... *(x+nq)/K, C where K = factorial(nq)*(1 + 1/2 + ... + 1/nq). C C The TESCO array contains test constants used for the C local error test and the selection of step size and/or order. C At order nq, TESCO(k,nq) is used for the selection of step C size at order nq - 1 if k = 1, at order nq if k = 2, and at order C nq + 1 if k = 3. C C***SEE ALSO DLSODE C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791129 DATE WRITTEN C 890501 Modified prologue to SLATEC/LDOC format. (FNF) C 890503 Minor cosmetic changes. (FNF) C 930809 Renamed to allow single/double precision versions. (ACH) C***END PROLOGUE DCFODE C**End INTEGER METH INTEGER I, IB, NQ, NQM1, NQP1 DOUBLE PRECISION ELCO, TESCO DOUBLE PRECISION AGAMQ, FNQ, FNQM1, PC, PINT, RAGQ, 1 RQFAC, RQ1FAC, TSIGN, XPIN DIMENSION ELCO(13,12), TESCO(3,12) DIMENSION PC(12) C C***FIRST EXECUTABLE STATEMENT DCFODE IF (METH .EQ. 1) THEN GOTO 100 ELSE IF (METH .EQ. 2) THEN GOTO 200 ENDIF C GO TO (100, 200), METH C 100 ELCO(1,1) = 1.0D0 ELCO(2,1) = 1.0D0 TESCO(1,1) = 0.0D0 TESCO(2,1) = 2.0D0 TESCO(1,2) = 1.0D0 TESCO(3,12) = 0.0D0 PC(1) = 1.0D0 RQFAC = 1.0D0 DO 140 NQ = 2,12 C----------------------------------------------------------------------- C The PC array will contain the coefficients of the polynomial C p(x) = (x+1)*(x+2)*...*(x+nq-1). C Initially, p(x) = 1. C----------------------------------------------------------------------- RQ1FAC = RQFAC RQFAC = RQFAC/NQ NQM1 = NQ - 1 FNQM1 = NQM1 NQP1 = NQ + 1 C Form coefficients of p(x)*(x+nq-1). ---------------------------------- PC(NQ) = 0.0D0 DO 110 IB = 1,NQM1 I = NQP1 - IB PC(I) = PC(I-1) + FNQM1*PC(I) 110 CONTINUE PC(1) = FNQM1*PC(1) C Compute integral, -1 to 0, of p(x) and x*p(x). ----------------------- PINT = PC(1) XPIN = PC(1)/2.0D0 TSIGN = 1.0D0 DO 120 I = 2,NQ TSIGN = -TSIGN PINT = PINT + TSIGN*PC(I)/I XPIN = XPIN + TSIGN*PC(I)/(I+1) 120 CONTINUE C Store coefficients in ELCO and TESCO. -------------------------------- ELCO(1,NQ) = PINT*RQ1FAC ELCO(2,NQ) = 1.0D0 DO 130 I = 2,NQ ELCO(I+1,NQ) = RQ1FAC*PC(I)/I 130 CONTINUE AGAMQ = RQFAC*XPIN RAGQ = 1.0D0/AGAMQ TESCO(2,NQ) = RAGQ IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/NQP1 TESCO(3,NQM1) = RAGQ 140 CONTINUE RETURN C 200 PC(1) = 1.0D0 RQ1FAC = 1.0D0 DO 230 NQ = 1,5 C----------------------------------------------------------------------- C The PC array will contain the coefficients of the polynomial C p(x) = (x+1)*(x+2)*...*(x+nq). C Initially, p(x) = 1. C----------------------------------------------------------------------- FNQ = NQ NQP1 = NQ + 1 C Form coefficients of p(x)*(x+nq). ------------------------------------ PC(NQP1) = 0.0D0 DO 210 IB = 1,NQ I = NQ + 2 - IB PC(I) = PC(I-1) + FNQ*PC(I) 210 CONTINUE PC(1) = FNQ*PC(1) C Store coefficients in ELCO and TESCO. -------------------------------- DO 220 I = 1,NQP1 ELCO(I,NQ) = PC(I)/PC(2) 220 CONTINUE ELCO(2,NQ) = 1.0D0 TESCO(1,NQ) = RQ1FAC TESCO(2,NQ) = NQP1/ELCO(1,NQ) TESCO(3,NQ) = (NQ+2)/ELCO(1,NQ) RQ1FAC = RQ1FAC/FNQ 230 CONTINUE RETURN C----------------------- END OF SUBROUTINE DCFODE ---------------------- END *DECK DINTDY SUBROUTINE DINTDY (T, K, YH, NYH, DKY, IFLAG) C***BEGIN PROLOGUE DINTDY C***SUBSIDIARY C***PURPOSE Interpolate solution derivatives. C***TYPE DOUBLE PRECISION (SINTDY-S, DINTDY-D) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C DINTDY computes interpolated values of the K-th derivative of the C dependent variable vector y, and stores it in DKY. This routine C is called within the package with K = 0 and T = TOUT, but may C also be called by the user for any K up to the current order. C (See detailed instructions in the usage documentation.) C C The computed values in DKY are gotten by interpolation using the C Nordsieck history array YH. This array corresponds uniquely to a C vector-valued polynomial of degree NQCUR or less, and DKY is set C to the K-th derivative of this polynomial at T. C The formula for DKY is: C q C DKY(i) = sum c(j,K) * (T - tn)**(j-K) * h**(-j) * YH(i,j+1) C j=K C where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, tn = TCUR, h = HCUR. C The quantities nq = NQCUR, l = nq+1, N = NEQ, tn, and h are C communicated by COMMON. The above sum is done in reverse order. C IFLAG is returned negative if either K or T is out of bounds. C C***SEE ALSO DLSODE C***ROUTINES CALLED XERRWD C***COMMON BLOCKS DLS001 C***REVISION HISTORY (YYMMDD) C 791129 DATE WRITTEN C 890501 Modified prologue to SLATEC/LDOC format. (FNF) C 890503 Minor cosmetic changes. (FNF) C 930809 Renamed to allow single/double precision versions. (ACH) C 010418 Reduced size of Common block /DLS001/. (ACH) C 031105 Restored 'own' variables to Common block /DLS001/, to C enable interrupt/restart feature. (ACH) C 050427 Corrected roundoff decrement in TP. (ACH) C***END PROLOGUE DINTDY C**End INTEGER K, NYH, IFLAG DOUBLE PRECISION T, YH, DKY DIMENSION YH(NYH,*), DKY(*) INTEGER IOWNS, IXDUM1, IXDUM2, IXDUM3, IXDUM4, IXDUM5, IXDUM6, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IXDUM1, IXDUM2, IXDUM3, IXDUM4, IXDUM5, IXDUM6, IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 DOUBLE PRECISION C, R, S, TP CHARACTER(LEN=80) MSG C C***FIRST EXECUTABLE STATEMENT DINTDY IFLAG = 0 IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 TP = TN - HU - 100.0D0*UROUND*SIGN(ABS(TN) + ABS(HU), HU) IF ((T-TP)*(T-TN) .GT. 0.0D0) GO TO 90 C S = (T - TN)/H IC = 1 IF (K .EQ. 0) GO TO 15 JJ1 = L - K DO 10 JJ = JJ1,NQ IC = IC*JJ 10 CONTINUE 15 C = IC DO 20 I = 1,N DKY(I) = C*YH(I,L) 20 CONTINUE IF (K .EQ. NQ) GO TO 55 JB2 = NQ - K DO 50 JB = 1,JB2 J = NQ - JB JP1 = J + 1 IC = 1 IF (K .EQ. 0) GO TO 35 JJ1 = JP1 - K DO 30 JJ = JJ1,J IC = IC*JJ 30 CONTINUE 35 C = IC DO 40 I = 1,N DKY(I) = C*YH(I,JP1) + S*DKY(I) 40 CONTINUE 50 CONTINUE IF (K .EQ. 0) RETURN 55 R = H**(-K) DO 60 I = 1,N DKY(I) = R*DKY(I) 60 CONTINUE RETURN C 80 MSG = 'DINTDY- K (=I1) illegal ' CALL XERRWD (MSG, 30, 51, 0, 1, K, 0, 0, 0.0D0, 0.0D0) IFLAG = -1 RETURN 90 MSG = 'DINTDY- T (=R1) illegal ' CALL XERRWD (MSG, 30, 52, 0, 0, 0, 0, 1, T, 0.0D0) MSG=' T not in interval TCUR - HU (= R1) to TCUR (=R2) ' CALL XERRWD (MSG, 60, 52, 0, 0, 0, 0, 2, TP, TN) IFLAG = -2 RETURN C----------------------- END OF SUBROUTINE DINTDY ---------------------- END *DECK DPREPJ SUBROUTINE DPREPJ (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, 1 F, JAC,rpar,ipar) C***BEGIN PROLOGUE DPREPJ C***SUBSIDIARY C***PURPOSE Compute and process Newton iteration matrix. C***TYPE DOUBLE PRECISION (SPREPJ-S, DPREPJ-D) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C DPREPJ is called by DSTODE to compute and process the matrix C P = I - h*el(1)*J , where J is an approximation to the Jacobian. C Here J is computed by the user-supplied routine JAC if C MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5. C If MITER = 3, a diagonal approximation to J is used. C J is stored in WM and replaced by P. If MITER .ne. 3, P is then C subjected to LU decomposition in preparation for later solution C of linear systems with P as coefficient matrix. This is done C by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5. C C In addition to variables described in DSTODE and DLSODE prologues, C communication with DPREPJ uses the following: C Y = array containing predicted values on entry. C FTEM = work array of length N (ACOR in DSTODE). C SAVF = array containing f evaluated at predicted y. C WM = real work space for matrices. On output it contains the C inverse diagonal matrix if MITER = 3 and the LU decomposition C of P if MITER is 1, 2 , 4, or 5. C Storage of matrix elements starts at WM(3). C WM also contains the following matrix-related data: C WM(1) = SQRT(UROUND), used in numerical Jacobian increments. C WM(2) = H*EL0, saved for later use if MITER = 3. C IWM = integer work space containing pivot information, starting at C IWM(21), if MITER is 1, 2, 4, or 5. IWM also contains band C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. C EL0 = EL(1) (input). C IERPJ = output error flag, = 0 if no trouble, .gt. 0 if C P matrix found to be singular. C JCUR = output flag = 1 to indicate that the Jacobian matrix C (or approximation) is now current. C This routine also uses the COMMON variables EL0, H, TN, UROUND, C MITER, N, NFE, and NJE. C C***SEE ALSO DLSODE C***ROUTINES CALLED DGBFA, DGEFA, DVNORM C***COMMON BLOCKS DLS001 C***REVISION HISTORY (YYMMDD) C 791129 DATE WRITTEN C 890501 Modified prologue to SLATEC/LDOC format. (FNF) C 890504 Minor cosmetic changes. (FNF) C 930809 Renamed to allow single/double precision versions. (ACH) C 010418 Reduced size of Common block /DLS001/. (ACH) C 031105 Restored 'own' variables to Common block /DLS001/, to C enable interrupt/restart feature. (ACH) C***END PROLOGUE DPREPJ C**End EXTERNAL F, JAC CKS: added rpar,ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, NYH, IWM DOUBLE PRECISION Y, YH, EWT, FTEM, SAVF, WM DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), 1 WM(*), IWM(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER I, I1, I2, IER, II, J, J1, JJ, LENP, 1 MBA, MBAND, MEB1, MEBAND, ML, ML3, MU, NP1 DOUBLE PRECISION CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, 1 DVNORM C C***FIRST EXECUTABLE STATEMENT DPREPJ NJE = NJE + 1 IERPJ = 0 JCUR = 1 HL0 = H*EL0 IF (MITER .EQ. 1) THEN GOTO 100 ELSE IF (MITER .EQ. 2) THEN GOTO 200 ELSE IF (MITER .EQ. 3) THEN GOTO 300 ELSE IF (MITER .EQ. 4) THEN GOTO 400 ELSE IF (MITER .EQ. 5) THEN GOTO 500 ENDIF C GO TO (100, 200, 300, 400, 500), MITER C If MITER = 1, call JAC and multiply by scalar. ----------------------- 100 LENP = N*N DO 110 I = 1,LENP WM(I+2) = 0.0D0 110 CONTINUE CKS CALL JAC (NEQ, TN, Y, 0, 0, WM(3), N,RPAR,IPAR) CON = -HL0 DO 120 I = 1,LENP WM(I+2) = WM(I+2)*CON 120 CONTINUE GO TO 240 C If MITER = 2, make N calls to F to approximate J. -------------------- 200 FAC = DVNORM (N, SAVF, EWT) R0 = 1000.0D0*ABS(H)*UROUND*N*FAC IF (R0 .EQ. 0.0D0) R0 = 1.0D0 SRUR = WM(1) J1 = 2 DO 230 J = 1,N YJ = Y(J) R = MAX(SRUR*ABS(YJ),R0/EWT(J)) Y(J) = Y(J) + R FAC = -HL0/R CKS CALL F (NEQ, TN, Y, FTEM, rpar, ipar) DO 220 I = 1,N WM(I+J1) = (FTEM(I) - SAVF(I))*FAC 220 CONTINUE Y(J) = YJ J1 = J1 + N 230 CONTINUE NFE = NFE + N C Add identity matrix. ------------------------------------------------- 240 J = 3 NP1 = N + 1 DO 250 I = 1,N WM(J) = WM(J) + 1.0D0 J = J + NP1 250 CONTINUE C Do LU decomposition on P. -------------------------------------------- CALL DGEFA (WM(3), N, N, IWM(21), IER) IF (IER .NE. 0) IERPJ = 1 RETURN C If MITER = 3, construct a diagonal approximation to J and P. --------- 300 WM(2) = HL0 R = EL0*0.1D0 DO 310 I = 1,N Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) 310 CONTINUE CKS CALL F (NEQ, TN, Y, WM(3), rpar, ipar) NFE = NFE + 1 DO 320 I = 1,N R0 = H*SAVF(I) - YH(I,2) DI = 0.1D0*R0 - H*(WM(I+2) - SAVF(I)) WM(I+2) = 1.0D0 IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 IF (ABS(DI) .EQ. 0.0D0) GO TO 330 WM(I+2) = 0.1D0*R0/DI 320 CONTINUE RETURN 330 IERPJ = 1 RETURN C If MITER = 4, call JAC and multiply by scalar. ----------------------- 400 ML = IWM(1) MU = IWM(2) ML3 = ML + 3 MBAND = ML + MU + 1 MEBAND = MBAND + ML LENP = MEBAND*N DO 410 I = 1,LENP WM(I+2) = 0.0D0 410 CONTINUE CKS CALL JAC (NEQ, TN, Y, ML, MU, WM(ML3), MEBAND,RPAR,IPAR) CON = -HL0 DO 420 I = 1,LENP WM(I+2) = WM(I+2)*CON 420 CONTINUE GO TO 570 C If MITER = 5, make MBAND calls to F to approximate J. ---------------- 500 ML = IWM(1) MU = IWM(2) MBAND = ML + MU + 1 MBA = MIN(MBAND,N) MEBAND = MBAND + ML MEB1 = MEBAND - 1 SRUR = WM(1) FAC = DVNORM (N, SAVF, EWT) R0 = 1000.0D0*ABS(H)*UROUND*N*FAC IF (R0 .EQ. 0.0D0) R0 = 1.0D0 DO 560 J = 1,MBA DO 530 I = J,N,MBAND YI = Y(I) R = MAX(SRUR*ABS(YI),R0/EWT(I)) Y(I) = Y(I) + R 530 CONTINUE CKS CALL F (NEQ, TN, Y, FTEM, rpar, ipar) DO 550 JJ = J,N,MBAND Y(JJ) = YH(JJ,1) YJJ = Y(JJ) R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) FAC = -HL0/R I1 = MAX(JJ-MU,1) I2 = MIN(JJ+ML,N) II = JJ*MEB1 - ML + 2 DO 540 I = I1,I2 WM(II+I) = (FTEM(I) - SAVF(I))*FAC 540 CONTINUE 550 CONTINUE 560 CONTINUE NFE = NFE + MBA C Add identity matrix. ------------------------------------------------- 570 II = MBAND + 2 DO 580 I = 1,N WM(II) = WM(II) + 1.0D0 II = II + MEBAND 580 CONTINUE C Do LU decomposition of P. -------------------------------------------- CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(21), IER) IF (IER .NE. 0) IERPJ = 1 RETURN C----------------------- END OF SUBROUTINE DPREPJ ---------------------- END *DECK DSOLSY SUBROUTINE DSOLSY (WM, IWM, X, TEM) C***BEGIN PROLOGUE DSOLSY C***SUBSIDIARY C***PURPOSE ODEPACK linear system solver. C***TYPE DOUBLE PRECISION (SSOLSY-S, DSOLSY-D) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C This routine manages the solution of the linear system arising from C a chord iteration. It is called if MITER .ne. 0. C If MITER is 1 or 2, it calls DGESL to accomplish this. C If MITER = 3 it updates the coefficient h*EL0 in the diagonal C matrix, and then computes the solution. C If MITER is 4 or 5, it calls DGBSL. C Communication with DSOLSY uses the following variables: C WM = real work space containing the inverse diagonal matrix if C MITER = 3 and the LU decomposition of the matrix otherwise. C Storage of matrix elements starts at WM(3). C WM also contains the following matrix-related data: C WM(1) = SQRT(UROUND) (not used here), C WM(2) = HL0, the previous value of h*EL0, used if MITER = 3. C IWM = integer work space containing pivot information, starting at C IWM(21), if MITER is 1, 2, 4, or 5. IWM also contains band C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. C X = the right-hand side vector on input, and the solution vector C on output, of length N. C TEM = vector of work space of length N, not used in this version. C IERSL = output flag (in COMMON). IERSL = 0 if no trouble occurred. C IERSL = 1 if a singular matrix arose with MITER = 3. C This routine also uses the COMMON variables EL0, H, MITER, and N. C C***SEE ALSO DLSODE C***ROUTINES CALLED DGBSL, DGESL C***COMMON BLOCKS DLS001 C***REVISION HISTORY (YYMMDD) C 791129 DATE WRITTEN C 890501 Modified prologue to SLATEC/LDOC format. (FNF) C 890503 Minor cosmetic changes. (FNF) C 930809 Renamed to allow single/double precision versions. (ACH) C 010418 Reduced size of Common block /DLS001/. (ACH) C 031105 Restored 'own' variables to Common block /DLS001/, to C enable interrupt/restart feature. (ACH) C***END PROLOGUE DSOLSY C**End INTEGER IWM DOUBLE PRECISION WM, X, TEM DIMENSION WM(*), IWM(*), X(*), TEM(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER I, MEBAND, ML, MU DOUBLE PRECISION DI, HL0, PHL0, R C C***FIRST EXECUTABLE STATEMENT DSOLSY IERSL = 0 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN GOTO 100 ELSE IF (MITER .EQ. 3) THEN GOTO 300 ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN GOTO 400 ENDIF C GO TO (100, 100, 300, 400, 400), MITER 100 CALL DGESL (WM(3), N, N, IWM(21), X, 0) RETURN C 300 PHL0 = WM(2) HL0 = H*EL0 WM(2) = HL0 IF (HL0 .EQ. PHL0) GO TO 330 R = HL0/PHL0 DO 320 I = 1,N DI = 1.0D0 - R*(1.0D0 - 1.0D0/WM(I+2)) IF (ABS(DI) .EQ. 0.0D0) GO TO 390 WM(I+2) = 1.0D0/DI 320 CONTINUE 330 DO 340 I = 1,N X(I) = WM(I+2)*X(I) 340 CONTINUE RETURN 390 IERSL = 1 RETURN C 400 ML = IWM(1) MU = IWM(2) MEBAND = 2*ML + MU + 1 CALL DGBSL (WM(3), MEBAND, N, ML, MU, IWM(21), X, 0) RETURN C----------------------- END OF SUBROUTINE DSOLSY ---------------------- END *DECK DSRCOM *DECK DSTODE SUBROUTINE DSTODE (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, 1 WM, IWM, F, JAC, PJAC, SLVS,RPAR,IPAR) C***BEGIN PROLOGUE DSTODE C***SUBSIDIARY C***PURPOSE Performs one step of an ODEPACK integration. C***TYPE DOUBLE PRECISION (SSTODE-S, DSTODE-D) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C DSTODE performs one step of the integration of an initial value C problem for a system of ordinary differential equations. C Note: DSTODE is independent of the value of the iteration method C indicator MITER, when this is .ne. 0, and hence is independent C of the type of chord method used, or the Jacobian structure. C Communication with DSTODE is done with the following variables: C C NEQ = integer array containing problem size in NEQ(1), and C passed as the NEQ argument in all calls to F and JAC. C Y = an array of length .ge. N used as the Y argument in C all calls to F and JAC. C YH = an NYH by LMAX array containing the dependent variables C and their approximate scaled derivatives, where C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate C j-th derivative of y(i), scaled by h**j/factorial(j) C (j = 0,1,...,NQ). on entry for the first step, the first C two columns of YH must be set from the initial values. C NYH = a constant integer .ge. N, the first dimension of YH. C YH1 = a one-dimensional array occupying the same space as YH. C EWT = an array of length N containing multiplicative weights C for local error measurements. Local errors in Y(i) are C compared to 1.0/EWT(i) in various error tests. C SAVF = an array of working storage, of length N. C Also used for input of YH(*,MAXORD+2) when JSTART = -1 C and MAXORD .lt. the current order NQ. C ACOR = a work array of length N, used for the accumulated C corrections. On a successful return, ACOR(i) contains C the estimated one-step local error in Y(i). C WM,IWM = real and integer work arrays associated with matrix C operations in chord iteration (MITER .ne. 0). C PJAC = name of routine to evaluate and preprocess Jacobian matrix C and P = I - h*el0*JAC, if a chord method is being used. C SLVS = name of routine to solve linear system in chord iteration. C CCMAX = maximum relative change in h*el0 before PJAC is called. C H = the step size to be attempted on the next step. C H is altered by the error control algorithm during the C problem. H can be either positive or negative, but its C sign must remain constant throughout the problem. C HMIN = the minimum absolute value of the step size h to be used. C HMXI = inverse of the maximum absolute value of h to be used. C HMXI = 0.0 is allowed and corresponds to an infinite hmax. C HMIN and HMXI may be changed at any time, but will not C take effect until the next change of h is considered. C TN = the independent variable. TN is updated on each step taken. C JSTART = an integer used for input only, with the following C values and meanings: C 0 perform the first step. C .gt.0 take a new step continuing from the last. C -1 take the next step with a new value of H, MAXORD, C N, METH, MITER, and/or matrix parameters. C -2 take the next step with a new value of H, C but with other inputs unchanged. C On return, JSTART is set to 1 to facilitate continuation. C KFLAG = a completion code with the following meanings: C 0 the step was succesful. C -1 the requested error could not be achieved. C -2 corrector convergence could not be achieved. C -3 fatal error in PJAC or SLVS. C A return with KFLAG = -1 or -2 means either C abs(H) = HMIN or 10 consecutive failures occurred. C On a return with KFLAG negative, the values of TN and C the YH array are as of the beginning of the last C step, and H is the last step size attempted. C MAXORD = the maximum order of integration method to be allowed. C MAXCOR = the maximum number of corrector iterations allowed. C MSBP = maximum number of steps between PJAC calls (MITER .gt. 0). C MXNCF = maximum number of convergence failures allowed. C METH/MITER = the method flags. See description in driver. C N = the number of first-order differential equations. C The values of CCMAX, H, HMIN, HMXI, TN, JSTART, KFLAG, MAXORD, C MAXCOR, MSBP, MXNCF, METH, MITER, and N are communicated via COMMON. C C***SEE ALSO DLSODE C***ROUTINES CALLED DCFODE, DVNORM C***COMMON BLOCKS DLS001 C***REVISION HISTORY (YYMMDD) C 791129 DATE WRITTEN C 890501 Modified prologue to SLATEC/LDOC format. (FNF) C 890503 Minor cosmetic changes. (FNF) C 930809 Renamed to allow single/double precision versions. (ACH) C 010418 Reduced size of Common block /DLS001/. (ACH) C 031105 Restored 'own' variables to Common block /DLS001/, to C enable interrupt/restart feature. (ACH) C***END PROLOGUE DSTODE C**End EXTERNAL F, JAC, PJAC, SLVS INTEGER NEQ, NYH, IWM CKS: added rpar,ipar integer ipar(*) double precision rpar(*) DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, ACOR, WM DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), 1 ACOR(*), WM(*), IWM(*) INTEGER IOWND, IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER I, I1, IREDO, IRET, J, JB, M, NCF, NEWQ DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP, 1 R, RH, RHDN, RHSM, RHUP, TOLD, DVNORM COMMON /DLS001/ CONIT, CRATE, EL(13), ELCO(13,12), 1 HOLD, RMAX, TESCO(3,12), 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 3 IOWND(6), IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C C***FIRST EXECUTABLE STATEMENT DSTODE KFLAG = 0 TOLD = TN NCF = 0 IERPJ = 0 IERSL = 0 JCUR = 0 ICF = 0 DELP = 0.0D0 IF (JSTART .GT. 0) GO TO 200 IF (JSTART .EQ. -1) GO TO 100 IF (JSTART .EQ. -2) GO TO 160 C----------------------------------------------------------------------- C On the first call, the order is set to 1, and other variables are C initialized. RMAX is the maximum ratio by which H can be increased C in a single step. It is initially 1.E4 to compensate for the small C initial H, but then is normally equal to 10. If a failure C occurs (in corrector convergence or error test), RMAX is set to 2 C for the next increase. C----------------------------------------------------------------------- LMAX = MAXORD + 1 NQ = 1 L = 2 IALTH = 2 RMAX = 10000.0D0 RC = 0.0D0 EL0 = 1.0D0 CRATE = 0.7D0 HOLD = H MEO = METH NSLP = 0 IPUP = MITER IRET = 3 GO TO 140 C----------------------------------------------------------------------- C The following block handles preliminaries needed when JSTART = -1. C IPUP is set to MITER to force a matrix update. C If an order increase is about to be considered (IALTH = 1), C IALTH is reset to 2 to postpone consideration one more step. C If the caller has changed METH, DCFODE is called to reset C the coefficients of the method. C If the caller has changed MAXORD to a value less than the current C order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly. C If H is to be changed, YH must be rescaled. C If H or METH is being changed, IALTH is reset to L = NQ + 1 C to prevent further changes in H for that many steps. C----------------------------------------------------------------------- 100 IPUP = MITER LMAX = MAXORD + 1 IF (IALTH .EQ. 1) IALTH = 2 IF (METH .EQ. MEO) GO TO 110 CALL DCFODE (METH, ELCO, TESCO) MEO = METH IF (NQ .GT. MAXORD) GO TO 120 IALTH = L IRET = 1 GO TO 150 110 IF (NQ .LE. MAXORD) GO TO 160 120 NQ = MAXORD L = LMAX DO 125 I = 1,L EL(I) = ELCO(I,NQ) 125 CONTINUE NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/(NQ+2) DDN = DVNORM (N, SAVF, EWT)/TESCO(1,L) EXDN = 1.0D0/L RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) RH = MIN(RHDN,1.0D0) IREDO = 3 IF (H .EQ. HOLD) GO TO 170 RH = MIN(RH,ABS(H/HOLD)) H = HOLD GO TO 175 C----------------------------------------------------------------------- C DCFODE is called to get all the integration coefficients for the C current METH. Then the EL vector and related constants are reset C whenever the order NQ is changed, or at the start of the problem. C----------------------------------------------------------------------- 140 CALL DCFODE (METH, ELCO, TESCO) 150 DO 155 I = 1,L EL(I) = ELCO(I,NQ) 155 CONTINUE NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/(NQ+2) IF (IRET .EQ. 1) THEN GOTO 160 ELSE IF (IRET .EQ. 2) THEN GOTO 170 ELSE IF (IRET .EQ. 3) THEN GOTO 200 ENDIF C GO TO (160, 170, 200), IRET C----------------------------------------------------------------------- C If H is being changed, the H ratio RH is checked against C RMAX, HMIN, and HMXI, and the YH array rescaled. IALTH is set to C L = NQ + 1 to prevent a change of H for that many steps, unless C forced by a convergence or error test failure. C----------------------------------------------------------------------- 160 IF (H .EQ. HOLD) GO TO 200 RH = H/HOLD H = HOLD IREDO = 3 GO TO 175 170 RH = MAX(RH,HMIN/ABS(H)) 175 RH = MIN(RH,RMAX) RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) R = 1.0D0 DO 190 J = 2,L R = R*RH DO 180 I = 1,N YH(I,J) = YH(I,J)*R 180 CONTINUE 190 CONTINUE H = H*RH RC = RC*RH IALTH = L IF (IREDO .EQ. 0) GO TO 690 C----------------------------------------------------------------------- C This section computes the predicted values by effectively C multiplying the YH array by the Pascal Triangle matrix. C RC is the ratio of new to old values of the coefficient H*EL(1). C When RC differs from 1 by more than CCMAX, IPUP is set to MITER C to force PJAC to be called, if a Jacobian is involved. C In any case, PJAC is called at least every MSBP steps. C----------------------------------------------------------------------- 200 IF (ABS(RC-1.0D0) .GT. CCMAX) IPUP = MITER IF (NST .GE. NSLP+MSBP) IPUP = MITER TN = TN + H I1 = NQNYH + 1 DO 215 JB = 1,NQ I1 = I1 - NYH Cdir$ ivdep DO 210 I = I1,NQNYH YH1(I) = YH1(I) + YH1(I+NYH) 210 CONTINUE 215 CONTINUE C----------------------------------------------------------------------- C Up to MAXCOR corrector iterations are taken. A convergence test is C made on the R.M.S. norm of each correction, weighted by the error C weight vector EWT. The sum of the corrections is accumulated in the C vector ACOR(i). The YH array is not altered in the corrector loop. C----------------------------------------------------------------------- 220 M = 0 DO 230 I = 1,N Y(I) = YH(I,1) 230 CONTINUE CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 IF (IPUP .LE. 0) GO TO 250 C----------------------------------------------------------------------- C If indicated, the matrix P = I - h*el(1)*J is reevaluated and C preprocessed before starting the corrector iteration. IPUP is set C to 0 as an indicator that this has been done. C----------------------------------------------------------------------- CKS CALL PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, &rpar,ipar) IPUP = 0 RC = 1.0D0 NSLP = NST CRATE = 0.7D0 IF (IERPJ .NE. 0) GO TO 430 250 DO 260 I = 1,N ACOR(I) = 0.0D0 260 CONTINUE 270 IF (MITER .NE. 0) GO TO 350 C----------------------------------------------------------------------- C In the case of functional iteration, update Y directly from C the result of the last function evaluation. C----------------------------------------------------------------------- DO 290 I = 1,N SAVF(I) = H*SAVF(I) - YH(I,2) Y(I) = SAVF(I) - ACOR(I) 290 CONTINUE DEL = DVNORM (N, Y, EWT) DO 300 I = 1,N Y(I) = YH(I,1) + EL(1)*SAVF(I) ACOR(I) = SAVF(I) 300 CONTINUE GO TO 400 C----------------------------------------------------------------------- C In the case of the chord method, compute the corrector error, C and solve the linear system with that as right-hand side and C P as coefficient matrix. C----------------------------------------------------------------------- 350 DO 360 I = 1,N Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) 360 CONTINUE CALL SLVS (WM, IWM, Y, SAVF) IF (IERSL .LT. 0) GO TO 430 IF (IERSL .GT. 0) GO TO 410 DEL = DVNORM (N, Y, EWT) DO 380 I = 1,N ACOR(I) = ACOR(I) + Y(I) Y(I) = YH(I,1) + EL(1)*ACOR(I) 380 CONTINUE C----------------------------------------------------------------------- C Test for convergence. If M.gt.0, an estimate of the convergence C rate constant is stored in CRATE, and this is used in the test. C----------------------------------------------------------------------- 400 IF (M .NE. 0) CRATE = MAX(0.2D0*CRATE,DEL/DELP) DCON = DEL*MIN(1.0D0,1.5D0*CRATE)/(TESCO(2,NQ)*CONIT) IF (DCON .LE. 1.0D0) GO TO 450 M = M + 1 IF (M .EQ. MAXCOR) GO TO 410 IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 DELP = DEL CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 GO TO 270 C----------------------------------------------------------------------- C The corrector iteration failed to converge. C If MITER .ne. 0 and the Jacobian is out of date, PJAC is called for C the next try. Otherwise the YH array is retracted to its values C before prediction, and H is reduced, if possible. If H cannot be C reduced or MXNCF failures have occurred, exit with KFLAG = -2. C----------------------------------------------------------------------- 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 ICF = 1 IPUP = MITER GO TO 220 430 ICF = 2 NCF = NCF + 1 RMAX = 2.0D0 TN = TOLD I1 = NQNYH + 1 DO 445 JB = 1,NQ I1 = I1 - NYH Cdir$ ivdep DO 440 I = I1,NQNYH YH1(I) = YH1(I) - YH1(I+NYH) 440 CONTINUE 445 CONTINUE IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670 IF (NCF .EQ. MXNCF) GO TO 670 RH = 0.25D0 IPUP = MITER IREDO = 1 GO TO 170 C----------------------------------------------------------------------- C The corrector has converged. JCUR is set to 0 C to signal that the Jacobian involved may need updating later. C The local error test is made and control passes to statement 500 C if it fails. C----------------------------------------------------------------------- 450 JCUR = 0 IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) IF (M .GT. 0) DSM = DVNORM (N, ACOR, EWT)/TESCO(2,NQ) IF (DSM .GT. 1.0D0) GO TO 500 C----------------------------------------------------------------------- C After a successful step, update the YH array. C Consider changing H if IALTH = 1. Otherwise decrease IALTH by 1. C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for C use in a possible order increase on the next step. C If a change in H is considered, an increase or decrease in order C by one is considered also. A change in H is made only if it is by a C factor of at least 1.1. If not, IALTH is set to 3 to prevent C testing for that many steps. C----------------------------------------------------------------------- KFLAG = 0 IREDO = 0 NST = NST + 1 HU = H NQU = NQ DO 480 J = 1,L DO 470 I = 1,N YH(I,J) = YH(I,J) + EL(J)*ACOR(I) 470 CONTINUE 480 CONTINUE IALTH = IALTH - 1 IF (IALTH .EQ. 0) GO TO 520 IF (IALTH .GT. 1) GO TO 700 IF (L .EQ. LMAX) GO TO 700 DO 490 I = 1,N YH(I,LMAX) = ACOR(I) 490 CONTINUE GO TO 700 C----------------------------------------------------------------------- C The error test failed. KFLAG keeps track of multiple failures. C Restore TN and the YH array to their previous values, and prepare C to try the step again. Compute the optimum step size for this or C one lower order. After 2 or more failures, H is forced to decrease C by a factor of 0.2 or less. C----------------------------------------------------------------------- 500 KFLAG = KFLAG - 1 TN = TOLD I1 = NQNYH + 1 DO 515 JB = 1,NQ I1 = I1 - NYH Cdir$ ivdep DO 510 I = I1,NQNYH YH1(I) = YH1(I) - YH1(I+NYH) 510 CONTINUE 515 CONTINUE RMAX = 2.0D0 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 IF (KFLAG .LE. -3) GO TO 640 IREDO = 2 RHUP = 0.0D0 GO TO 540 C----------------------------------------------------------------------- C Regardless of the success or failure of the step, factors C RHDN, RHSM, and RHUP are computed, by which H could be multiplied C at order NQ - 1, order NQ, or order NQ + 1, respectively. C In the case of failure, RHUP = 0.0 to avoid an order increase. C The largest of these is determined and the new order chosen C accordingly. If the order is to be increased, we compute one C additional scaled derivative. C----------------------------------------------------------------------- 520 RHUP = 0.0D0 IF (L .EQ. LMAX) GO TO 540 DO 530 I = 1,N SAVF(I) = ACOR(I) - YH(I,LMAX) 530 CONTINUE DUP = DVNORM (N, SAVF, EWT)/TESCO(3,NQ) EXUP = 1.0D0/(L+1) RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) 540 EXSM = 1.0D0/L RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) RHDN = 0.0D0 IF (NQ .EQ. 1) GO TO 560 DDN = DVNORM (N, YH(1,L), EWT)/TESCO(1,NQ) EXDN = 1.0D0/NQ RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) 560 IF (RHSM .GE. RHUP) GO TO 570 IF (RHUP .GT. RHDN) GO TO 590 GO TO 580 570 IF (RHSM .LT. RHDN) GO TO 580 NEWQ = NQ RH = RHSM GO TO 620 580 NEWQ = NQ - 1 RH = RHDN IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 GO TO 620 590 NEWQ = L RH = RHUP IF (RH .LT. 1.1D0) GO TO 610 R = EL(L)/L DO 600 I = 1,N YH(I,NEWQ+1) = ACOR(I)*R 600 CONTINUE GO TO 630 610 IALTH = 3 GO TO 700 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) C----------------------------------------------------------------------- C If there is a change of order, reset NQ, l, and the coefficients. C In any case H is reset according to RH and the YH array is rescaled. C Then exit from 690 if the step was OK, or redo the step otherwise. C----------------------------------------------------------------------- IF (NEWQ .EQ. NQ) GO TO 170 630 NQ = NEWQ L = NQ + 1 IRET = 2 GO TO 150 C----------------------------------------------------------------------- C Control reaches this section if 3 or more failures have occured. C If 10 failures have occurred, exit with KFLAG = -1. C It is assumed that the derivatives that have accumulated in the C YH array have errors of the wrong order. Hence the first C derivative is recomputed, and the order is set to 1. Then C H is reduced by a factor of 10, and the step is retried, C until it succeeds or H reaches HMIN. C----------------------------------------------------------------------- 640 IF (KFLAG .EQ. -10) GO TO 660 RH = 0.1D0 RH = MAX(HMIN/ABS(H),RH) H = H*RH DO 645 I = 1,N Y(I) = YH(I,1) 645 CONTINUE CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 DO 650 I = 1,N YH(I,2) = H*SAVF(I) 650 CONTINUE IPUP = MITER IALTH = 5 IF (NQ .EQ. 1) GO TO 200 NQ = 1 L = 2 IRET = 3 GO TO 150 C----------------------------------------------------------------------- C All returns are made through this section. H is saved in HOLD C to allow the caller to change H on the next step. C----------------------------------------------------------------------- 660 KFLAG = -1 GO TO 720 670 KFLAG = -2 GO TO 720 680 KFLAG = -3 GO TO 720 690 RMAX = 10.0D0 700 R = 1.0D0/TESCO(2,NQU) DO 710 I = 1,N ACOR(I) = ACOR(I)*R 710 CONTINUE 720 HOLD = H JSTART = 1 RETURN C----------------------- END OF SUBROUTINE DSTODE ---------------------- END *DECK DEWSET SUBROUTINE DEWSET (N, ITOL, RTOL, ATOL, YCUR, EWT) C***BEGIN PROLOGUE DEWSET C***SUBSIDIARY C***PURPOSE Set error weight vector. C***TYPE DOUBLE PRECISION (SEWSET-S, DEWSET-D) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C This subroutine sets the error weight vector EWT according to C EWT(i) = RTOL(i)*ABS(YCUR(i)) + ATOL(i), i = 1,...,N, C with the subscript on RTOL and/or ATOL possibly replaced by 1 above, C depending on the value of ITOL. C C***SEE ALSO DLSODE C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791129 DATE WRITTEN C 890501 Modified prologue to SLATEC/LDOC format. (FNF) C 890503 Minor cosmetic changes. (FNF) C 930809 Renamed to allow single/double precision versions. (ACH) C***END PROLOGUE DEWSET C**End INTEGER N, ITOL INTEGER I DOUBLE PRECISION RTOL, ATOL, YCUR, EWT DIMENSION RTOL(*), ATOL(*), YCUR(N), EWT(N) C C***FIRST EXECUTABLE STATEMENT DEWSET IF (ITOL .EQ. 1) THEN GOTO 10 ELSE IF (ITOL .EQ. 2) THEN GOTO 20 ELSE IF (ITOL .EQ. 3) THEN GOTO 30 ELSE IF (ITOL .EQ. 4) THEN GOTO 40 ENDIF C GO TO (10, 20, 30, 40), ITOL 10 CONTINUE DO 15 I = 1,N EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(1) 15 CONTINUE RETURN 20 CONTINUE DO 25 I = 1,N EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(I) 25 CONTINUE RETURN 30 CONTINUE DO 35 I = 1,N EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(1) 35 CONTINUE RETURN 40 CONTINUE DO 45 I = 1,N EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I) 45 CONTINUE RETURN C----------------------- END OF SUBROUTINE DEWSET ---------------------- END *DECK DVNORM DOUBLE PRECISION FUNCTION DVNORM (N, V, W) C***BEGIN PROLOGUE DVNORM C***SUBSIDIARY C***PURPOSE Weighted root-mean-square vector norm. C***TYPE DOUBLE PRECISION (SVNORM-S, DVNORM-D) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C This function routine computes the weighted root-mean-square norm C of the vector of length N contained in the array V, with weights C contained in the array W of length N: C DVNORM = SQRT( (1/N) * SUM( V(i)*W(i) )**2 ) C C***SEE ALSO DLSODE C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791129 DATE WRITTEN C 890501 Modified prologue to SLATEC/LDOC format. (FNF) C 890503 Minor cosmetic changes. (FNF) C 930809 Renamed to allow single/double precision versions. (ACH) C***END PROLOGUE DVNORM C**End INTEGER N, I DOUBLE PRECISION V, W, SUM DIMENSION V(N), W(N) C C***FIRST EXECUTABLE STATEMENT DVNORM SUM = 0.0D0 DO 10 I = 1,N SUM = SUM + (V(I)*W(I))**2 10 CONTINUE DVNORM = SQRT(SUM/N) RETURN C----------------------- END OF FUNCTION DVNORM ------------------------ END *DECK DIPREP SUBROUTINE DIPREP (NEQ, Y, RWORK, IWK, IA, JA, IPFLAG, F, JAC, &rpar,ipar) EXTERNAL F, JAC CKS: added rpar,ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, IA, JA, IPFLAG, IWK(*) DOUBLE PRECISION Y, RWORK DIMENSION NEQ(*), Y(*), RWORK(*), IA(*), JA(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION RLSS COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLSS01/ RLSS(6), 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU INTEGER I, IMAX, LEWTN, LYHD, LYHN C----------------------------------------------------------------------- C This routine serves as an interface between the driver and C Subroutine DPREP. It is called only if MITER is 1 or 2. C Tasks performed here are: C * call DPREP, C * reset the required WM segment length LENWK, C * move YH back to its final location (following WM in RWORK), C * reset pointers for YH, SAVF, EWT, and ACOR, and C * move EWT to its new position if ISTATE = 1. C IPFLAG is an output error indication flag. IPFLAG = 0 if there was C no trouble, and IPFLAG is the value of the DPREP error flag IPPER C if there was trouble in Subroutine DPREP. C----------------------------------------------------------------------- IPFLAG = 0 C Call DPREP to do matrix preprocessing operations. -------------------- CALL DPREP (NEQ, Y, RWORK(LYH), RWORK(LSAVF), RWORK(LEWT), 1 RWORK(LACOR),IA,JA,RWORK(LWM),IWK(2*LWM-1),IPFLAG, F, JAC, & rpar,ipar) LENWK = MAX(LREQ,LWMIN) IF (IPFLAG .LT. 0) RETURN C If DPREP was successful, move YH to end of required space for WM. ---- LYHN = LWM + LENWK IF (LYHN .GT. LYH) RETURN LYHD = LYH - LYHN IF (LYHD .EQ. 0) GO TO 20 IMAX = LYHN - 1 + LENYHM DO 10 I = LYHN,IMAX RWORK(I) = RWORK(I+LYHD) 10 CONTINUE LYH = LYHN C Reset pointers for SAVF, EWT, and ACOR. ------------------------------ 20 LSAVF = LYH + LENYH LEWTN = LSAVF + N LACOR = LEWTN + N IF (ISTATC .EQ. 3) GO TO 40 C If ISTATE = 1, move EWT (left) to its new position. ------------------ IF (LEWTN .GT. LEWT) RETURN DO 30 I = 1,N RWORK(I+LEWTN-1) = RWORK(I+LEWT-1) 30 CONTINUE 40 LEWT = LEWTN RETURN C----------------------- End of Subroutine DIPREP ---------------------- END *DECK DPREP SUBROUTINE DPREP (NEQ, Y, YH, SAVF, EWT, FTEM, IA, JA, 1 WK, IWK, IPPER, F, JAC,rpar,ipar) EXTERNAL F,JAC CKS: added rpar,ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, IA, JA, IWK, IPPER DOUBLE PRECISION Y, YH, SAVF, EWT, FTEM, WK DIMENSION NEQ(*), Y(*), YH(*), SAVF(*), EWT(*), FTEM(*), 1 IA(*), JA(*), WK(*), IWK(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLSS01/ CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH, 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU INTEGER I, IBR, IER, IPIL, IPIU, IPTT1, IPTT2, J, JFOUND, K, 1 KNEW, KMAX, KMIN, LDIF, LENIGP, LIWK, MAXG, NP1, NZSUT DOUBLE PRECISION DQ, DYJ, ERWT, FAC, YJ C----------------------------------------------------------------------- C This routine performs preprocessing related to the sparse linear C systems that must be solved if MITER = 1 or 2. C The operations that are performed here are: C * compute sparseness structure of Jacobian according to MOSS, C * compute grouping of column indices (MITER = 2), C * compute a new ordering of rows and columns of the matrix, C * reorder JA corresponding to the new ordering, C * perform a symbolic LU factorization of the matrix, and C * set pointers for segments of the IWK/WK array. C In addition to variables described previously, DPREP uses the C following for communication: C YH = the history array. Only the first column, containing the C current Y vector, is used. Used only if MOSS .ne. 0. C SAVF = a work array of length NEQ, used only if MOSS .ne. 0. C EWT = array of length NEQ containing (inverted) error weights. C Used only if MOSS = 2 or if ISTATE = MOSS = 1. C FTEM = a work array of length NEQ, identical to ACOR in the driver, C used only if MOSS = 2. C WK = a real work array of length LENWK, identical to WM in C the driver. C IWK = integer work array, assumed to occupy the same space as WK. C LENWK = the length of the work arrays WK and IWK. C ISTATC = a copy of the driver input argument ISTATE (= 1 on the C first call, = 3 on a continuation call). C IYS = flag value from ODRV or CDRV. C IPPER = output error flag with the following values and meanings: C 0 no error. C -1 insufficient storage for internal structure pointers. C -2 insufficient storage for JGROUP. C -3 insufficient storage for ODRV. C -4 other error flag from ODRV (should never occur). C -5 insufficient storage for CDRV. C -6 other error flag from CDRV. C----------------------------------------------------------------------- IBIAN = LRAT*2 IPIAN = IBIAN + 1 NP1 = N + 1 IPJAN = IPIAN + NP1 IBJAN = IPJAN - 1 LIWK = LENWK*LRAT IF (IPJAN+N-1 .GT. LIWK) GO TO 210 IF (MOSS .EQ. 0) GO TO 30 C IF (ISTATC .EQ. 3) GO TO 20 C ISTATE = 1 and MOSS .ne. 0. Perturb Y for structure determination. -- DO 10 I = 1,N ERWT = 1.0D0/EWT(I) FAC = 1.0D0 + 1.0D0/(I + 1.0D0) Y(I) = Y(I) + FAC*SIGN(ERWT,Y(I)) 10 CONTINUE IF (MOSS .EQ. 1) THEN GOTO 70 ELSE IF (MOSS .EQ. 2) THEN GOTO 100 ENDIF C GO TO (70, 100), MOSS C 20 CONTINUE C ISTATE = 3 and MOSS .ne. 0. Load Y from YH(*,1). -------------------- DO 25 I = 1,N Y(I) = YH(I) 25 CONTINUE IF (MOSS .EQ. 1) THEN GOTO 70 ELSE IF (MOSS .EQ. 2) THEN GOTO 100 ENDIF C GO TO (70, 100), MOSS C C MOSS = 0. Process user's IA,JA. Add diagonal entries if necessary. - 30 KNEW = IPJAN KMIN = IA(1) IWK(IPIAN) = 1 DO 60 J = 1,N JFOUND = 0 KMAX = IA(J+1) - 1 IF (KMIN .GT. KMAX) GO TO 45 DO 40 K = KMIN,KMAX I = JA(K) IF (I .EQ. J) JFOUND = 1 IF (KNEW .GT. LIWK) GO TO 210 IWK(KNEW) = I KNEW = KNEW + 1 40 CONTINUE IF (JFOUND .EQ. 1) GO TO 50 45 IF (KNEW .GT. LIWK) GO TO 210 IWK(KNEW) = J KNEW = KNEW + 1 50 IWK(IPIAN+J) = KNEW + 1 - IPJAN KMIN = KMAX + 1 60 CONTINUE GO TO 140 C C MOSS = 1. Compute structure from user-supplied Jacobian routine JAC. 70 CONTINUE C A dummy call to F allows user to create temporaries for use in JAC. -- CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) K = IPJAN IWK(IPIAN) = 1 DO 90 J = 1,N IF (K .GT. LIWK) GO TO 210 IWK(K) = J K = K + 1 DO 75 I = 1,N SAVF(I) = 0.0D0 75 CONTINUE CKS CALL JAC (NEQ, TN, Y, J, IWK(IPIAN), IWK(IPJAN), SAVF, & rpar,ipar) DO 80 I = 1,N IF (ABS(SAVF(I)) .LE. SETH) GO TO 80 IF (I .EQ. J) GO TO 80 IF (K .GT. LIWK) GO TO 210 IWK(K) = I K = K + 1 80 CONTINUE IWK(IPIAN+J) = K + 1 - IPJAN 90 CONTINUE GO TO 140 C C MOSS = 2. Compute structure from results of N + 1 calls to F. ------- 100 K = IPJAN IWK(IPIAN) = 1 CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) DO 120 J = 1,N IF (K .GT. LIWK) GO TO 210 IWK(K) = J K = K + 1 YJ = Y(J) ERWT = 1.0D0/EWT(J) DYJ = SIGN(ERWT,YJ) Y(J) = YJ + DYJ CKS CALL F (NEQ, TN, Y, FTEM, rpar, ipar) Y(J) = YJ DO 110 I = 1,N DQ = (FTEM(I) - SAVF(I))/DYJ IF (ABS(DQ) .LE. SETH) GO TO 110 IF (I .EQ. J) GO TO 110 IF (K .GT. LIWK) GO TO 210 IWK(K) = I K = K + 1 110 CONTINUE IWK(IPIAN+J) = K + 1 - IPJAN 120 CONTINUE C 140 CONTINUE IF (MOSS .EQ. 0 .OR. ISTATC .NE. 1) GO TO 150 C If ISTATE = 1 and MOSS .ne. 0, restore Y from YH. -------------------- DO 145 I = 1,N Y(I) = YH(I) 145 CONTINUE 150 NNZ = IWK(IPIAN+N) - 1 LENIGP = 0 IPIGP = IPJAN + NNZ IF (MITER .NE. 2) GO TO 160 C C Compute grouping of column indices (MITER = 2). ---------------------- MAXG = NP1 IPJGP = IPJAN + NNZ IBJGP = IPJGP - 1 IPIGP = IPJGP + N IPTT1 = IPIGP + NP1 IPTT2 = IPTT1 + N LREQ = IPTT2 + N - 1 IF (LREQ .GT. LIWK) GO TO 220 CALL JGROUP (N, IWK(IPIAN), IWK(IPJAN), MAXG, NGP, IWK(IPIGP), 1 IWK(IPJGP), IWK(IPTT1), IWK(IPTT2), IER) IF (IER .NE. 0) GO TO 220 LENIGP = NGP + 1 C C Compute new ordering of rows/columns of Jacobian. -------------------- 160 IPR = IPIGP + LENIGP IPC = IPR IPIC = IPC + N IPISP = IPIC + N IPRSP = (IPISP - 2)/LRAT + 2 IESP = LENWK + 1 - IPRSP IF (IESP .LT. 0) GO TO 230 IBR = IPR - 1 DO 170 I = 1,N IWK(IBR+I) = I 170 CONTINUE NSP = LIWK + 1 - IPISP CALL ODRV (N, IWK(IPIAN), IWK(IPJAN), WK, IWK(IPR), IWK(IPIC), 1 NSP, IWK(IPISP), 1, IYS) IF (IYS .EQ. 11*N+1) GO TO 240 IF (IYS .NE. 0) GO TO 230 C C Reorder JAN and do symbolic LU factorization of matrix. -------------- IPA = LENWK + 1 - NNZ NSP = IPA - IPRSP LREQ = MAX(12*N/LRAT, 6*N/LRAT+2*N+NNZ) + 3 LREQ = LREQ + IPRSP - 1 + NNZ IF (LREQ .GT. LENWK) GO TO 250 IBA = IPA - 1 DO 180 I = 1,NNZ WK(IBA+I) = 0.0D0 180 CONTINUE IPISP = LRAT*(IPRSP - 1) + 1 CALL CDRV (N,IWK(IPR),IWK(IPC),IWK(IPIC),IWK(IPIAN),IWK(IPJAN), 1 WK(IPA),WK(IPA),WK(IPA),NSP,IWK(IPISP),WK(IPRSP),IESP,5,IYS) LREQ = LENWK - IESP IF (IYS .EQ. 10*N+1) GO TO 250 IF (IYS .NE. 0) GO TO 260 IPIL = IPISP IPIU = IPIL + 2*N + 1 NZU = IWK(IPIL+N) - IWK(IPIL) NZL = IWK(IPIU+N) - IWK(IPIU) IF (LRAT .GT. 1) GO TO 190 CALL ADJLR (N, IWK(IPISP), LDIF) LREQ = LREQ + LDIF 190 CONTINUE IF (LRAT .EQ. 2 .AND. NNZ .EQ. N) LREQ = LREQ + 1 NSP = NSP + LREQ - LENWK IPA = LREQ + 1 - NNZ IBA = IPA - 1 IPPER = 0 RETURN C 210 IPPER = -1 LREQ = 2 + (2*N + 1)/LRAT LREQ = MAX(LENWK+1,LREQ) RETURN C 220 IPPER = -2 LREQ = (LREQ - 1)/LRAT + 1 RETURN C 230 IPPER = -3 CALL CNTNZU (N, IWK(IPIAN), IWK(IPJAN), NZSUT) LREQ = LENWK - IESP + (3*N + 4*NZSUT - 1)/LRAT + 1 RETURN C 240 IPPER = -4 RETURN C 250 IPPER = -5 RETURN C 260 IPPER = -6 LREQ = LENWK RETURN C----------------------- End of Subroutine DPREP ----------------------- END *DECK JGROUP SUBROUTINE JGROUP (N,IA,JA,MAXG,NGRP,IGP,JGP,INCL,JDONE,IER) INTEGER N, IA, JA, MAXG, NGRP, IGP, JGP, INCL, JDONE, IER DIMENSION IA(*), JA(*), IGP(*), JGP(*), INCL(*), JDONE(*) C----------------------------------------------------------------------- C This subroutine constructs groupings of the column indices of C the Jacobian matrix, used in the numerical evaluation of the C Jacobian by finite differences. C C Input: C N = the order of the matrix. C IA,JA = sparse structure descriptors of the matrix by rows. C MAXG = length of available storage in the IGP array. C C Output: C NGRP = number of groups. C JGP = array of length N containing the column indices by groups. C IGP = pointer array of length NGRP + 1 to the locations in JGP C of the beginning of each group. C IER = error indicator. IER = 0 if no error occurred, or 1 if C MAXG was insufficient. C C INCL and JDONE are working arrays of length N. C----------------------------------------------------------------------- INTEGER I, J, K, KMIN, KMAX, NCOL, NG C IER = 0 DO 10 J = 1,N JDONE(J) = 0 10 CONTINUE NCOL = 1 DO 60 NG = 1,MAXG IGP(NG) = NCOL DO 20 I = 1,N INCL(I) = 0 20 CONTINUE DO 50 J = 1,N C Reject column J if it is already in a group.-------------------------- IF (JDONE(J) .EQ. 1) GO TO 50 KMIN = IA(J) KMAX = IA(J+1) - 1 DO 30 K = KMIN,KMAX C Reject column J if it overlaps any column already in this group.------ I = JA(K) IF (INCL(I) .EQ. 1) GO TO 50 30 CONTINUE C Accept column J into group NG.---------------------------------------- JGP(NCOL) = J NCOL = NCOL + 1 JDONE(J) = 1 DO 40 K = KMIN,KMAX I = JA(K) INCL(I) = 1 40 CONTINUE 50 CONTINUE C Stop if this group is empty (grouping is complete).------------------- IF (NCOL .EQ. IGP(NG)) GO TO 70 60 CONTINUE C Error return if not all columns were chosen (MAXG too small).--------- IF (NCOL .LE. N) GO TO 80 NG = MAXG 70 NGRP = NG - 1 RETURN 80 IER = 1 RETURN C----------------------- End of Subroutine JGROUP ---------------------- END *DECK ADJLR SUBROUTINE ADJLR (N, ISP, LDIF) INTEGER N, ISP, LDIF DIMENSION ISP(*) C----------------------------------------------------------------------- C This routine computes an adjustment, LDIF, to the required C integer storage space in IWK (sparse matrix work space). C It is called only if the word length ratio is LRAT = 1. C This is to account for the possibility that the symbolic LU phase C may require more storage than the numerical LU and solution phases. C----------------------------------------------------------------------- INTEGER IP, JLMAX, JUMAX, LNFC, LSFC, NZLU C IP = 2*N + 1 C Get JLMAX = IJL(N) and JUMAX = IJU(N) (sizes of JL and JU). ---------- JLMAX = ISP(IP) JUMAX = ISP(IP+IP) C NZLU = (size of L) + (size of U) = (IL(N+1)-IL(1)) + (IU(N+1)-IU(1)). NZLU = ISP(N+1) - ISP(1) + ISP(IP+N+1) - ISP(IP+1) LSFC = 12*N + 3 + 2*MAX(JLMAX,JUMAX) LNFC = 9*N + 2 + JLMAX + JUMAX + NZLU LDIF = MAX(0, LSFC - LNFC) RETURN C----------------------- End of Subroutine ADJLR ----------------------- END *DECK CNTNZU SUBROUTINE CNTNZU (N, IA, JA, NZSUT) INTEGER N, IA, JA, NZSUT DIMENSION IA(*), JA(*) C----------------------------------------------------------------------- C This routine counts the number of nonzero elements in the strict C upper triangle of the matrix M + M(transpose), where the sparsity C structure of M is given by pointer arrays IA and JA. C This is needed to compute the storage requirements for the C sparse matrix reordering operation in ODRV. C----------------------------------------------------------------------- INTEGER II, JJ, J, JMIN, JMAX, K, KMIN, KMAX, NUM C NUM = 0 DO 50 II = 1,N JMIN = IA(II) JMAX = IA(II+1) - 1 IF (JMIN .GT. JMAX) GO TO 50 DO 40 J = JMIN,JMAX IF (JA(J) - II .LT. 0) THEN GOTO 10 ELSE IF (JA(J) - II .EQ. 0) THEN GOTO 40 ElSE GOTO 30 ENDIF C IF (JA(J) - II) 10, 40, 30 10 JJ =JA(J) KMIN = IA(JJ) KMAX = IA(JJ+1) - 1 IF (KMIN .GT. KMAX) GO TO 30 DO 20 K = KMIN,KMAX IF (JA(K) .EQ. II) GO TO 40 20 CONTINUE 30 NUM = NUM + 1 40 CONTINUE 50 CONTINUE NZSUT = NUM RETURN C----------------------- End of Subroutine CNTNZU ---------------------- END *DECK DPRJS SUBROUTINE DPRJS (NEQ,Y,YH,NYH,EWT,FTEM,SAVF,WK,IWK,F,JAC, & rpar,ipar) EXTERNAL F,JAC CKS: added rpar,ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, NYH, IWK DOUBLE PRECISION Y, YH, EWT, FTEM, SAVF, WK DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), 1 WK(*), IWK(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLSS01/ CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH, 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU INTEGER I, IMUL, J, JJ, JOK, JMAX, JMIN, K, KMAX, KMIN, NG DOUBLE PRECISION CON, DI, FAC, HL0, PIJ, R, R0, RCON, RCONT, 1 SRUR, DVNORM C----------------------------------------------------------------------- C DPRJS is called to compute and process the matrix C P = I - H*EL(1)*J , where J is an approximation to the Jacobian. C J is computed by columns, either by the user-supplied routine JAC C if MITER = 1, or by finite differencing if MITER = 2. C if MITER = 3, a diagonal approximation to J is used. C if MITER = 1 or 2, and if the existing value of the Jacobian C (as contained in P) is considered acceptable, then a new value of C P is reconstructed from the old value. In any case, when MITER C is 1 or 2, the P matrix is subjected to LU decomposition in CDRV. C P and its LU decomposition are stored (separately) in WK. C C In addition to variables described previously, communication C with DPRJS uses the following: C Y = array containing predicted values on entry. C FTEM = work array of length N (ACOR in DSTODE). C SAVF = array containing f evaluated at predicted y. C WK = real work space for matrices. On output it contains the C inverse diagonal matrix if MITER = 3, and P and its sparse C LU decomposition if MITER is 1 or 2. C Storage of matrix elements starts at WK(3). C WK also contains the following matrix-related data: C WK(1) = SQRT(UROUND), used in numerical Jacobian increments. C WK(2) = H*EL0, saved for later use if MITER = 3. C IWK = integer work space for matrix-related data, assumed to C be equivalenced to WK. In addition, WK(IPRSP) and IWK(IPISP) C are assumed to have identical locations. C EL0 = EL(1) (input). C IERPJ = output error flag (in Common). C = 0 if no error. C = 1 if zero pivot found in CDRV. C = 2 if a singular matrix arose with MITER = 3. C = -1 if insufficient storage for CDRV (should not occur here). C = -2 if other error found in CDRV (should not occur here). C JCUR = output flag showing status of (approximate) Jacobian matrix: C = 1 to indicate that the Jacobian is now current, or C = 0 to indicate that a saved value was used. C This routine also uses other variables in Common. C----------------------------------------------------------------------- HL0 = H*EL0 CON = -HL0 IF (MITER .EQ. 3) GO TO 300 C See whether J should be reevaluated (JOK = 0) or not (JOK = 1). ------ JOK = 1 IF (NST .EQ. 0 .OR. NST .GE. NSLJ+MSBJ) JOK = 0 IF (ICF .EQ. 1 .AND. ABS(RC - 1.0D0) .LT. CCMXJ) JOK = 0 IF (ICF .EQ. 2) JOK = 0 IF (JOK .EQ. 1) GO TO 250 C C MITER = 1 or 2, and the Jacobian is to be reevaluated. --------------- 20 JCUR = 1 NJE = NJE + 1 NSLJ = NST IPLOST = 0 CONMIN = ABS(CON) IF (MITER .EQ. 1) THEN GOTO 100 ELSE IF (MITER .EQ. 2) THEN GOTO 200 ENDIF C GO TO (100, 200), MITER C C If MITER = 1, call JAC, multiply by scalar, and add identity. -------- 100 CONTINUE KMIN = IWK(IPIAN) DO 130 J = 1, N KMAX = IWK(IPIAN+J) - 1 DO 110 I = 1,N FTEM(I) = 0.0D0 110 CONTINUE CALL JAC (NEQ, TN, Y, J, IWK(IPIAN), IWK(IPJAN), FTEM, & rpar,ipar) DO 120 K = KMIN, KMAX I = IWK(IBJAN+K) WK(IBA+K) = FTEM(I)*CON IF (I .EQ. J) WK(IBA+K) = WK(IBA+K) + 1.0D0 120 CONTINUE KMIN = KMAX + 1 130 CONTINUE GO TO 290 C C If MITER = 2, make NGP calls to F to approximate J and P. ------------ 200 CONTINUE FAC = DVNORM(N, SAVF, EWT) R0 = 1000.0D0 * ABS(H) * UROUND * N * FAC IF (R0 .EQ. 0.0D0) R0 = 1.0D0 SRUR = WK(1) JMIN = IWK(IPIGP) DO 240 NG = 1,NGP JMAX = IWK(IPIGP+NG) - 1 DO 210 J = JMIN,JMAX JJ = IWK(IBJGP+J) R = MAX(SRUR*ABS(Y(JJ)),R0/EWT(JJ)) Y(JJ) = Y(JJ) + R 210 CONTINUE CKS CALL F (NEQ, TN, Y, FTEM, rpar, ipar) DO 230 J = JMIN,JMAX JJ = IWK(IBJGP+J) Y(JJ) = YH(JJ,1) R = MAX(SRUR*ABS(Y(JJ)),R0/EWT(JJ)) FAC = -HL0/R KMIN =IWK(IBIAN+JJ) KMAX =IWK(IBIAN+JJ+1) - 1 DO 220 K = KMIN,KMAX I = IWK(IBJAN+K) WK(IBA+K) = (FTEM(I) - SAVF(I))*FAC IF (I .EQ. JJ) WK(IBA+K) = WK(IBA+K) + 1.0D0 220 CONTINUE 230 CONTINUE JMIN = JMAX + 1 240 CONTINUE NFE = NFE + NGP GO TO 290 C C If JOK = 1, reconstruct new P from old P. ---------------------------- 250 JCUR = 0 RCON = CON/CON0 RCONT = ABS(CON)/CONMIN IF (RCONT .GT. RBIG .AND. IPLOST .EQ. 1) GO TO 20 KMIN = IWK(IPIAN) DO 275 J = 1,N KMAX = IWK(IPIAN+J) - 1 DO 270 K = KMIN,KMAX I = IWK(IBJAN+K) PIJ = WK(IBA+K) IF (I .NE. J) GO TO 260 PIJ = PIJ - 1.0D0 IF (ABS(PIJ) .GE. PSMALL) GO TO 260 IPLOST = 1 CONMIN = MIN(ABS(CON0),CONMIN) 260 PIJ = PIJ*RCON IF (I .EQ. J) PIJ = PIJ + 1.0D0 WK(IBA+K) = PIJ 270 CONTINUE KMIN = KMAX + 1 275 CONTINUE C C Do numerical factorization of P matrix. ------------------------------ 290 NLU = NLU + 1 CON0 = CON IERPJ = 0 DO 295 I = 1,N FTEM(I) = 0.0D0 295 CONTINUE CALL CDRV (N,IWK(IPR),IWK(IPC),IWK(IPIC),IWK(IPIAN),IWK(IPJAN), 1 WK(IPA),FTEM,FTEM,NSP,IWK(IPISP),WK(IPRSP),IESP,2,IYS) IF (IYS .EQ. 0) RETURN IMUL = (IYS - 1)/N IERPJ = -2 IF (IMUL .EQ. 8) IERPJ = 1 IF (IMUL .EQ. 10) IERPJ = -1 RETURN C C If MITER = 3, construct a diagonal approximation to J and P. --------- 300 CONTINUE JCUR = 1 NJE = NJE + 1 WK(2) = HL0 IERPJ = 0 R = EL0*0.1D0 DO 310 I = 1,N Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) 310 CONTINUE CKS CALL F (NEQ, TN, Y, WK(3), rpar, ipar) NFE = NFE + 1 DO 320 I = 1,N R0 = H*SAVF(I) - YH(I,2) DI = 0.1D0*R0 - H*(WK(I+2) - SAVF(I)) WK(I+2) = 1.0D0 IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 IF (ABS(DI) .EQ. 0.0D0) GO TO 330 WK(I+2) = 0.1D0*R0/DI 320 CONTINUE RETURN 330 IERPJ = 2 RETURN C----------------------- End of Subroutine DPRJS ----------------------- END *DECK DSOLSS SUBROUTINE DSOLSS (WK, IWK, X, TEM) INTEGER IWK DOUBLE PRECISION WK, X, TEM DIMENSION WK(*), IWK(*), X(*), TEM(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION RLSS COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLSS01/ RLSS(6), 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU INTEGER I DOUBLE PRECISION DI, HL0, PHL0, R C----------------------------------------------------------------------- C This routine manages the solution of the linear system arising from C a chord iteration. It is called if MITER .ne. 0. C If MITER is 1 or 2, it calls CDRV to accomplish this. C If MITER = 3 it updates the coefficient H*EL0 in the diagonal C matrix, and then computes the solution. C communication with DSOLSS uses the following variables: C WK = real work space containing the inverse diagonal matrix if C MITER = 3 and the LU decomposition of the matrix otherwise. C Storage of matrix elements starts at WK(3). C WK also contains the following matrix-related data: C WK(1) = SQRT(UROUND) (not used here), C WK(2) = HL0, the previous value of H*EL0, used if MITER = 3. C IWK = integer work space for matrix-related data, assumed to C be equivalenced to WK. In addition, WK(IPRSP) and IWK(IPISP) C are assumed to have identical locations. C X = the right-hand side vector on input, and the solution vector C on output, of length N. C TEM = vector of work space of length N, not used in this version. C IERSL = output flag (in Common). C IERSL = 0 if no trouble occurred. C IERSL = -1 if CDRV returned an error flag (MITER = 1 or 2). C This should never occur and is considered fatal. C IERSL = 1 if a singular matrix arose with MITER = 3. C This routine also uses other variables in Common. C----------------------------------------------------------------------- IERSL = 0 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN GOTO 100 ELSE IF (MITER .EQ. 3) THEN GOTO 300 ENDIF C GO TO (100, 100, 300), MITER 100 CALL CDRV (N,IWK(IPR),IWK(IPC),IWK(IPIC),IWK(IPIAN),IWK(IPJAN), 1 WK(IPA),X,X,NSP,IWK(IPISP),WK(IPRSP),IESP,4,IERSL) IF (IERSL .NE. 0) IERSL = -1 RETURN C 300 PHL0 = WK(2) HL0 = H*EL0 WK(2) = HL0 IF (HL0 .EQ. PHL0) GO TO 330 R = HL0/PHL0 DO 320 I = 1,N DI = 1.0D0 - R*(1.0D0 - 1.0D0/WK(I+2)) IF (ABS(DI) .EQ. 0.0D0) GO TO 390 WK(I+2) = 1.0D0/DI 320 CONTINUE 330 DO 340 I = 1,N X(I) = WK(I+2)*X(I) 340 CONTINUE RETURN 390 IERSL = 1 RETURN C C----------------------- End of Subroutine DSOLSS ---------------------- END *DECK DSRCMS *DECK ODRV subroutine odrv * (n, ia,ja,a, p,ip, nsp,isp, path, flag) c 5/2/83 c*********************************************************************** c odrv -- driver for sparse matrix reordering routines c*********************************************************************** c c description c c odrv finds a minimum degree ordering of the rows and columns c of a matrix m stored in (ia,ja,a) format (see below). for the c reordered matrix, the work and storage required to perform c gaussian elimination is (usually) significantly less. c c note.. odrv and its subordinate routines have been modified to c compute orderings for general matrices, not necessarily having any c symmetry. the miminum degree ordering is computed for the c structure of the symmetric matrix m + m-transpose. c modifications to the original odrv module have been made in c the coding in subroutine mdi, and in the initial comments in c subroutines odrv and md. c c if only the nonzero entries in the upper triangle of m are being c stored, then odrv symmetrically reorders (ia,ja,a), (optionally) c with the diagonal entries placed first in each row. this is to c ensure that if m(i,j) will be in the upper triangle of m with c respect to the new ordering, then m(i,j) is stored in row i (and c thus m(j,i) is not stored), whereas if m(i,j) will be in the c strict lower triangle of m, then m(j,i) is stored in row j (and c thus m(i,j) is not stored). c c c storage of sparse matrices c c the nonzero entries of the matrix m are stored row-by-row in the c array a. to identify the individual nonzero entries in each row, c we need to know in which column each entry lies. these column c indices are stored in the array ja. i.e., if a(k) = m(i,j), then c ja(k) = j. to identify the individual rows, we need to know where c each row starts. these row pointers are stored in the array ia. c i.e., if m(i,j) is the first nonzero entry (stored) in the i-th row c and a(k) = m(i,j), then ia(i) = k. moreover, ia(n+1) points to c the first location following the last element in the last row. c thus, the number of entries in the i-th row is ia(i+1) - ia(i), c the nonzero entries in the i-th row are stored consecutively in c c a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), c c and the corresponding column indices are stored consecutively in c c ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). c c when the coefficient matrix is symmetric, only the nonzero entries c in the upper triangle need be stored. for example, the matrix c c ( 1 0 2 3 0 ) c ( 0 4 0 0 0 ) c m = ( 2 0 5 6 0 ) c ( 3 0 6 7 8 ) c ( 0 0 0 8 9 ) c c could be stored as c c - 1 2 3 4 5 6 7 8 9 10 11 12 13 c ---+-------------------------------------- c ia - 1 4 5 8 12 14 c ja - 1 3 4 2 1 3 4 1 3 4 5 4 5 c a - 1 2 3 4 2 5 6 3 6 7 8 8 9 c c or (symmetrically) as c c - 1 2 3 4 5 6 7 8 9 c ---+-------------------------- c ia - 1 4 5 7 9 10 c ja - 1 3 4 2 3 4 4 5 5 c a - 1 2 3 4 5 6 7 8 9 . c c c parameters c c n - order of the matrix c c ia - integer one-dimensional array containing pointers to delimit c rows in ja and a. dimension = n+1 c c ja - integer one-dimensional array containing the column indices c corresponding to the elements of a. dimension = number of c nonzero entries in (the upper triangle of) m c c a - real one-dimensional array containing the nonzero entries in c (the upper triangle of) m, stored by rows. dimension = c number of nonzero entries in (the upper triangle of) m c c p - integer one-dimensional array used to return the permutation c of the rows and columns of m corresponding to the minimum c degree ordering. dimension = n c c ip - integer one-dimensional array used to return the inverse of c the permutation returned in p. dimension = n c c nsp - declared dimension of the one-dimensional array isp. nsp c must be at least 3n+4k, where k is the number of nonzeroes c in the strict upper triangle of m c c isp - integer one-dimensional array used for working storage. c dimension = nsp c c path - integer path specification. values and their meanings are - c 1 find minimum degree ordering only c 2 find minimum degree ordering and reorder symmetrically c stored matrix (used when only the nonzero entries in c the upper triangle of m are being stored) c 3 reorder symmetrically stored matrix as specified by c input permutation (used when an ordering has already c been determined and only the nonzero entries in the c upper triangle of m are being stored) c 4 same as 2 but put diagonal entries at start of each row c 5 same as 3 but put diagonal entries at start of each row c c flag - integer error flag. values and their meanings are - c 0 no errors detected c 9n+k insufficient storage in md c 10n+1 insufficient storage in odrv c 11n+1 illegal path specification c c c conversion from real to double precision c c change the real declarations in odrv and sro to double precision c declarations. c c----------------------------------------------------------------------- c integer ia(*), ja(*), p(*), ip(*), isp(*), path, flag, * v, l, head, tmp, q c... real a(*) double precision a(*) logical dflag c c----initialize error flag and validate path specification flag = 0 if (path.lt.1 .or. 5.lt.path) go to 111 c c----allocate storage and find minimum degree ordering if ((path-1) * (path-2) * (path-4) .ne. 0) go to 1 max = (nsp-n)/2 v = 1 l = v + max head = l + max next = head + n if (max.lt.n) go to 110 c call md * (n, ia,ja, max,isp(v),isp(l), isp(head),p,ip, isp(v), flag) if (flag.ne.0) go to 100 c c----allocate storage and symmetrically reorder matrix 1 if ((path-2) * (path-3) * (path-4) * (path-5) .ne. 0) go to 2 tmp = (nsp+1) - n q = tmp - (ia(n+1)-1) if (q.lt.1) go to 110 c dflag = path.eq.4 .or. path.eq.5 call sro * (n, ip, ia, ja, a, isp(tmp), isp(q), dflag) c 2 return c c ** error -- error detected in md 100 return c ** error -- insufficient storage 110 flag = 10*n + 1 return c ** error -- illegal path specified 111 flag = 11*n + 1 return end subroutine md * (n, ia,ja, max, v,l, head,last,next, mark, flag) c*********************************************************************** c md -- minimum degree algorithm (based on element model) c*********************************************************************** c c description c c md finds a minimum degree ordering of the rows and columns of a c general sparse matrix m stored in (ia,ja,a) format. c when the structure of m is nonsymmetric, the ordering is that c obtained for the symmetric matrix m + m-transpose. c c c additional parameters c c max - declared dimension of the one-dimensional arrays v and l. c max must be at least n+2k, where k is the number of c nonzeroes in the strict upper triangle of m + m-transpose c c v - integer one-dimensional work array. dimension = max c c l - integer one-dimensional work array. dimension = max c c head - integer one-dimensional work array. dimension = n c c last - integer one-dimensional array used to return the permutation c of the rows and columns of m corresponding to the minimum c degree ordering. dimension = n c c next - integer one-dimensional array used to return the inverse of c the permutation returned in last. dimension = n c c mark - integer one-dimensional work array (may be the same as v). c dimension = n c c flag - integer error flag. values and their meanings are - c 0 no errors detected c 9n+k insufficient storage in md c c c definitions of internal parameters c c ---------+--------------------------------------------------------- c v(s) - value field of list entry c ---------+--------------------------------------------------------- c l(s) - link field of list entry (0 =) end of list) c ---------+--------------------------------------------------------- c l(vi) - pointer to element list of uneliminated vertex vi c ---------+--------------------------------------------------------- c l(ej) - pointer to boundary list of active element ej c ---------+--------------------------------------------------------- c head(d) - vj =) vj head of d-list d c - 0 =) no vertex in d-list d c c c - vi uneliminated vertex c - vi in ek - vi not in ek c ---------+-----------------------------+--------------------------- c next(vi) - undefined but nonnegative - vj =) vj next in d-list c - - 0 =) vi tail of d-list c ---------+-----------------------------+--------------------------- c last(vi) - (not set until mdp) - -d =) vi head of d-list d c --vk =) compute degree - vj =) vj last in d-list c - ej =) vi prototype of ej - 0 =) vi not in any d-list c - 0 =) do not compute degree - c ---------+-----------------------------+--------------------------- c mark(vi) - mark(vk) - nonneg. tag .lt. mark(vk) c c c - vi eliminated vertex c - ei active element - otherwise c ---------+-----------------------------+--------------------------- c next(vi) - -j =) vi was j-th vertex - -j =) vi was j-th vertex c - to be eliminated - to be eliminated c ---------+-----------------------------+--------------------------- c last(vi) - m =) size of ei = m - undefined c ---------+-----------------------------+--------------------------- c mark(vi) - -m =) overlap count of ei - undefined c - with ek = m - c - otherwise nonnegative tag - c - .lt. mark(vk) - c c----------------------------------------------------------------------- c integer ia(*), ja(*), v(*), l(*), head(*), last(*), next(*), * mark(*), flag, tag, dmin, vk,ek, tail equivalence (vk,ek) c c----initialization tag = 0 call mdi * (n, ia,ja, max,v,l, head,last,next, mark,tag, flag) if (flag.ne.0) return c k = 0 dmin = 1 c c----while k .lt. n do 1 if (k.ge.n) go to 4 c c------search for vertex of minimum degree 2 if (head(dmin).gt.0) go to 3 dmin = dmin + 1 go to 2 c c------remove vertex vk of minimum degree from degree list 3 vk = head(dmin) head(dmin) = next(vk) if (head(dmin).gt.0) last(head(dmin)) = -dmin c c------number vertex vk, adjust tag, and tag vk k = k+1 next(vk) = -k last(ek) = dmin - 1 tag = tag + last(ek) mark(vk) = tag c c------form element ek from uneliminated neighbors of vk call mdm * (vk,tail, v,l, last,next, mark) c c------purge inactive elements and do mass elimination call mdp * (k,ek,tail, v,l, head,last,next, mark) c c------update degrees of uneliminated vertices in ek call mdu * (ek,dmin, v,l, head,last,next, mark) c go to 1 c c----generate inverse permutation from permutation 4 do 5 k=1,n next(k) = -next(k) last(next(k)) = k 5 continue c return end subroutine mdi * (n, ia,ja, max,v,l, head,last,next, mark,tag, flag) c*********************************************************************** c mdi -- initialization c*********************************************************************** integer ia(*), ja(*), v(*), l(*), head(*), last(*), next(*), * mark(*), tag, flag, sfs, vi,dvi, vj c c----initialize degrees, element lists, and degree lists do 1 vi=1,n mark(vi) = 1 l(vi) = 0 head(vi) = 0 1 continue sfs = n+1 c c----create nonzero structure c----for each nonzero entry a(vi,vj) do 6 vi=1,n jmin = ia(vi) jmax = ia(vi+1) - 1 if (jmin.gt.jmax) go to 6 do 5 j=jmin,jmax vj = ja(j) if (vj-vi .LT. 0) then goto 2 else if (vj-vi .EQ. 0) then goto 5 else goto 4 endif c if (vj-vi) 2, 5, 4 c c------if a(vi,vj) is in strict lower triangle c------check for previous occurrence of a(vj,vi) 2 lvk = vi kmax = mark(vi) - 1 if (kmax .eq. 0) go to 4 do 3 k=1,kmax lvk = l(lvk) if (v(lvk).eq.vj) go to 5 3 continue c----for unentered entries a(vi,vj) 4 if (sfs.ge.max) go to 101 c c------enter vj in element list for vi mark(vi) = mark(vi) + 1 v(sfs) = vj l(sfs) = l(vi) l(vi) = sfs sfs = sfs+1 c c------enter vi in element list for vj mark(vj) = mark(vj) + 1 v(sfs) = vi l(sfs) = l(vj) l(vj) = sfs sfs = sfs+1 5 continue 6 continue c c----create degree lists and initialize mark vector do 7 vi=1,n dvi = mark(vi) next(vi) = head(dvi) head(dvi) = vi last(vi) = -dvi nextvi = next(vi) if (nextvi.gt.0) last(nextvi) = vi mark(vi) = tag 7 continue c return c c ** error- insufficient storage 101 flag = 9*n + vi return end subroutine mdm * (vk,tail, v,l, last,next, mark) c*********************************************************************** c mdm -- form element from uneliminated neighbors of vk c*********************************************************************** integer vk, tail, v(*), l(*), last(*), next(*), mark(*), * tag, s,ls,vs,es, b,lb,vb, blp,blpmax equivalence (vs, es) c c----initialize tag and list of uneliminated neighbors tag = mark(vk) tail = vk c c----for each vertex/element vs/es in element list of vk ls = l(vk) 1 s = ls if (s.eq.0) go to 5 ls = l(s) vs = v(s) if (next(vs).lt.0) go to 2 c c------if vs is uneliminated vertex, then tag and append to list of c------uneliminated neighbors mark(vs) = tag l(tail) = s tail = s go to 4 c c------if es is active element, then ... c--------for each vertex vb in boundary list of element es 2 lb = l(es) blpmax = last(es) do 3 blp=1,blpmax b = lb lb = l(b) vb = v(b) c c----------if vb is untagged vertex, then tag and append to list of c----------uneliminated neighbors if (mark(vb).ge.tag) go to 3 mark(vb) = tag l(tail) = b tail = b 3 continue c c--------mark es inactive mark(es) = tag c 4 go to 1 c c----terminate list of uneliminated neighbors 5 l(tail) = 0 c return end subroutine mdp * (k,ek,tail, v,l, head,last,next, mark) c*********************************************************************** c mdp -- purge inactive elements and do mass elimination c*********************************************************************** integer ek, tail, v(*), l(*), head(*), last(*), next(*), * mark(*), tag, free, li,vi,lvi,evi, s,ls,es, ilp,ilpmax c karline initialised free to avoid warning free = 1 c----initialize tag tag = mark(ek) c c----for each vertex vi in ek li = ek ilpmax = last(ek) if (ilpmax.le.0) go to 12 do 11 ilp=1,ilpmax i = li li = l(i) vi = v(li) c c------remove vi from degree list if (last(vi).eq.0) go to 3 if (last(vi).gt.0) go to 1 head(-last(vi)) = next(vi) go to 2 1 next(last(vi)) = next(vi) 2 if (next(vi).gt.0) last(next(vi)) = last(vi) c c------remove inactive items from element list of vi 3 ls = vi 4 s = ls ls = l(s) if (ls.eq.0) go to 6 es = v(ls) if (mark(es).lt.tag) go to 5 free = ls l(s) = l(ls) ls = s 5 go to 4 c c------if vi is interior vertex, then remove from list and eliminate 6 lvi = l(vi) if (lvi.ne.0) go to 7 l(i) = l(li) li = i c k = k+1 next(vi) = -k last(ek) = last(ek) - 1 go to 11 c c------else ... c--------classify vertex vi 7 if (l(lvi).ne.0) go to 9 evi = v(lvi) if (next(evi).ge.0) go to 9 if (mark(evi).lt.0) go to 8 c c----------if vi is prototype vertex, then mark as such, initialize c----------overlap count for corresponding element, and move vi to end c----------of boundary list last(vi) = evi mark(evi) = -1 l(tail) = li tail = li l(i) = l(li) li = i go to 10 c c----------else if vi is duplicate vertex, then mark as such and adjust c----------overlap count for corresponding element 8 last(vi) = 0 mark(evi) = mark(evi) - 1 go to 10 c c----------else mark vi to compute degree 9 last(vi) = -ek c c--------insert ek in element list of vi 10 v(free) = ek l(free) = l(vi) l(vi) = free 11 continue c c----terminate boundary list 12 l(tail) = 0 c return end subroutine mdu * (ek,dmin, v,l, head,last,next, mark) c*********************************************************************** c mdu -- update degrees of uneliminated vertices in ek c*********************************************************************** integer ek, dmin, v(*), l(*), head(*), last(*), next(*), * mark(*), tag, vi,evi,dvi, s,vs,es, b,vb, ilp,ilpmax, * blp,blpmax equivalence (vs, es) c c----initialize tag tag = mark(ek) - last(ek) c c----for each vertex vi in ek i = ek ilpmax = last(ek) if (ilpmax.le.0) go to 11 do 10 ilp=1,ilpmax i = l(i) vi = v(i) if (last(vi) .LT. 0) then goto 1 else if (last(vi) .EQ. 0) then goto 10 else if (last(vi) .GT. 0) then goto 8 endif c if (last(vi)) 1, 10, 8 c c------if vi neither prototype nor duplicate vertex, then merge elements c------to compute degree 1 tag = tag + 1 dvi = last(ek) c c--------for each vertex/element vs/es in element list of vi s = l(vi) 2 s = l(s) if (s.eq.0) go to 9 vs = v(s) if (next(vs).lt.0) go to 3 c c----------if vs is uneliminated vertex, then tag and adjust degree mark(vs) = tag dvi = dvi + 1 go to 5 c c----------if es is active element, then expand c------------check for outmatched vertex 3 if (mark(es).lt.0) go to 6 c c------------for each vertex vb in es b = es blpmax = last(es) do 4 blp=1,blpmax b = l(b) vb = v(b) c c--------------if vb is untagged, then tag and adjust degree if (mark(vb).ge.tag) go to 4 mark(vb) = tag dvi = dvi + 1 4 continue c 5 go to 2 c c------else if vi is outmatched vertex, then adjust overlaps but do not c------compute degree 6 last(vi) = 0 mark(es) = mark(es) - 1 7 s = l(s) if (s.eq.0) go to 10 es = v(s) if (mark(es).lt.0) mark(es) = mark(es) - 1 go to 7 c c------else if vi is prototype vertex, then calculate degree by c------inclusion/exclusion and reset overlap count 8 evi = last(vi) dvi = last(ek) + last(evi) + mark(evi) mark(evi) = 0 c c------insert vi in appropriate degree list 9 next(vi) = head(dvi) head(dvi) = vi last(vi) = -dvi if (next(vi).gt.0) last(next(vi)) = vi if (dvi.lt.dmin) dmin = dvi c 10 continue c 11 return end subroutine sro * (n, ip, ia,ja,a, q, r, dflag) c*********************************************************************** c sro -- symmetric reordering of sparse symmetric matrix c*********************************************************************** c c description c c the nonzero entries of the matrix m are assumed to be stored c symmetrically in (ia,ja,a) format (i.e., not both m(i,j) and m(j,i) c are stored if i ne j). c c sro does not rearrange the order of the rows, but does move c nonzeroes from one row to another to ensure that if m(i,j) will be c in the upper triangle of m with respect to the new ordering, then c m(i,j) is stored in row i (and thus m(j,i) is not stored), whereas c if m(i,j) will be in the strict lower triangle of m, then m(j,i) is c stored in row j (and thus m(i,j) is not stored). c c c additional parameters c c q - integer one-dimensional work array. dimension = n c c r - integer one-dimensional work array. dimension = number of c nonzero entries in the upper triangle of m c c dflag - logical variable. if dflag = .true., then store nonzero c diagonal elements at the beginning of the row c c----------------------------------------------------------------------- c integer ip(*), ia(*), ja(*), q(*), r(*) c... real a(*), ak double precision a(*), ak logical dflag c c c--phase 1 -- find row in which to store each nonzero c----initialize count of nonzeroes to be stored in each row do 1 i=1,n q(i) = 0 1 continue c c----for each nonzero element a(j) do 3 i=1,n jmin = ia(i) jmax = ia(i+1) - 1 if (jmin.gt.jmax) go to 3 do 2 j=jmin,jmax c c--------find row (=r(j)) and column (=ja(j)) in which to store a(j) ... k = ja(j) if (ip(k).lt.ip(i)) ja(j) = i if (ip(k).ge.ip(i)) k = i r(j) = k c c--------... and increment count of nonzeroes (=q(r(j)) in that row q(k) = q(k) + 1 2 continue 3 continue c c c--phase 2 -- find new ia and permutation to apply to (ja,a) c----determine pointers to delimit rows in permuted (ja,a) do 4 i=1,n ia(i+1) = ia(i) + q(i) q(i) = ia(i+1) 4 continue c c----determine where each (ja(j),a(j)) is stored in permuted (ja,a) c----for each nonzero element (in reverse order) ilast = 0 jmin = ia(1) jmax = ia(n+1) - 1 j = jmax do 6 jdummy=jmin,jmax i = r(j) if (.not.dflag .or. ja(j).ne.i .or. i.eq.ilast) go to 5 c c------if dflag, then put diagonal nonzero at beginning of row r(j) = ia(i) ilast = i go to 6 c c------put (off-diagonal) nonzero in last unused location in row 5 q(i) = q(i) - 1 r(j) = q(i) c j = j-1 6 continue c c c--phase 3 -- permute (ja,a) to upper triangular form (wrt new ordering) do 8 j=jmin,jmax 7 if (r(j).eq.j) go to 8 k = r(j) r(j) = r(k) r(k) = k jak = ja(k) ja(k) = ja(j) ja(j) = jak ak = a(k) a(k) = a(j) a(j) = ak go to 7 8 continue c return end *DECK CDRV subroutine cdrv * (n, r,c,ic, ia,ja,a, b, z, nsp,isp,rsp,esp, path, flag) c*** subroutine cdrv c*** driver for subroutines for solving sparse nonsymmetric systems of c linear equations (compressed pointer storage) c c c parameters c class abbreviations are-- c n - integer variable c f - real variable c v - supplies a value to the driver c r - returns a result from the driver c i - used internally by the driver c a - array c c class - parameter c ------+---------- c - c the nonzero entries of the coefficient matrix m are stored c row-by-row in the array a. to identify the individual nonzero c entries in each row, we need to know in which column each entry c lies. the column indices which correspond to the nonzero entries c of m are stored in the array ja. i.e., if a(k) = m(i,j), then c ja(k) = j. in addition, we need to know where each row starts and c how long it is. the index positions in ja and a where the rows of c m begin are stored in the array ia. i.e., if m(i,j) is the first c nonzero entry (stored) in the i-th row and a(k) = m(i,j), then c ia(i) = k. moreover, the index in ja and a of the first location c following the last element in the last row is stored in ia(n+1). c thus, the number of entries in the i-th row is given by c ia(i+1) - ia(i), the nonzero entries of the i-th row are stored c consecutively in c a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), c and the corresponding column indices are stored consecutively in c ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). c for example, the 5 by 5 matrix c ( 1. 0. 2. 0. 0.) c ( 0. 3. 0. 0. 0.) c m = ( 0. 4. 5. 6. 0.) c ( 0. 0. 0. 7. 0.) c ( 0. 0. 0. 8. 9.) c would be stored as c - 1 2 3 4 5 6 7 8 9 c ---+-------------------------- c ia - 1 3 4 7 8 10 c ja - 1 3 2 2 3 4 4 4 5 c a - 1. 2. 3. 4. 5. 6. 7. 8. 9. . c c nv - n - number of variables/equations. c fva - a - nonzero entries of the coefficient matrix m, stored c - by rows. c - size = number of nonzero entries in m. c nva - ia - pointers to delimit the rows in a. c - size = n+1. c nva - ja - column numbers corresponding to the elements of a. c - size = size of a. c fva - b - right-hand side b. b and z can the same array. c - size = n. c fra - z - solution x. b and z can be the same array. c - size = n. c c the rows and columns of the original matrix m can be c reordered (e.g., to reduce fillin or ensure numerical stability) c before calling the driver. if no reordering is done, then set c r(i) = c(i) = ic(i) = i for i=1,...,n. the solution z is returned c in the original order. c if the columns have been reordered (i.e., c(i).ne.i for some c i), then the driver will call a subroutine (nroc) which rearranges c each row of ja and a, leaving the rows in the original order, but c placing the elements of each row in increasing order with respect c to the new ordering. if path.ne.1, then nroc is assumed to have c been called already. c c nva - r - ordering of the rows of m. c - size = n. c nva - c - ordering of the columns of m. c - size = n. c nva - ic - inverse of the ordering of the columns of m. i.e., c - ic(c(i)) = i for i=1,...,n. c - size = n. c c the solution of the system of linear equations is divided into c three stages -- c nsfc -- the matrix m is processed symbolically to determine where c fillin will occur during the numeric factorization. c nnfc -- the matrix m is factored numerically into the product ldu c of a unit lower triangular matrix l, a diagonal matrix c d, and a unit upper triangular matrix u, and the system c mx = b is solved. c nnsc -- the linear system mx = b is solved using the ldu c or factorization from nnfc. c nntc -- the transposed linear system mt x = b is solved using c the ldu factorization from nnf. c for several systems whose coefficient matrices have the same c nonzero structure, nsfc need be done only once (for the first c system). then nnfc is done once for each additional system. for c several systems with the same coefficient matrix, nsfc and nnfc c need be done only once (for the first system). then nnsc or nntc c is done once for each additional right-hand side. c c nv - path - path specification. values and their meanings are -- c - 1 perform nroc, nsfc, and nnfc. c - 2 perform nnfc only (nsfc is assumed to have been c - done in a manner compatible with the storage c - allocation used in the driver). c - 3 perform nnsc only (nsfc and nnfc are assumed to c - have been done in a manner compatible with the c - storage allocation used in the driver). c - 4 perform nntc only (nsfc and nnfc are assumed to c - have been done in a manner compatible with the c - storage allocation used in the driver). c - 5 perform nroc and nsfc. c c various errors are detected by the driver and the individual c subroutines. c c nr - flag - error flag. values and their meanings are -- c - 0 no errors detected c - n+k null row in a -- row = k c - 2n+k duplicate entry in a -- row = k c - 3n+k insufficient storage in nsfc -- row = k c - 4n+1 insufficient storage in nnfc c - 5n+k null pivot -- row = k c - 6n+k insufficient storage in nsfc -- row = k c - 7n+1 insufficient storage in nnfc c - 8n+k zero pivot -- row = k c - 10n+1 insufficient storage in cdrv c - 11n+1 illegal path specification c c working storage is needed for the factored form of the matrix c m plus various temporary vectors. the arrays isp and rsp should be c equivalenced. integer storage is allocated from the beginning of c isp and real storage from the end of rsp. c c nv - nsp - declared dimension of rsp. nsp generally must c - be larger than 8n+2 + 2k (where k = (number of c - nonzero entries in m)). c nvira - isp - integer working storage divided up into various arrays c - needed by the subroutines. isp and rsp should be c - equivalenced. c - size = lratio*nsp. c fvira - rsp - real working storage divided up into various arrays c - needed by the subroutines. isp and rsp should be c - equivalenced. c - size = nsp. c nr - esp - if sufficient storage was available to perform the c - symbolic factorization (nsfc), then esp is set to c - the amount of excess storage provided (negative if c - insufficient storage was available to perform the c - numeric factorization (nnfc)). c c c conversion to double precision c c to convert these routines for double precision arrays.. c (1) use the double precision declarations in place of the real c declarations in each subprogram, as given in comment cards. c (2) change the data-loaded value of the integer lratio c in subroutine cdrv, as indicated below. c (3) change e0 to d0 in the constants in statement number 10 c in subroutine nnfc and the line following that. c integer r(*), c(*), ic(*), ia(*), ja(*), isp(*), esp, path, * flag, d, u, q, row, tmp, ar, umax c real a(*), b(*), z(*), rsp(*) double precision a(*), b(*), z(*), rsp(*) c c set lratio equal to the ratio between the length of floating point c and integer array data. e. g., lratio = 1 for (real, integer), c lratio = 2 for (double precision, integer) c data lratio/2/ c if (path.lt.1 .or. 5.lt.path) go to 111 c******initialize and divide up temporary storage ******************* il = 1 ijl = il + (n+1) iu = ijl + n iju = iu + (n+1) irl = iju + n jrl = irl + n jl = jrl + n c c ****** reorder a if necessary, call nsfc if flag is set *********** if ((path-1) * (path-5) .ne. 0) go to 5 max = (lratio*nsp + 1 - jl) - (n+1) - 5*n jlmax = max/2 q = jl + jlmax ira = q + (n+1) jra = ira + n irac = jra + n iru = irac + n jru = iru + n jutmp = jru + n jumax = lratio*nsp + 1 - jutmp esp = max/lratio if (jlmax.le.0 .or. jumax.le.0) go to 110 c do 1 i=1,n if (c(i).ne.i) go to 2 1 continue go to 3 2 ar = nsp + 1 - n call nroc * (n, ic, ia,ja,a, isp(il), rsp(ar), isp(iu), flag) if (flag.ne.0) go to 100 c 3 call nsfc * (n, r, ic, ia,ja, * jlmax, isp(il), isp(jl), isp(ijl), * jumax, isp(iu), isp(jutmp), isp(iju), * isp(q), isp(ira), isp(jra), isp(irac), * isp(irl), isp(jrl), isp(iru), isp(jru), flag) if(flag .ne. 0) go to 100 c ****** move ju next to jl ***************************************** jlmax = isp(ijl+n-1) ju = jl + jlmax jumax = isp(iju+n-1) if (jumax.le.0) go to 5 do 4 j=1,jumax isp(ju+j-1) = isp(jutmp+j-1) 4 continue c c ****** call remaining subroutines ********************************* 5 jlmax = isp(ijl+n-1) ju = jl + jlmax jumax = isp(iju+n-1) l = (ju + jumax - 2 + lratio) / lratio + 1 lmax = isp(il+n) - 1 d = l + lmax u = d + n row = nsp + 1 - n tmp = row - n umax = tmp - u esp = umax - (isp(iu+n) - 1) c if ((path-1) * (path-2) .ne. 0) go to 6 if (umax.lt.0) go to 110 call nnfc * (n, r, c, ic, ia, ja, a, z, b, * lmax, isp(il), isp(jl), isp(ijl), rsp(l), rsp(d), * umax, isp(iu), isp(ju), isp(iju), rsp(u), * rsp(row), rsp(tmp), isp(irl), isp(jrl), flag) if(flag .ne. 0) go to 100 c 6 if ((path-3) .ne. 0) go to 7 call nnsc * (n, r, c, isp(il), isp(jl), isp(ijl), rsp(l), * rsp(d), isp(iu), isp(ju), isp(iju), rsp(u), * z, b, rsp(tmp)) c 7 if ((path-4) .ne. 0) go to 8 call nntc * (n, r, c, isp(il), isp(jl), isp(ijl), rsp(l), * rsp(d), isp(iu), isp(ju), isp(iju), rsp(u), * z, b, rsp(tmp)) 8 return c c ** error.. error detected in nroc, nsfc, nnfc, or nnsc 100 return c ** error.. insufficient storage 110 flag = 10*n + 1 return c ** error.. illegal path specification 111 flag = 11*n + 1 return end subroutine nroc (n, ic, ia, ja, a, jar, ar, p, flag) c c ---------------------------------------------------------------- c c yale sparse matrix package - nonsymmetric codes c solving the system of equations mx = b c c i. calling sequences c the coefficient matrix can be processed by an ordering routine c (e.g., to reduce fillin or ensure numerical stability) before using c the remaining subroutines. if no reordering is done, then set c r(i) = c(i) = ic(i) = i for i=1,...,n. if an ordering subroutine c is used, then nroc should be used to reorder the coefficient matrix c the calling sequence is -- c ( (matrix ordering)) c (nroc (matrix reordering)) c nsfc (symbolic factorization to determine where fillin will c occur during numeric factorization) c nnfc (numeric factorization into product ldu of unit lower c triangular matrix l, diagonal matrix d, and unit c upper triangular matrix u, and solution of linear c system) c nnsc (solution of linear system for additional right-hand c side using ldu factorization from nnfc) c (if only one system of equations is to be solved, then the c subroutine trk should be used.) c c ii. storage of sparse matrices c the nonzero entries of the coefficient matrix m are stored c row-by-row in the array a. to identify the individual nonzero c entries in each row, we need to know in which column each entry c lies. the column indices which correspond to the nonzero entries c of m are stored in the array ja. i.e., if a(k) = m(i,j), then c ja(k) = j. in addition, we need to know where each row starts and c how long it is. the index positions in ja and a where the rows of c m begin are stored in the array ia. i.e., if m(i,j) is the first c (leftmost) entry in the i-th row and a(k) = m(i,j), then c ia(i) = k. moreover, the index in ja and a of the first location c following the last element in the last row is stored in ia(n+1). c thus, the number of entries in the i-th row is given by c ia(i+1) - ia(i), the nonzero entries of the i-th row are stored c consecutively in c a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), c and the corresponding column indices are stored consecutively in c ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). c for example, the 5 by 5 matrix c ( 1. 0. 2. 0. 0.) c ( 0. 3. 0. 0. 0.) c m = ( 0. 4. 5. 6. 0.) c ( 0. 0. 0. 7. 0.) c ( 0. 0. 0. 8. 9.) c would be stored as c - 1 2 3 4 5 6 7 8 9 c ---+-------------------------- c ia - 1 3 4 7 8 10 c ja - 1 3 2 2 3 4 4 4 5 c a - 1. 2. 3. 4. 5. 6. 7. 8. 9. . c c the strict upper (lower) triangular portion of the matrix c u (l) is stored in a similar fashion using the arrays iu, ju, u c (il, jl, l) except that an additional array iju (ijl) is used to c compress storage of ju (jl) by allowing some sequences of column c (row) indices to used for more than one row (column) (n.b., l is c stored by columns). iju(k) (ijl(k)) points to the starting c location in ju (jl) of entries for the kth row (column). c compression in ju (jl) occurs in two ways. first, if a row c (column) i was merged into the current row (column) k, and the c number of elements merged in from (the tail portion of) row c (column) i is the same as the final length of row (column) k, then c the kth row (column) and the tail of row (column) i are identical c and iju(k) (ijl(k)) points to the start of the tail. second, if c some tail portion of the (k-1)st row (column) is identical to the c head of the kth row (column), then iju(k) (ijl(k)) points to the c start of that tail portion. for example, the nonzero structure of c the strict upper triangular part of the matrix c d 0 x x x c 0 d 0 x x c 0 0 d x 0 c 0 0 0 d x c 0 0 0 0 d c would be represented as c - 1 2 3 4 5 6 c ----+------------ c iu - 1 4 6 7 8 8 c ju - 3 4 5 4 c iju - 1 2 4 3 . c the diagonal entries of l and u are assumed to be equal to one and c are not stored. the array d contains the reciprocals of the c diagonal entries of the matrix d. c c iii. additional storage savings c in nsfc, r and ic can be the same array in the calling c sequence if no reordering of the coefficient matrix has been done. c in nnfc, r, c, and ic can all be the same array if no c reordering has been done. if only the rows have been reordered, c then c and ic can be the same array. if the row and column c orderings are the same, then r and c can be the same array. z and c row can be the same array. c in nnsc or nntc, r and c can be the same array if no c reordering has been done or if the row and column orderings are the c same. z and b can be the same array. however, then b will be c destroyed. c c iv. parameters c following is a list of parameters to the programs. names are c uniform among the various subroutines. class abbreviations are -- c n - integer variable c f - real variable c v - supplies a value to a subroutine c r - returns a result from a subroutine c i - used internally by a subroutine c a - array c c class - parameter c ------+---------- c fva - a - nonzero entries of the coefficient matrix m, stored c - by rows. c - size = number of nonzero entries in m. c fva - b - right-hand side b. c - size = n. c nva - c - ordering of the columns of m. c - size = n. c fvra - d - reciprocals of the diagonal entries of the matrix d. c - size = n. c nr - flag - error flag. values and their meanings are -- c - 0 no errors detected c - n+k null row in a -- row = k c - 2n+k duplicate entry in a -- row = k c - 3n+k insufficient storage for jl -- row = k c - 4n+1 insufficient storage for l c - 5n+k null pivot -- row = k c - 6n+k insufficient storage for ju -- row = k c - 7n+1 insufficient storage for u c - 8n+k zero pivot -- row = k c nva - ia - pointers to delimit the rows of a. c - size = n+1. c nvra - ijl - pointers to the first element in each column in jl, c - used to compress storage in jl. c - size = n. c nvra - iju - pointers to the first element in each row in ju, used c - to compress storage in ju. c - size = n. c nvra - il - pointers to delimit the columns of l. c - size = n+1. c nvra - iu - pointers to delimit the rows of u. c - size = n+1. c nva - ja - column numbers corresponding to the elements of a. c - size = size of a. c nvra - jl - row numbers corresponding to the elements of l. c - size = jlmax. c nv - jlmax - declared dimension of jl. jlmax must be larger than c - the number of nonzeros in the strict lower triangle c - of m plus fillin minus compression. c nvra - ju - column numbers corresponding to the elements of u. c - size = jumax. c nv - jumax - declared dimension of ju. jumax must be larger than c - the number of nonzeros in the strict upper triangle c - of m plus fillin minus compression. c fvra - l - nonzero entries in the strict lower triangular portion c - of the matrix l, stored by columns. c - size = lmax. c nv - lmax - declared dimension of l. lmax must be larger than c - the number of nonzeros in the strict lower triangle c - of m plus fillin (il(n+1)-1 after nsfc). c nv - n - number of variables/equations. c nva - r - ordering of the rows of m. c - size = n. c fvra - u - nonzero entries in the strict upper triangular portion c - of the matrix u, stored by rows. c - size = umax. c nv - umax - declared dimension of u. umax must be larger than c - the number of nonzeros in the strict upper triangle c - of m plus fillin (iu(n+1)-1 after nsfc). c fra - z - solution x. c - size = n. c c ---------------------------------------------------------------- c c*** subroutine nroc c*** reorders rows of a, leaving row order unchanged c c c input parameters.. n, ic, ia, ja, a c output parameters.. ja, a, flag c c parameters used internally.. c nia - p - at the kth step, p is a linked list of the reordered c - column indices of the kth row of a. p(n+1) points c - to the first entry in the list. c - size = n+1. c nia - jar - at the kth step,jar contains the elements of the c - reordered column indices of a. c - size = n. c fia - ar - at the kth step, ar contains the elements of the c - reordered row of a. c - size = n. c integer ic(*), ia(*), ja(*), jar(*), p(*), flag c real a(*), ar(*) double precision a(*), ar(*) c c ****** for each nonempty row ******************************* do 5 k=1,n jmin = ia(k) jmax = ia(k+1) - 1 if(jmin .gt. jmax) go to 5 p(n+1) = n + 1 c ****** insert each element in the list ********************* do 3 j=jmin,jmax newj = ic(ja(j)) i = n + 1 1 if(p(i) .ge. newj) go to 2 i = p(i) go to 1 2 if(p(i) .eq. newj) go to 102 p(newj) = p(i) p(i) = newj jar(newj) = ja(j) ar(newj) = a(j) 3 continue c ****** replace old row in ja and a ************************* i = n + 1 do 4 j=jmin,jmax i = p(i) ja(j) = jar(i) a(j) = ar(i) 4 continue 5 continue flag = 0 return c c ** error.. duplicate entry in a 102 flag = n + k return end subroutine nsfc * (n, r, ic, ia,ja, jlmax,il,jl,ijl, jumax,iu,ju,iju, * q, ira,jra, irac, irl,jrl, iru,jru, flag) c*** subroutine nsfc c*** symbolic ldu-factorization of nonsymmetric sparse matrix c (compressed pointer storage) c c c input variables.. n, r, ic, ia, ja, jlmax, jumax. c output variables.. il, jl, ijl, iu, ju, iju, flag. c c parameters used internally.. c nia - q - suppose m* is the result of reordering m. if c - processing of the ith row of m* (hence the ith c - row of u) is being done, q(j) is initially c - nonzero if m*(i,j) is nonzero (j.ge.i). since c - values need not be stored, each entry points to the c - next nonzero and q(n+1) points to the first. n+1 c - indicates the end of the list. for example, if n=9 c - and the 5th row of m* is c - 0 x x 0 x 0 0 x 0 c - then q will initially be c - a a a a 8 a a 10 5 (a - arbitrary). c - as the algorithm proceeds, other elements of q c - are inserted in the list because of fillin. c - q is used in an analogous manner to compute the c - ith column of l. c - size = n+1. c nia - ira, - vectors used to find the columns of m. at the kth c nia - jra, step of the factorization, irac(k) points to the c nia - irac head of a linked list in jra of row indices i c - such that i .ge. k and m(i,k) is nonzero. zero c - indicates the end of the list. ira(i) (i.ge.k) c - points to the smallest j such that j .ge. k and c - m(i,j) is nonzero. c - size of each = n. c nia - irl, - vectors used to find the rows of l. at the kth step c nia - jrl of the factorization, jrl(k) points to the head c - of a linked list in jrl of column indices j c - such j .lt. k and l(k,j) is nonzero. zero c - indicates the end of the list. irl(j) (j.lt.k) c - points to the smallest i such that i .ge. k and c - l(i,j) is nonzero. c - size of each = n. c nia - iru, - vectors used in a manner analogous to irl and jrl c nia - jru to find the columns of u. c - size of each = n. c c internal variables.. c jlptr - points to the last position used in jl. c juptr - points to the last position used in ju. c jmin,jmax - are the indices in a or u of the first and last c elements to be examined in a given row. c for example, jmin=ia(k), jmax=ia(k+1)-1. c integer cend, qm, rend, rk, vj integer ia(*), ja(*), ira(*), jra(*), il(*), jl(*), ijl(*) integer iu(*), ju(*), iju(*), irl(*), jrl(*), iru(*), jru(*) integer r(*), ic(*), q(*), irac(*), flag c c ****** initialize pointers **************************************** np1 = n + 1 jlmin = 1 jlptr = 0 il(1) = 1 jumin = 1 juptr = 0 iu(1) = 1 do 1 k=1,n irac(k) = 0 jra(k) = 0 jrl(k) = 0 jru(k) = 0 1 continue c ****** initialize column pointers for a *************************** do 2 k=1,n rk = r(k) iak = ia(rk) if (iak .ge. ia(rk+1)) go to 101 jaiak = ic(ja(iak)) if (jaiak .gt. k) go to 105 jra(k) = irac(jaiak) irac(jaiak) = k ira(k) = iak 2 continue c c ****** for each column of l and row of u ************************** do 41 k=1,n c c ****** initialize q for computing kth column of l ***************** q(np1) = np1 luk = -1 c ****** by filling in kth column of a ****************************** vj = irac(k) if (vj .eq. 0) go to 5 3 qm = np1 4 m = qm qm = q(m) if (qm .lt. vj) go to 4 if (qm .eq. vj) go to 102 luk = luk + 1 q(m) = vj q(vj) = qm vj = jra(vj) if (vj .ne. 0) go to 3 c ****** link through jru ******************************************* 5 lastid = 0 lasti = 0 ijl(k) = jlptr i = k 6 i = jru(i) if (i .eq. 0) go to 10 qm = np1 jmin = irl(i) jmax = ijl(i) + il(i+1) - il(i) - 1 long = jmax - jmin if (long .lt. 0) go to 6 jtmp = jl(jmin) if (jtmp .ne. k) long = long + 1 if (jtmp .eq. k) r(i) = -r(i) if (lastid .ge. long) go to 7 lasti = i lastid = long c ****** and merge the corresponding columns into the kth column **** 7 do 9 j=jmin,jmax vj = jl(j) 8 m = qm qm = q(m) if (qm .lt. vj) go to 8 if (qm .eq. vj) go to 9 luk = luk + 1 q(m) = vj q(vj) = qm qm = vj 9 continue go to 6 c ****** lasti is the longest column merged into the kth ************ c ****** see if it equals the entire kth column ********************* 10 qm = q(np1) if (qm .ne. k) go to 105 if (luk .eq. 0) go to 17 if (lastid .ne. luk) go to 11 c ****** if so, jl can be compressed ******************************** irll = irl(lasti) ijl(k) = irll + 1 if (jl(irll) .ne. k) ijl(k) = ijl(k) - 1 go to 17 c ****** if not, see if kth column can overlap the previous one ***** 11 if (jlmin .gt. jlptr) go to 15 qm = q(qm) do 12 j=jlmin,jlptr if (jl(j) - qm .LT. 0) then goto 12 else if (jl(j) - qm .EQ. 0) then goto 13 else goto 15 endif c if (jl(j) - qm) 12, 13, 15 12 continue go to 15 13 ijl(k) = j do 14 i=j,jlptr if (jl(i) .ne. qm) go to 15 qm = q(qm) if (qm .gt. n) go to 17 14 continue jlptr = j - 1 c ****** move column indices from q to jl, update vectors *********** 15 jlmin = jlptr + 1 ijl(k) = jlmin if (luk .eq. 0) go to 17 jlptr = jlptr + luk if (jlptr .gt. jlmax) go to 103 qm = q(np1) do 16 j=jlmin,jlptr qm = q(qm) jl(j) = qm 16 continue 17 irl(k) = ijl(k) il(k+1) = il(k) + luk c c ****** initialize q for computing kth row of u ******************** q(np1) = np1 luk = -1 c ****** by filling in kth row of reordered a *********************** rk = r(k) jmin = ira(k) jmax = ia(rk+1) - 1 if (jmin .gt. jmax) go to 20 do 19 j=jmin,jmax vj = ic(ja(j)) qm = np1 18 m = qm qm = q(m) if (qm .lt. vj) go to 18 if (qm .eq. vj) go to 102 luk = luk + 1 q(m) = vj q(vj) = qm 19 continue c ****** link through jrl, ****************************************** 20 lastid = 0 lasti = 0 iju(k) = juptr i = k i1 = jrl(k) 21 i = i1 if (i .eq. 0) go to 26 i1 = jrl(i) qm = np1 jmin = iru(i) jmax = iju(i) + iu(i+1) - iu(i) - 1 long = jmax - jmin if (long .lt. 0) go to 21 jtmp = ju(jmin) if (jtmp .eq. k) go to 22 c ****** update irl and jrl, ***************************************** long = long + 1 cend = ijl(i) + il(i+1) - il(i) irl(i) = irl(i) + 1 if (irl(i) .ge. cend) go to 22 j = jl(irl(i)) jrl(i) = jrl(j) jrl(j) = i 22 if (lastid .ge. long) go to 23 lasti = i lastid = long c ****** and merge the corresponding rows into the kth row ********** 23 do 25 j=jmin,jmax vj = ju(j) 24 m = qm qm = q(m) if (qm .lt. vj) go to 24 if (qm .eq. vj) go to 25 luk = luk + 1 q(m) = vj q(vj) = qm qm = vj 25 continue go to 21 c ****** update jrl(k) and irl(k) *********************************** 26 if (il(k+1) .le. il(k)) go to 27 j = jl(irl(k)) jrl(k) = jrl(j) jrl(j) = k c ****** lasti is the longest row merged into the kth *************** c ****** see if it equals the entire kth row ************************ 27 qm = q(np1) if (qm .ne. k) go to 105 if (luk .eq. 0) go to 34 if (lastid .ne. luk) go to 28 c ****** if so, ju can be compressed ******************************** irul = iru(lasti) iju(k) = irul + 1 if (ju(irul) .ne. k) iju(k) = iju(k) - 1 go to 34 c ****** if not, see if kth row can overlap the previous one ******** 28 if (jumin .gt. juptr) go to 32 qm = q(qm) do 29 j=jumin,juptr if (ju(j) - qm .LT. 0) then goto 29 else if (ju(j) - qm .EQ. 0) then goto 30 else if (ju(j) - qm .GT. 0) then goto 32 endif C if (ju(j) - qm) 29, 30, 32 29 continue go to 32 30 iju(k) = j do 31 i=j,juptr if (ju(i) .ne. qm) go to 32 qm = q(qm) if (qm .gt. n) go to 34 31 continue juptr = j - 1 c ****** move row indices from q to ju, update vectors ************** 32 jumin = juptr + 1 iju(k) = jumin if (luk .eq. 0) go to 34 juptr = juptr + luk if (juptr .gt. jumax) go to 106 qm = q(np1) do 33 j=jumin,juptr qm = q(qm) ju(j) = qm 33 CONTINUE 34 iru(k) = iju(k) iu(k+1) = iu(k) + luk c c ****** update iru, jru ******************************************** i = k 35 i1 = jru(i) if (r(i) .lt. 0) go to 36 rend = iju(i) + iu(i+1) - iu(i) if (iru(i) .ge. rend) go to 37 j = ju(iru(i)) jru(i) = jru(j) jru(j) = i go to 37 36 r(i) = -r(i) 37 i = i1 if (i .eq. 0) go to 38 iru(i) = iru(i) + 1 go to 35 c c ****** update ira, jra, irac ************************************** 38 i = irac(k) if (i .eq. 0) go to 41 39 i1 = jra(i) ira(i) = ira(i) + 1 if (ira(i) .ge. ia(r(i)+1)) go to 40 irai = ira(i) jairai = ic(ja(irai)) if (jairai .gt. i) go to 40 jra(i) = irac(jairai) irac(jairai) = i 40 i = i1 if (i .ne. 0) go to 39 41 continue c ijl(n) = jlptr iju(n) = juptr flag = 0 return c c ** error.. null row in a 101 flag = n + rk return c ** error.. duplicate entry in a 102 flag = 2*n + rk return c ** error.. insufficient storage for jl 103 flag = 3*n + k return c ** error.. null pivot 105 flag = 5*n + k return c ** error.. insufficient storage for ju 106 flag = 6*n + k return end subroutine nnfc * (n, r,c,ic, ia,ja,a, z, b, * lmax,il,jl,ijl,l, d, umax,iu,ju,iju,u, * row, tmp, irl,jrl, flag) c*** subroutine nnfc c*** numerical ldu-factorization of sparse nonsymmetric matrix and c solution of system of linear equations (compressed pointer c storage) c c c input variables.. n, r, c, ic, ia, ja, a, b, c il, jl, ijl, lmax, iu, ju, iju, umax c output variables.. z, l, d, u, flag c c parameters used internally.. c nia - irl, - vectors used to find the rows of l. at the kth step c nia - jrl of the factorization, jrl(k) points to the head c - of a linked list in jrl of column indices j c - such j .lt. k and l(k,j) is nonzero. zero c - indicates the end of the list. irl(j) (j.lt.k) c - points to the smallest i such that i .ge. k and c - l(i,j) is nonzero. c - size of each = n. c fia - row - holds intermediate values in calculation of u and l. c - size = n. c fia - tmp - holds new right-hand side b* for solution of the c - equation ux = b*. c - size = n. c c internal variables.. c jmin, jmax - indices of the first and last positions in a row to c be examined. c sum - used in calculating tmp. c integer rk,umax integer r(*), c(*), ic(*), ia(*), ja(*), il(*), jl(*), ijl(*) integer iu(*), ju(*), iju(*), irl(*), jrl(*), flag c real a(*), l(*), d(*), u(*), z(*), b(*), row(*) c real tmp(*), lki, sum, dk double precision a(*), l(*), d(*), u(*), z(*), b(*), row(*) double precision tmp(*), lki, sum, dk c c ****** initialize pointers and test storage *********************** if(il(n+1)-1 .gt. lmax) go to 104 if(iu(n+1)-1 .gt. umax) go to 107 do 1 k=1,n irl(k) = il(k) jrl(k) = 0 1 continue c c ****** for each row *********************************************** do 19 k=1,n c ****** reverse jrl and zero row where kth row of l will fill in *** row(k) = 0 i1 = 0 if (jrl(k) .eq. 0) go to 3 i = jrl(k) 2 i2 = jrl(i) jrl(i) = i1 i1 = i row(i) = 0 i = i2 if (i .ne. 0) go to 2 c ****** set row to zero where u will fill in *********************** 3 jmin = iju(k) jmax = jmin + iu(k+1) - iu(k) - 1 if (jmin .gt. jmax) go to 5 do 4 j=jmin,jmax row(ju(j)) = 0 4 CONTINUE c ****** place kth row of a in row ********************************** 5 rk = r(k) jmin = ia(rk) jmax = ia(rk+1) - 1 do 6 j=jmin,jmax row(ic(ja(j))) = a(j) 6 continue c ****** initialize sum, and link through jrl *********************** sum = b(rk) i = i1 if (i .eq. 0) go to 10 c ****** assign the kth row of l and adjust row, sum **************** 7 lki = -row(i) c ****** if l is not required, then comment out the following line ** l(irl(i)) = -lki sum = sum + lki * tmp(i) jmin = iu(i) jmax = iu(i+1) - 1 if (jmin .gt. jmax) go to 9 mu = iju(i) - jmin do 8 j=jmin,jmax row(ju(mu+j)) = row(ju(mu+j)) + lki * u(j) 8 CONTINUE 9 i = jrl(i) if (i .ne. 0) go to 7 c c ****** assign kth row of u and diagonal d, set tmp(k) ************* 10 if (row(k) .eq. 0.0d0) go to 108 dk = 1.0d0 / row(k) d(k) = dk tmp(k) = sum * dk if (k .eq. n) go to 19 jmin = iu(k) jmax = iu(k+1) - 1 if (jmin .gt. jmax) go to 12 mu = iju(k) - jmin do 11 j=jmin,jmax u(j) = row(ju(mu+j)) * dk 11 CONTINUE 12 continue c c ****** update irl and jrl, keeping jrl in decreasing order ******** i = i1 if (i .eq. 0) go to 18 14 irl(i) = irl(i) + 1 i1 = jrl(i) if (irl(i) .ge. il(i+1)) go to 17 ijlb = irl(i) - il(i) + ijl(i) j = jl(ijlb) 15 if (i .gt. jrl(j)) go to 16 j = jrl(j) go to 15 16 jrl(i) = jrl(j) jrl(j) = i 17 i = i1 if (i .ne. 0) go to 14 18 if (irl(k) .ge. il(k+1)) go to 19 j = jl(ijl(k)) jrl(k) = jrl(j) jrl(j) = k 19 continue c c ****** solve ux = tmp by back substitution ********************** k = n do 22 i=1,n sum = tmp(k) jmin = iu(k) jmax = iu(k+1) - 1 if (jmin .gt. jmax) go to 21 mu = iju(k) - jmin do 20 j=jmin,jmax sum = sum - u(j) * tmp(ju(mu+j)) 20 CONTINUE 21 tmp(k) = sum z(c(k)) = sum k = k-1 22 CONTINUE flag = 0 return c c ** error.. insufficient storage for l 104 flag = 4*n + 1 return c ** error.. insufficient storage for u 107 flag = 7*n + 1 return c ** error.. zero pivot 108 flag = 8*n + k return end subroutine nnsc * (n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, z, b, tmp) c*** subroutine nnsc c*** numerical solution of sparse nonsymmetric system of linear c equations given ldu-factorization (compressed pointer storage) c c c input variables.. n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, b c output variables.. z c c parameters used internally.. c fia - tmp - temporary vector which gets result of solving ly = b. c - size = n. c c internal variables.. c jmin, jmax - indices of the first and last positions in a row of c u or l to be used. c integer r(*), c(*), il(*), jl(*), ijl(*), iu(*), ju(*), iju(*) c real l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk, sum double precision l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk,sum c c ****** set tmp to reordered b ************************************* do 1 k=1,n tmp(k) = b(r(k)) 1 CONTINUE c ****** solve ly = b by forward substitution ********************* do 3 k=1,n jmin = il(k) jmax = il(k+1) - 1 tmpk = -d(k) * tmp(k) tmp(k) = -tmpk if (jmin .gt. jmax) go to 3 ml = ijl(k) - jmin do 2 j=jmin,jmax tmp(jl(ml+j)) = tmp(jl(ml+j)) + tmpk * l(j) 2 CONTINUE 3 continue c ****** solve ux = y by back substitution ************************ k = n do 6 i=1,n sum = -tmp(k) jmin = iu(k) jmax = iu(k+1) - 1 if (jmin .gt. jmax) go to 5 mu = iju(k) - jmin do 4 j=jmin,jmax sum = sum + u(j) * tmp(ju(mu+j)) 4 CONTINUE 5 tmp(k) = -sum z(c(k)) = -sum k = k - 1 6 continue return end subroutine nntc * (n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, z, b, tmp) c*** subroutine nntc c*** numeric solution of the transpose of a sparse nonsymmetric system c of linear equations given lu-factorization (compressed pointer c storage) c c c input variables.. n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, b c output variables.. z c c parameters used internally.. c fia - tmp - temporary vector which gets result of solving ut y = b c - size = n. c c internal variables.. c jmin, jmax - indices of the first and last positions in a row of c u or l to be used. c integer r(*), c(*), il(*), jl(*), ijl(*), iu(*), ju(*), iju(*) c real l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk,sum double precision l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk,sum c c ****** set tmp to reordered b ************************************* do 1 k=1,n tmp(k) = b(c(k)) 1 CONTINUE c ****** solve ut y = b by forward substitution ******************* do 3 k=1,n jmin = iu(k) jmax = iu(k+1) - 1 tmpk = -tmp(k) if (jmin .gt. jmax) go to 3 mu = iju(k) - jmin do 2 j=jmin,jmax tmp(ju(mu+j)) = tmp(ju(mu+j)) + tmpk * u(j) 2 CONTINUE 3 continue c ****** solve lt x = y by back substitution ********************** k = n do 6 i=1,n sum = -tmp(k) jmin = il(k) jmax = il(k+1) - 1 if (jmin .gt. jmax) go to 5 ml = ijl(k) - jmin do 4 j=jmin,jmax sum = sum + l(j) * tmp(jl(ml+j)) 4 CONTINUE 5 tmp(k) = -sum * d(k) z(r(k)) = tmp(k) k = k - 1 6 continue return end *DECK DSTODA SUBROUTINE DSTODA (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, 1 WM, IWM, F, JAC, PJAC, SLVS,rpar,ipar) EXTERNAL F, JAC, PJAC, SLVS CKS: added rpar,ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, NYH, IWM DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, ACOR, WM DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), 1 ACOR(*), WM(*), IWM(*) INTEGER IOWND, IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IOWND21, IOWND22, IOWND23, ICOUNT, IRFLAG, JTYP, 1 MUSED, MXORDN, MXORDS DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION ROWND2, CM1, CM2, PDEST, PDLAST, RATIO, 1 PDNORM COMMON /DLS001/ CONIT, CRATE, EL(13), ELCO(13,12), 1 HOLD, RMAX, TESCO(3,12), 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 3 IOWND(6), IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 4 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 5 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 6 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLSA01/ ROWND2, CM1(12), CM2(5), PDEST, PDLAST, RATIO, 1 PDNORM, IOWND21, IOWND22, IOWND23, 2 ICOUNT, IRFLAG, JTYP, MUSED, MXORDN, MXORDS INTEGER I, I1, IREDO, IRET, J, JB, M, NCF, NEWQ INTEGER LM1, LM1P1, LM2, LM2P1, NQM1, NQM2 DOUBLE PRECISION DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP, 1 R, RH, RHDN, RHSM, RHUP, TOLD, DMNORM DOUBLE PRECISION ALPHA, DM1,DM2, EXM1,EXM2, 1 PDH, PNORM, RATE, RH1, RH1IT, RH2, RM, SM1(12) SAVE SM1 DATA SM1/0.5D0, 0.575D0, 0.55D0, 0.45D0, 0.35D0, 0.25D0, 1 0.20D0, 0.15D0, 0.10D0, 0.075D0, 0.050D0, 0.025D0/ C----------------------------------------------------------------------- C DSTODA performs one step of the integration of an initial value C problem for a system of ordinary differential equations. C Note: DSTODA is independent of the value of the iteration method C indicator MITER, when this is .ne. 0, and hence is independent C of the type of chord method used, or the Jacobian structure. C Communication with DSTODA is done with the following variables: C C Y = an array of length .ge. N used as the Y argument in C all calls to F and JAC. C NEQ = integer array containing problem size in NEQ(1), and C passed as the NEQ argument in all calls to F and JAC. C YH = an NYH by LMAX array containing the dependent variables C and their approximate scaled derivatives, where C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate C j-th derivative of y(i), scaled by H**j/factorial(j) C (j = 0,1,...,NQ). On entry for the first step, the first C two columns of YH must be set from the initial values. C NYH = a constant integer .ge. N, the first dimension of YH. C YH1 = a one-dimensional array occupying the same space as YH. C EWT = an array of length N containing multiplicative weights C for local error measurements. Local errors in y(i) are C compared to 1.0/EWT(i) in various error tests. C SAVF = an array of working storage, of length N. C ACOR = a work array of length N, used for the accumulated C corrections. On a successful return, ACOR(i) contains C the estimated one-step local error in y(i). C WM,IWM = real and integer work arrays associated with matrix C operations in chord iteration (MITER .ne. 0). C PJAC = name of routine to evaluate and preprocess Jacobian matrix C and P = I - H*EL0*Jac, if a chord method is being used. C It also returns an estimate of norm(Jac) in PDNORM. C SLVS = name of routine to solve linear system in chord iteration. C CCMAX = maximum relative change in H*EL0 before PJAC is called. C H = the step size to be attempted on the next step. C H is altered by the error control algorithm during the C problem. H can be either positive or negative, but its C sign must remain constant throughout the problem. C HMIN = the minimum absolute value of the step size H to be used. C HMXI = inverse of the maximum absolute value of H to be used. C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. C HMIN and HMXI may be changed at any time, but will not C take effect until the next change of H is considered. C TN = the independent variable. TN is updated on each step taken. C JSTART = an integer used for input only, with the following C values and meanings: C 0 perform the first step. C .gt.0 take a new step continuing from the last. C -1 take the next step with a new value of H, C N, METH, MITER, and/or matrix parameters. C -2 take the next step with a new value of H, C but with other inputs unchanged. C On return, JSTART is set to 1 to facilitate continuation. C KFLAG = a completion code with the following meanings: C 0 the step was succesful. C -1 the requested error could not be achieved. C -2 corrector convergence could not be achieved. C -3 fatal error in PJAC or SLVS. C A return with KFLAG = -1 or -2 means either C ABS(H) = HMIN or 10 consecutive failures occurred. C On a return with KFLAG negative, the values of TN and C the YH array are as of the beginning of the last C step, and H is the last step size attempted. C MAXORD = the maximum order of integration method to be allowed. C MAXCOR = the maximum number of corrector iterations allowed. C MSBP = maximum number of steps between PJAC calls (MITER .gt. 0). C MXNCF = maximum number of convergence failures allowed. C METH = current method. C METH = 1 means Adams method (nonstiff) C METH = 2 means BDF method (stiff) C METH may be reset by DSTODA. C MITER = corrector iteration method. C MITER = 0 means functional iteration. C MITER = JT .gt. 0 means a chord iteration corresponding C to Jacobian type JT. (The DLSODA/DLSODAR argument JT is C communicated here as JTYP, but is not used in DSTODA C except to load MITER following a method switch.) C MITER may be reset by DSTODA. C N = the number of first-order differential equations. C----------------------------------------------------------------------- C KARLINE: INITIALISED IREDO, RH TO AVOID COMPILER WARNING - SHOULD HAVE NO EFFECT IREDO = 0 RH = 1.D0 KFLAG = 0 TOLD = TN NCF = 0 IERPJ = 0 IERSL = 0 JCUR = 0 ICF = 0 DELP = 0.0D0 IF (JSTART .GT. 0) GO TO 200 IF (JSTART .EQ. -1) GO TO 100 IF (JSTART .EQ. -2) GO TO 160 C----------------------------------------------------------------------- C On the first call, the order is set to 1, and other variables are C initialized. RMAX is the maximum ratio by which H can be increased C in a single step. It is initially 1.E4 to compensate for the small C initial H, but then is normally equal to 10. If a failure C occurs (in corrector convergence or error test), RMAX is set at 2 C for the next increase. C DCFODE is called to get the needed coefficients for both methods. C----------------------------------------------------------------------- LMAX = MAXORD + 1 NQ = 1 L = 2 IALTH = 2 RMAX = 10000.0D0 RC = 0.0D0 EL0 = 1.0D0 CRATE = 0.7D0 HOLD = H NSLP = 0 IPUP = MITER IRET = 3 C Initialize switching parameters. METH = 1 is assumed initially. ----- ICOUNT = 20 IRFLAG = 0 PDEST = 0.0D0 PDLAST = 0.0D0 RATIO = 5.0D0 CALL DCFODE (2, ELCO, TESCO) DO 10 I = 1,5 CM2(I) = TESCO(2,I)*ELCO(I+1,I) 10 CONTINUE CALL DCFODE (1, ELCO, TESCO) DO 20 I = 1,12 CM1(I) = TESCO(2,I)*ELCO(I+1,I) 20 CONTINUE GO TO 150 C----------------------------------------------------------------------- C The following block handles preliminaries needed when JSTART = -1. C IPUP is set to MITER to force a matrix update. C If an order increase is about to be considered (IALTH = 1), C IALTH is reset to 2 to postpone consideration one more step. C If the caller has changed METH, DCFODE is called to reset C the coefficients of the method. C If H is to be changed, YH must be rescaled. C If H or METH is being changed, IALTH is reset to L = NQ + 1 C to prevent further changes in H for that many steps. C----------------------------------------------------------------------- 100 IPUP = MITER LMAX = MAXORD + 1 IF (IALTH .EQ. 1) IALTH = 2 IF (METH .EQ. MUSED) GO TO 160 CALL DCFODE (METH, ELCO, TESCO) IALTH = L IRET = 1 C----------------------------------------------------------------------- C The el vector and related constants are reset C whenever the order NQ is changed, or at the start of the problem. C----------------------------------------------------------------------- 150 DO 155 I = 1,L EL(I) = ELCO(I,NQ) 155 CONTINUE NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/(NQ+2) IF (IRET .EQ. 1) THEN GOTO 160 ELSE IF (IRET .EQ. 2) THEN GOTO 170 ELSE IF (IRET .EQ. 3) THEN GOTO 200 ENDIF C GO TO (160, 170, 200), IRET C----------------------------------------------------------------------- C If H is being changed, the H ratio RH is checked against C RMAX, HMIN, and HMXI, and the YH array rescaled. IALTH is set to C L = NQ + 1 to prevent a change of H for that many steps, unless C forced by a convergence or error test failure. C----------------------------------------------------------------------- 160 IF (H .EQ. HOLD) GO TO 200 RH = H/HOLD H = HOLD IREDO = 3 GO TO 175 170 RH = MAX(RH,HMIN/ABS(H)) 175 RH = MIN(RH,RMAX) RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) C----------------------------------------------------------------------- C If METH = 1, also restrict the new step size by the stability region. C If this reduces H, set IRFLAG to 1 so that if there are roundoff C problems later, we can assume that is the cause of the trouble. C----------------------------------------------------------------------- IF (METH .EQ. 2) GO TO 178 IRFLAG = 0 PDH = MAX(ABS(H)*PDLAST,0.000001D0) IF (RH*PDH*1.00001D0 .LT. SM1(NQ)) GO TO 178 RH = SM1(NQ)/PDH IRFLAG = 1 178 CONTINUE R = 1.0D0 DO 190 J = 2,L R = R*RH DO 180 I = 1,N YH(I,J) = YH(I,J)*R 180 CONTINUE 190 CONTINUE H = H*RH RC = RC*RH IALTH = L IF (IREDO .EQ. 0) GO TO 690 C----------------------------------------------------------------------- C This section computes the predicted values by effectively C multiplying the YH array by the Pascal triangle matrix. C RC is the ratio of new to old values of the coefficient H*EL(1). C When RC differs from 1 by more than CCMAX, IPUP is set to MITER C to force PJAC to be called, if a Jacobian is involved. C In any case, PJAC is called at least every MSBP steps. C----------------------------------------------------------------------- 200 IF (ABS(RC-1.0D0) .GT. CCMAX) IPUP = MITER IF (NST .GE. NSLP+MSBP) IPUP = MITER TN = TN + H I1 = NQNYH + 1 DO 215 JB = 1,NQ I1 = I1 - NYH CDIR$ IVDEP DO 210 I = I1,NQNYH YH1(I) = YH1(I) + YH1(I+NYH) 210 CONTINUE 215 CONTINUE PNORM = DMNORM (N, YH1, EWT) C----------------------------------------------------------------------- C Up to MAXCOR corrector iterations are taken. A convergence test is C made on the RMS-norm of each correction, weighted by the error C weight vector EWT. The sum of the corrections is accumulated in the C vector ACOR(i). The YH array is not altered in the corrector loop. C----------------------------------------------------------------------- 220 M = 0 RATE = 0.0D0 DEL = 0.0D0 DO 230 I = 1,N Y(I) = YH(I,1) 230 CONTINUE CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 IF (IPUP .LE. 0) GO TO 250 C----------------------------------------------------------------------- C If indicated, the matrix P = I - H*EL(1)*J is reevaluated and C preprocessed before starting the corrector iteration. IPUP is set C to 0 as an indicator that this has been done. C----------------------------------------------------------------------- CKS CALL PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, &rpar,ipar) IPUP = 0 RC = 1.0D0 NSLP = NST CRATE = 0.7D0 IF (IERPJ .NE. 0) GO TO 430 250 DO 260 I = 1,N ACOR(I) = 0.0D0 260 CONTINUE 270 IF (MITER .NE. 0) GO TO 350 C----------------------------------------------------------------------- C In the case of functional iteration, update Y directly from C the result of the last function evaluation. C----------------------------------------------------------------------- DO 290 I = 1,N SAVF(I) = H*SAVF(I) - YH(I,2) Y(I) = SAVF(I) - ACOR(I) 290 CONTINUE DEL = DMNORM (N, Y, EWT) DO 300 I = 1,N Y(I) = YH(I,1) + EL(1)*SAVF(I) ACOR(I) = SAVF(I) 300 CONTINUE GO TO 400 C----------------------------------------------------------------------- C In the case of the chord method, compute the corrector error, C and solve the linear system with that as right-hand side and C P as coefficient matrix. C----------------------------------------------------------------------- 350 DO 360 I = 1,N Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) 360 CONTINUE CALL SLVS (WM, IWM, Y, SAVF) IF (IERSL .LT. 0) GO TO 430 IF (IERSL .GT. 0) GO TO 410 DEL = DMNORM (N, Y, EWT) DO 380 I = 1,N ACOR(I) = ACOR(I) + Y(I) Y(I) = YH(I,1) + EL(1)*ACOR(I) 380 CONTINUE C----------------------------------------------------------------------- C Test for convergence. If M .gt. 0, an estimate of the convergence C rate constant is stored in CRATE, and this is used in the test. C C We first check for a change of iterates that is the size of C roundoff error. If this occurs, the iteration has converged, and a C new rate estimate is not formed. C In all other cases, force at least two iterations to estimate a C local Lipschitz constant estimate for Adams methods. C On convergence, form PDEST = local maximum Lipschitz constant C estimate. PDLAST is the most recent nonzero estimate. C----------------------------------------------------------------------- 400 CONTINUE IF (DEL .LE. 100.0D0*PNORM*UROUND) GO TO 450 IF (M .EQ. 0 .AND. METH .EQ. 1) GO TO 405 IF (M .EQ. 0) GO TO 402 RM = 1024.0D0 IF (DEL .LE. 1024.0D0*DELP) RM = DEL/DELP RATE = MAX(RATE,RM) CRATE = MAX(0.2D0*CRATE,RM) 402 DCON = DEL*MIN(1.0D0,1.5D0*CRATE)/(TESCO(2,NQ)*CONIT) IF (DCON .GT. 1.0D0) GO TO 405 PDEST = MAX(PDEST,RATE/ABS(H*EL(1))) IF (PDEST .NE. 0.0D0) PDLAST = PDEST GO TO 450 405 CONTINUE M = M + 1 IF (M .EQ. MAXCOR) GO TO 410 IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 DELP = DEL CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 GO TO 270 C----------------------------------------------------------------------- C The corrector iteration failed to converge. C If MITER .ne. 0 and the Jacobian is out of date, PJAC is called for C the next try. Otherwise the YH array is retracted to its values C before prediction, and H is reduced, if possible. If H cannot be C reduced or MXNCF failures have occurred, exit with KFLAG = -2. C----------------------------------------------------------------------- 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 ICF = 1 IPUP = MITER GO TO 220 430 ICF = 2 NCF = NCF + 1 RMAX = 2.0D0 TN = TOLD I1 = NQNYH + 1 DO 445 JB = 1,NQ I1 = I1 - NYH CDIR$ IVDEP DO 440 I = I1,NQNYH YH1(I) = YH1(I) - YH1(I+NYH) 440 CONTINUE 445 CONTINUE IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670 IF (NCF .EQ. MXNCF) GO TO 670 RH = 0.25D0 IPUP = MITER IREDO = 1 GO TO 170 C----------------------------------------------------------------------- C The corrector has converged. JCUR is set to 0 C to signal that the Jacobian involved may need updating later. C The local error test is made and control passes to statement 500 C if it fails. C----------------------------------------------------------------------- 450 JCUR = 0 IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) IF (M .GT. 0) DSM = DMNORM (N, ACOR, EWT)/TESCO(2,NQ) IF (DSM .GT. 1.0D0) GO TO 500 C----------------------------------------------------------------------- C After a successful step, update the YH array. C Decrease ICOUNT by 1, and if it is -1, consider switching methods. C If a method switch is made, reset various parameters, C rescale the YH array, and exit. If there is no switch, C consider changing H if IALTH = 1. Otherwise decrease IALTH by 1. C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for C use in a possible order increase on the next step. C If a change in H is considered, an increase or decrease in order C by one is considered also. A change in H is made only if it is by a C factor of at least 1.1. If not, IALTH is set to 3 to prevent C testing for that many steps. C----------------------------------------------------------------------- KFLAG = 0 IREDO = 0 NST = NST + 1 HU = H NQU = NQ MUSED = METH DO 465 J = 1,L DO 460 I = 1,N YH(I,J) = YH(I,J) + EL(J)*ACOR(I) 460 CONTINUE 465 CONTINUE ICOUNT = ICOUNT - 1 IF (ICOUNT .GE. 0) GO TO 488 IF (METH .EQ. 2) GO TO 480 C----------------------------------------------------------------------- C We are currently using an Adams method. Consider switching to BDF. C If the current order is greater than 5, assume the problem is C not stiff, and skip this section. C If the Lipschitz constant and error estimate are not polluted C by roundoff, go to 470 and perform the usual test. C Otherwise, switch to the BDF methods if the last step was C restricted to insure stability (irflag = 1), and stay with Adams C method if not. When switching to BDF with polluted error estimates, C in the absence of other information, double the step size. C C When the estimates are OK, we make the usual test by computing C the step size we could have (ideally) used on this step, C with the current (Adams) method, and also that for the BDF. C If NQ .gt. MXORDS, we consider changing to order MXORDS on switching. C Compare the two step sizes to decide whether to switch. C The step size advantage must be at least RATIO = 5 to switch. C----------------------------------------------------------------------- IF (NQ .GT. 5) GO TO 488 IF (DSM .GT. 100.0D0*PNORM*UROUND .AND. PDEST .NE. 0.0D0) 1 GO TO 470 IF (IRFLAG .EQ. 0) GO TO 488 RH2 = 2.0D0 NQM2 = MIN(NQ,MXORDS) GO TO 478 470 CONTINUE EXSM = 1.0D0/L RH1 = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) RH1IT = 2.0D0*RH1 PDH = PDLAST*ABS(H) IF (PDH*RH1 .GT. 0.00001D0) RH1IT = SM1(NQ)/PDH RH1 = MIN(RH1,RH1IT) IF (NQ .LE. MXORDS) GO TO 474 NQM2 = MXORDS LM2 = MXORDS + 1 EXM2 = 1.0D0/LM2 LM2P1 = LM2 + 1 DM2 = DMNORM (N, YH(1,LM2P1), EWT)/CM2(MXORDS) RH2 = 1.0D0/(1.2D0*DM2**EXM2 + 0.0000012D0) GO TO 476 474 DM2 = DSM*(CM1(NQ)/CM2(NQ)) RH2 = 1.0D0/(1.2D0*DM2**EXSM + 0.0000012D0) NQM2 = NQ 476 CONTINUE IF (RH2 .LT. RATIO*RH1) GO TO 488 C THE SWITCH TEST PASSED. RESET RELEVANT QUANTITIES FOR BDF. ---------- 478 RH = RH2 ICOUNT = 20 METH = 2 MITER = JTYP PDLAST = 0.0D0 NQ = NQM2 L = NQ + 1 GO TO 170 C----------------------------------------------------------------------- C We are currently using a BDF method. Consider switching to Adams. C Compute the step size we could have (ideally) used on this step, C with the current (BDF) method, and also that for the Adams. C If NQ .gt. MXORDN, we consider changing to order MXORDN on switching. C Compare the two step sizes to decide whether to switch. C The step size advantage must be at least 5/RATIO = 1 to switch. C If the step size for Adams would be so small as to cause C roundoff pollution, we stay with BDF. C----------------------------------------------------------------------- 480 CONTINUE EXSM = 1.0D0/L IF (MXORDN .GE. NQ) GO TO 484 NQM1 = MXORDN LM1 = MXORDN + 1 EXM1 = 1.0D0/LM1 LM1P1 = LM1 + 1 DM1 = DMNORM (N, YH(1,LM1P1), EWT)/CM1(MXORDN) RH1 = 1.0D0/(1.2D0*DM1**EXM1 + 0.0000012D0) GO TO 486 484 DM1 = DSM*(CM2(NQ)/CM1(NQ)) RH1 = 1.0D0/(1.2D0*DM1**EXSM + 0.0000012D0) NQM1 = NQ EXM1 = EXSM 486 RH1IT = 2.0D0*RH1 PDH = PDNORM*ABS(H) IF (PDH*RH1 .GT. 0.00001D0) RH1IT = SM1(NQM1)/PDH RH1 = MIN(RH1,RH1IT) RH2 = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) IF (RH1*RATIO .LT. 5.0D0*RH2) GO TO 488 ALPHA = MAX(0.001D0,RH1) DM1 = (ALPHA**EXM1)*DM1 IF (DM1 .LE. 1000.0D0*UROUND*PNORM) GO TO 488 C The switch test passed. Reset relevant quantities for Adams. -------- RH = RH1 ICOUNT = 20 METH = 1 MITER = 0 PDLAST = 0.0D0 NQ = NQM1 L = NQ + 1 GO TO 170 C C No method switch is being made. Do the usual step/order selection. -- 488 CONTINUE IALTH = IALTH - 1 IF (IALTH .EQ. 0) GO TO 520 IF (IALTH .GT. 1) GO TO 700 IF (L .EQ. LMAX) GO TO 700 DO 490 I = 1,N YH(I,LMAX) = ACOR(I) 490 CONTINUE GO TO 700 C----------------------------------------------------------------------- C The error test failed. KFLAG keeps track of multiple failures. C Restore TN and the YH array to their previous values, and prepare C to try the step again. Compute the optimum step size for this or C one lower order. After 2 or more failures, H is forced to decrease C by a factor of 0.2 or less. C----------------------------------------------------------------------- 500 KFLAG = KFLAG - 1 TN = TOLD I1 = NQNYH + 1 DO 515 JB = 1,NQ I1 = I1 - NYH CDIR$ IVDEP DO 510 I = I1,NQNYH YH1(I) = YH1(I) - YH1(I+NYH) 510 CONTINUE 515 CONTINUE RMAX = 2.0D0 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 IF (KFLAG .LE. -3) GO TO 640 IREDO = 2 RHUP = 0.0D0 GO TO 540 C----------------------------------------------------------------------- C Regardless of the success or failure of the step, factors C RHDN, RHSM, and RHUP are computed, by which H could be multiplied C at order NQ - 1, order NQ, or order NQ + 1, respectively. C In the case of failure, RHUP = 0.0 to avoid an order increase. C The largest of these is determined and the new order chosen C accordingly. If the order is to be increased, we compute one C additional scaled derivative. C----------------------------------------------------------------------- 520 RHUP = 0.0D0 IF (L .EQ. LMAX) GO TO 540 DO 530 I = 1,N SAVF(I) = ACOR(I) - YH(I,LMAX) 530 CONTINUE DUP = DMNORM (N, SAVF, EWT)/TESCO(3,NQ) EXUP = 1.0D0/(L+1) RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) 540 EXSM = 1.0D0/L RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) RHDN = 0.0D0 IF (NQ .EQ. 1) GO TO 550 DDN = DMNORM (N, YH(1,L), EWT)/TESCO(1,NQ) EXDN = 1.0D0/NQ RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) C If METH = 1, limit RH according to the stability region also. -------- 550 IF (METH .EQ. 2) GO TO 560 PDH = MAX(ABS(H)*PDLAST,0.000001D0) IF (L .LT. LMAX) RHUP = MIN(RHUP,SM1(L)/PDH) RHSM = MIN(RHSM,SM1(NQ)/PDH) IF (NQ .GT. 1) RHDN = MIN(RHDN,SM1(NQ-1)/PDH) PDEST = 0.0D0 560 IF (RHSM .GE. RHUP) GO TO 570 IF (RHUP .GT. RHDN) GO TO 590 GO TO 580 570 IF (RHSM .LT. RHDN) GO TO 580 NEWQ = NQ RH = RHSM GO TO 620 580 NEWQ = NQ - 1 RH = RHDN IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 GO TO 620 590 NEWQ = L RH = RHUP IF (RH .LT. 1.1D0) GO TO 610 R = EL(L)/L DO 600 I = 1,N YH(I,NEWQ+1) = ACOR(I)*R 600 CONTINUE GO TO 630 610 IALTH = 3 GO TO 700 C If METH = 1 and H is restricted by stability, bypass 10 percent test. 620 IF (METH .EQ. 2) GO TO 622 IF (RH*PDH*1.00001D0 .GE. SM1(NEWQ)) GO TO 625 622 IF (KFLAG .EQ. 0 .AND. RH .LT. 1.1D0) GO TO 610 625 IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) C----------------------------------------------------------------------- C If there is a change of order, reset NQ, L, and the coefficients. C In any case H is reset according to RH and the YH array is rescaled. C Then exit from 690 if the step was OK, or redo the step otherwise. C----------------------------------------------------------------------- IF (NEWQ .EQ. NQ) GO TO 170 630 NQ = NEWQ L = NQ + 1 IRET = 2 GO TO 150 C----------------------------------------------------------------------- C Control reaches this section if 3 or more failures have occured. C If 10 failures have occurred, exit with KFLAG = -1. C It is assumed that the derivatives that have accumulated in the C YH array have errors of the wrong order. Hence the first C derivative is recomputed, and the order is set to 1. Then C H is reduced by a factor of 10, and the step is retried, C until it succeeds or H reaches HMIN. C----------------------------------------------------------------------- 640 IF (KFLAG .EQ. -10) GO TO 660 RH = 0.1D0 RH = MAX(HMIN/ABS(H),RH) H = H*RH DO 645 I = 1,N Y(I) = YH(I,1) 645 CONTINUE CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 DO 650 I = 1,N YH(I,2) = H*SAVF(I) 650 CONTINUE IPUP = MITER IALTH = 5 IF (NQ .EQ. 1) GO TO 200 NQ = 1 L = 2 IRET = 3 GO TO 150 C----------------------------------------------------------------------- C All returns are made through this section. H is saved in HOLD C to allow the caller to change H on the next step. C----------------------------------------------------------------------- 660 KFLAG = -1 GO TO 720 670 KFLAG = -2 GO TO 720 680 KFLAG = -3 GO TO 720 690 RMAX = 10.0D0 700 R = 1.0D0/TESCO(2,NQU) DO 710 I = 1,N ACOR(I) = ACOR(I)*R 710 CONTINUE 720 HOLD = H JSTART = 1 RETURN C----------------------- End of Subroutine DSTODA ---------------------- END *DECK DPRJA SUBROUTINE DPRJA (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, 1 F, JAC,rpar,ipar) EXTERNAL F, JAC CKS: added rpar,ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, NYH, IWM DOUBLE PRECISION Y, YH, EWT, FTEM, SAVF, WM DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), 1 WM(*), IWM(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IOWND21, IOWND22, IOWND23, IOWNS21, IOWNS22, JTYP, 1 MUSED, MXORDN, MXORDS DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION ROWND2, RCM1, RCM2, ROWNS21, ROWNS22, 1 ROWNS23, PDNORM COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLSA01/ ROWND2, RCM1(12), RCM2(5), 1 ROWNS21, ROWNS22, ROWNS23, PDNORM, 1 IOWND21, IOWND22, IOWND23, IOWNS21, IOWNS22, JTYP, 2 MUSED, MXORDN, MXORDS INTEGER I, I1, I2, IER, II, J, J1, JJ, LENP, 1 MBA, MBAND, MEB1, MEBAND, ML, ML3, MU, NP1 DOUBLE PRECISION CON, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, 1 DMNORM, DFNORM, DBNORM C----------------------------------------------------------------------- C DPRJA is called by DSTODA to compute and process the matrix C P = I - H*EL(1)*J , where J is an approximation to the Jacobian. C Here J is computed by the user-supplied routine JAC if C MITER = 1 or 4 or by finite differencing if MITER = 2 or 5. C J, scaled by -H*EL(1), is stored in WM. Then the norm of J (the C matrix norm consistent with the weighted max-norm on vectors given C by DMNORM) is computed, and J is overwritten by P. P is then C subjected to LU decomposition in preparation for later solution C of linear systems with P as coefficient matrix. This is done C by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5. C C In addition to variables described previously, communication C with DPRJA uses the following: C Y = array containing predicted values on entry. C FTEM = work array of length N (ACOR in DSTODA). C SAVF = array containing f evaluated at predicted y. C WM = real work space for matrices. On output it contains the C LU decomposition of P. C Storage of matrix elements starts at WM(3). C WM also contains the following matrix-related data: C WM(1) = SQRT(UROUND), used in numerical Jacobian increments. C IWM = integer work space containing pivot information, starting at C IWM(21). IWM also contains the band parameters C ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. C EL0 = EL(1) (input). C PDNORM= norm of Jacobian matrix. (Output). C IERPJ = output error flag, = 0 if no trouble, .gt. 0 if C P matrix found to be singular. C JCUR = output flag = 1 to indicate that the Jacobian matrix C (or approximation) is now current. C This routine also uses the Common variables EL0, H, TN, UROUND, C MITER, N, NFE, and NJE. C----------------------------------------------------------------------- NJE = NJE + 1 IERPJ = 0 JCUR = 1 HL0 = H*EL0 IF (MITER .EQ. 1) THEN GOTO 100 ELSE IF (MITER .EQ. 2) THEN GOTO 200 ELSE IF (MITER .EQ. 3) THEN GOTO 300 ELSE IF (MITER .EQ. 4) THEN GOTO 400 ELSE IF (MITER .EQ. 5) THEN GOTO 500 ENDIF C karline C GO TO (100, 200, 300, 400, 500), MITER C If MITER = 1, call JAC and multiply by scalar. ----------------------- 100 LENP = N*N DO 110 I = 1,LENP WM(I+2) = 0.0D0 110 CONTINUE CALL JAC (NEQ, TN, Y, 0, 0, WM(3), N,rpar,ipar) CON = -HL0 DO 120 I = 1,LENP WM(I+2) = WM(I+2)*CON 120 CONTINUE GO TO 240 C If MITER = 2, make N calls to F to approximate J. -------------------- 200 FAC = DMNORM (N, SAVF, EWT) R0 = 1000.0D0*ABS(H)*UROUND*N*FAC IF (R0 .EQ. 0.0D0) R0 = 1.0D0 SRUR = WM(1) J1 = 2 DO 230 J = 1,N YJ = Y(J) R = MAX(SRUR*ABS(YJ),R0/EWT(J)) Y(J) = Y(J) + R FAC = -HL0/R CKS CALL F (NEQ, TN, Y, FTEM, rpar, ipar) DO 220 I = 1,N WM(I+J1) = (FTEM(I) - SAVF(I))*FAC 220 CONTINUE Y(J) = YJ J1 = J1 + N 230 CONTINUE NFE = NFE + N 240 CONTINUE C Compute norm of Jacobian. -------------------------------------------- PDNORM = DFNORM (N, WM(3), EWT)/ABS(HL0) C Add identity matrix. ------------------------------------------------- J = 3 NP1 = N + 1 DO 250 I = 1,N WM(J) = WM(J) + 1.0D0 J = J + NP1 250 CONTINUE C Do LU decomposition on P. -------------------------------------------- CALL DGEFA (WM(3), N, N, IWM(21), IER) IF (IER .NE. 0) IERPJ = 1 RETURN C Dummy block only, since MITER is never 3 in this routine. ------------ 300 RETURN C If MITER = 4, call JAC and multiply by scalar. ----------------------- 400 ML = IWM(1) MU = IWM(2) ML3 = ML + 3 MBAND = ML + MU + 1 MEBAND = MBAND + ML LENP = MEBAND*N DO 410 I = 1,LENP WM(I+2) = 0.0D0 410 CONTINUE CALL JAC (NEQ, TN, Y, ML, MU, WM(ML3), MEBAND,rpar,ipar) CON = -HL0 DO 420 I = 1,LENP WM(I+2) = WM(I+2)*CON 420 CONTINUE GO TO 570 C If MITER = 5, make MBAND calls to F to approximate J. ---------------- 500 ML = IWM(1) MU = IWM(2) MBAND = ML + MU + 1 MBA = MIN(MBAND,N) MEBAND = MBAND + ML MEB1 = MEBAND - 1 SRUR = WM(1) FAC = DMNORM (N, SAVF, EWT) R0 = 1000.0D0*ABS(H)*UROUND*N*FAC IF (R0 .EQ. 0.0D0) R0 = 1.0D0 DO 560 J = 1,MBA DO 530 I = J,N,MBAND YI = Y(I) R = MAX(SRUR*ABS(YI),R0/EWT(I)) Y(I) = Y(I) + R 530 CONTINUE CKS CALL F (NEQ, TN, Y, FTEM, rpar, ipar) DO 550 JJ = J,N,MBAND Y(JJ) = YH(JJ,1) YJJ = Y(JJ) R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) FAC = -HL0/R I1 = MAX(JJ-MU,1) I2 = MIN(JJ+ML,N) II = JJ*MEB1 - ML + 2 DO 540 I = I1,I2 WM(II+I) = (FTEM(I) - SAVF(I))*FAC 540 CONTINUE 550 CONTINUE 560 CONTINUE NFE = NFE + MBA 570 CONTINUE C Compute norm of Jacobian. -------------------------------------------- PDNORM = DBNORM (N, WM(ML+3), MEBAND, ML, MU, EWT)/ABS(HL0) C Add identity matrix. ------------------------------------------------- II = MBAND + 2 DO 580 I = 1,N WM(II) = WM(II) + 1.0D0 II = II + MEBAND 580 CONTINUE C Do LU decomposition of P. -------------------------------------------- CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(21), IER) IF (IER .NE. 0) IERPJ = 1 RETURN C----------------------- End of Subroutine DPRJA ----------------------- END *DECK DMNORM DOUBLE PRECISION FUNCTION DMNORM (N, V, W) C----------------------------------------------------------------------- C This function routine computes the weighted max-norm C of the vector of length N contained in the array V, with weights C contained in the array w of length N: C DMNORM = MAX(i=1,...,N) ABS(V(i))*W(i) C----------------------------------------------------------------------- INTEGER N, I DOUBLE PRECISION V, W, VM DIMENSION V(N), W(N) VM = 0.0D0 DO 10 I = 1,N VM = MAX(VM,ABS(V(I))*W(I)) 10 CONTINUE DMNORM = VM RETURN C----------------------- End of Function DMNORM ------------------------ END *DECK DFNORM DOUBLE PRECISION FUNCTION DFNORM (N, A, W) C----------------------------------------------------------------------- C This function computes the norm of a full N by N matrix, C stored in the array A, that is consistent with the weighted max-norm C on vectors, with weights stored in the array W: C DFNORM = MAX(i=1,...,N) ( W(i) * Sum(j=1,...,N) ABS(a(i,j))/W(j) ) C----------------------------------------------------------------------- INTEGER N, I, J DOUBLE PRECISION A, W, AN, SUM DIMENSION A(N,N), W(N) AN = 0.0D0 DO 20 I = 1,N SUM = 0.0D0 DO 10 J = 1,N SUM = SUM + ABS(A(I,J))/W(J) 10 CONTINUE AN = MAX(AN,SUM*W(I)) 20 CONTINUE DFNORM = AN RETURN C----------------------- End of Function DFNORM ------------------------ END *DECK DBNORM DOUBLE PRECISION FUNCTION DBNORM (N, A, NRA, ML, MU, W) C----------------------------------------------------------------------- C This function computes the norm of a banded N by N matrix, C stored in the array A, that is consistent with the weighted max-norm C on vectors, with weights stored in the array W. C ML and MU are the lower and upper half-bandwidths of the matrix. C NRA is the first dimension of the A array, NRA .ge. ML+MU+1. C In terms of the matrix elements a(i,j), the norm is given by: C DBNORM = MAX(i=1,...,N) ( W(i) * Sum(j=1,...,N) ABS(a(i,j))/W(j) ) C----------------------------------------------------------------------- INTEGER N, NRA, ML, MU INTEGER I, I1, JLO, JHI, J DOUBLE PRECISION A, W DOUBLE PRECISION AN, SUM DIMENSION A(NRA,N), W(N) AN = 0.0D0 DO 20 I = 1,N SUM = 0.0D0 I1 = I + MU + 1 JLO = MAX(I-ML,1) JHI = MIN(I+MU,N) DO 10 J = JLO,JHI SUM = SUM + ABS(A(I1-J,J))/W(J) 10 CONTINUE AN = MAX(AN,SUM*W(I)) 20 CONTINUE DBNORM = AN RETURN C----------------------- End of Function DBNORM ------------------------ END *DECK DSRCMA *DECK DRCHEK SUBROUTINE DRCHEK (JOB, G, NEQ, Y, YH,NYH, G0, G1, GX, JROOT, IRT, & 1 rpar, ipar) EXTERNAL G INTEGER JOB, NEQ, NYH, JROOT, IRT, ipar(*) DOUBLE PRECISION Y, YH, G0, G1, GX, rpar(*) DIMENSION NEQ(*), Y(*), YH(NYH,*), G0(*), G1(*), GX(*), JROOT(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C INTEGER IOWND3, IOWNR3, IRFND, ITASKC, NGC, NGE INTEGER LG0, LG1, LGX, IMAX, LAST, IRFND, ITASKC, NGC, NGE DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND C DOUBLE PRECISION ROWNR3, T0, TLAST, TOUTC DOUBLE PRECISION ALPHA, X2, T0, TLAST, TOUTC COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C COMMON /DLSR01/ ROWNR3(2), T0, TLAST, TOUTC, C 1 IOWND3(3), IOWNR3(2), IRFND, ITASKC, NGC, NGE COMMON /DLSR01/ ALPHA, X2, T0, TLAST, TOUTC, 1 LG0, LG1, LGX, IMAX, LAST, IRFND, ITASKC, NGC, NGE INTEGER I, IFLAG, JFLAG DOUBLE PRECISION HMING, T1, TEMP1, TEMP2, X LOGICAL ZROOT C----------------------------------------------------------------------- C This routine checks for the presence of a root in the vicinity of C the current T, in a manner depending on the input flag JOB. It calls C Subroutine DROOTS to locate the root as precisely as possible. C C In addition to variables described previously, DRCHEK C uses the following for communication: C JOB = integer flag indicating type of call: C JOB = 1 means the problem is being initialized, and DRCHEK C is to look for a root at or very near the initial T. C JOB = 2 means a continuation call to the solver was just C made, and DRCHEK is to check for a root in the C relevant part of the step last taken. C JOB = 3 means a successful step was just taken, and DRCHEK C is to look for a root in the interval of the step. C G0 = array of length NG, containing the value of g at T = T0. C G0 is input for JOB .ge. 2, and output in all cases. C G1,GX = arrays of length NG for work space. C IRT = completion flag: C IRT = 0 means no root was found. C IRT = -1 means JOB = 1 and a root was found too near to T. C IRT = 1 means a legitimate root was found (JOB = 2 or 3). C On return, T0 is the root location, and Y is the C corresponding solution vector. C T0 = value of T at one endpoint of interval of interest. Only C roots beyond T0 in the direction of integration are sought. C T0 is input if JOB .ge. 2, and output in all cases. C T0 is updated by DRCHEK, whether a root is found or not. C TLAST = last value of T returned by the solver (input only). C TOUTC = copy of TOUT (input only). C IRFND = input flag showing whether the last step taken had a root. C IRFND = 1 if it did, = 0 if not. C ITASKC = copy of ITASK (input only). C NGC = copy of NG (input only). C----------------------------------------------------------------------- IRT = 0 DO 10 I = 1,NGC JROOT(I) = 0 10 CONTINUE HMING = (ABS(TN) + ABS(H))*UROUND*100.0D0 C IF (JOB .EQ. 1) THEN GOTO 100 ELSE IF (JOB .EQ. 2) THEN GOTO 200 ELSE IF (JOB .EQ. 3) THEN GOTO 300 ENDIF C karline: C GO TO (100, 200, 300), JOB C C Evaluate g at initial T, and check for zero values. ------------------ 100 CONTINUE T0 = TN CALL G (NEQ, T0, Y, NGC, G0, rpar, ipar) NGE = 1 ZROOT = .FALSE. DO 110 I = 1,NGC IF (ABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. 110 CONTINUE IF (.NOT. ZROOT) GO TO 190 C g has a zero at T. Look at g at T + (small increment). -------------- TEMP2 = MAX(HMING/ABS(H), 0.1D0) TEMP1 = TEMP2*H T0 = T0 + TEMP1 DO 120 I = 1,N Y(I) = Y(I) + TEMP2*YH(I,2) 120 CONTINUE CALL G (NEQ, T0, Y, NGC, G0, rpar, ipar) NGE = NGE + 1 ZROOT = .FALSE. DO 130 I = 1,NGC IF (ABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. 130 CONTINUE IF (.NOT. ZROOT) GO TO 190 C g has a zero at T and also close to T. Take error return. ----------- IRT = -1 RETURN C 190 CONTINUE RETURN C C 200 CONTINUE IF (IRFND .EQ. 0) GO TO 260 C If a root was found on the previous step, evaluate G0 = g(T0). ------- CALL DINTDY (T0, 0, YH, NYH, Y, IFLAG) CALL G (NEQ, T0, Y, NGC, G0, rpar, ipar) NGE = NGE + 1 ZROOT = .FALSE. DO 210 I = 1,NGC IF (ABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. 210 CONTINUE IF (.NOT. ZROOT) GO TO 260 C g has a zero at T0. Look at g at T + (small increment). ------------- TEMP1 = SIGN(HMING,H) T0 = T0 + TEMP1 IF ((T0 - TN)*H .LT. 0.0D0) GO TO 230 TEMP2 = TEMP1/H DO 220 I = 1,N Y(I) = Y(I) + TEMP2*YH(I,2) 220 CONTINUE GO TO 240 230 CALL DINTDY (T0, 0, YH, NYH, Y, IFLAG) 240 CALL G (NEQ, T0, Y, NGC, G0, rpar, ipar) NGE = NGE + 1 ZROOT = .FALSE. DO 250 I = 1,NGC IF (ABS(G0(I)) .GT. 0.0D0) GO TO 250 JROOT(I) = 1 ZROOT = .TRUE. 250 CONTINUE IF (.NOT. ZROOT) GO TO 260 C g has a zero at T0 and also close to T0. Return root. --------------- IRT = 1 RETURN C G0 has no zero components. Proceed to check relevant interval. ------ 260 IF (TN .EQ. TLAST) GO TO 390 C 300 CONTINUE C Set T1 to TN or TOUTC, whichever comes first, and get g at T1. ------- IF (ITASKC.EQ.2 .OR. ITASKC.EQ.3 .OR. ITASKC.EQ.5) GO TO 310 IF ((TOUTC - TN)*H .GE. 0.0D0) GO TO 310 T1 = TOUTC IF ((T1 - T0)*H .LE. 0.0D0) GO TO 390 CALL DINTDY (T1, 0, YH, NYH, Y, IFLAG) GO TO 330 310 T1 = TN DO 320 I = 1,N Y(I) = YH(I,1) 320 CONTINUE 330 CALL G (NEQ, T1, Y, NGC, G1, rpar, ipar) NGE = NGE + 1 C Call DROOTS to search for root in interval from T0 to T1. ------------ JFLAG = 0 350 CONTINUE CALL DROOTS (NGC, HMING, JFLAG, T0, T1, G0, G1, GX, X, JROOT) IF (JFLAG .GT. 1) GO TO 360 CALL DINTDY (X, 0, YH, NYH, Y, IFLAG) CALL G (NEQ, X, Y, NGC, GX, rpar, ipar) NGE = NGE + 1 GO TO 350 360 T0 = X CALL DCOPY (NGC, GX, 1, G0, 1) IF (JFLAG .EQ. 4) GO TO 390 C Found a root. Interpolate to X and return. -------------------------- CALL DINTDY (X, 0, YH, NYH, Y, IFLAG) IRT = 1 RETURN C 390 CONTINUE RETURN C----------------------- End of Subroutine DRCHEK ---------------------- END *DECK DROOTS SUBROUTINE DROOTS (NG, HMIN, JFLAG, X0, X1, G0, G1, GX, X, JROOT) INTEGER NG, JFLAG, JROOT DOUBLE PRECISION HMIN, X0, X1, G0, G1, GX, X DIMENSION G0(NG), G1(NG), GX(NG), JROOT(NG) INTEGER LG0, LG1, LGX, IMAX, LAST, IRFND, ITASKC, NGC, NGE DOUBLE PRECISION ALPHA, X2, T0, TLAST, TOUTC COMMON /DLSR01/ ALPHA, X2, T0, TLAST, TOUTC, 1 LG0, LG1, LGX, IMAX, LAST, IRFND, ITASKC, NGC, NGE C----------------------------------------------------------------------- C This subroutine finds the leftmost root of a set of arbitrary C functions gi(x) (i = 1,...,NG) in an interval (X0,X1). Only roots C of odd multiplicity (i.e. changes of sign of the gi) are found. C Here the sign of X1 - X0 is arbitrary, but is constant for a given C problem, and -leftmost- means nearest to X0. C The values of the vector-valued function g(x) = (gi, i=1...NG) C are communicated through the call sequence of DROOTS. C The method used is the Illinois algorithm. C C Reference: C Kathie L. Hiebert and Lawrence F. Shampine, Implicitly Defined C Output Points for Solutions of ODEs, Sandia Report SAND80-0180, C February 1980. C C Description of parameters. C C NG = number of functions gi, or the number of components of C the vector valued function g(x). Input only. C C HMIN = resolution parameter in X. Input only. When a root is C found, it is located only to within an error of HMIN in X. C Typically, HMIN should be set to something on the order of C 100 * UROUND * MAX(ABS(X0),ABS(X1)), C where UROUND is the unit roundoff of the machine. C C JFLAG = integer flag for input and output communication. C C On input, set JFLAG = 0 on the first call for the problem, C and leave it unchanged until the problem is completed. C (The problem is completed when JFLAG .ge. 2 on return.) C C On output, JFLAG has the following values and meanings: C JFLAG = 1 means DROOTS needs a value of g(x). Set GX = g(X) C and call DROOTS again. C JFLAG = 2 means a root has been found. The root is C at X, and GX contains g(X). (Actually, X is the C rightmost approximation to the root on an interval C (X0,X1) of size HMIN or less.) C JFLAG = 3 means X = X1 is a root, with one or more of the gi C being zero at X1 and no sign changes in (X0,X1). C GX contains g(X) on output. C JFLAG = 4 means no roots (of odd multiplicity) were C found in (X0,X1) (no sign changes). C C X0,X1 = endpoints of the interval where roots are sought. C X1 and X0 are input when JFLAG = 0 (first call), and C must be left unchanged between calls until the problem is C completed. X0 and X1 must be distinct, but X1 - X0 may be C of either sign. However, the notion of -left- and -right- C will be used to mean nearer to X0 or X1, respectively. C When JFLAG .ge. 2 on return, X0 and X1 are output, and C are the endpoints of the relevant interval. C C G0,G1 = arrays of length NG containing the vectors g(X0) and g(X1), C respectively. When JFLAG = 0, G0 and G1 are input and C none of the G0(i) should be zero. C When JFLAG .ge. 2 on return, G0 and G1 are output. C C GX = array of length NG containing g(X). GX is input C when JFLAG = 1, and output when JFLAG .ge. 2. C C X = independent variable value. Output only. C When JFLAG = 1 on output, X is the point at which g(x) C is to be evaluated and loaded into GX. C When JFLAG = 2 or 3, X is the root. C When JFLAG = 4, X is the right endpoint of the interval, X1. C C JROOT = integer array of length NG. Output only. C When JFLAG = 2 or 3, JROOT indicates which components C of g(x) have a root at X. JROOT(i) is 1 if the i-th C component has a root, and JROOT(i) = 0 otherwise. C----------------------------------------------------------------------- INTEGER I, IMXOLD, NXLAST DOUBLE PRECISION T2, TMAX, FRACINT, FRACSUB, ZERO,HALF,TENTH,FIVE LOGICAL ZROOT, SGNCHG, XROOT SAVE ZERO, HALF, TENTH, FIVE DATA ZERO/0.0D0/, HALF/0.5D0/, TENTH/0.1D0/, FIVE/5.0D0/ C IF (JFLAG .EQ. 1) GO TO 200 C JFLAG .ne. 1. Check for change in sign of g or zero at X1. ---------- IMAX = 0 TMAX = ZERO ZROOT = .FALSE. DO 120 I = 1,NG IF (ABS(G1(I)) .GT. ZERO) GO TO 110 ZROOT = .TRUE. GO TO 120 C At this point, G0(i) has been checked and cannot be zero. ------------ 110 IF (SIGN(1.0D0,G0(I)) .EQ. SIGN(1.0D0,G1(I))) GO TO 120 T2 = ABS(G1(I)/(G1(I)-G0(I))) IF (T2 .LE. TMAX) GO TO 120 TMAX = T2 IMAX = I 120 CONTINUE IF (IMAX .GT. 0) GO TO 130 SGNCHG = .FALSE. GO TO 140 130 SGNCHG = .TRUE. 140 IF (.NOT. SGNCHG) GO TO 400 C There is a sign change. Find the first root in the interval. -------- XROOT = .FALSE. NXLAST = 0 LAST = 1 C C Repeat until the first root in the interval is found. Loop point. --- 150 CONTINUE IF (XROOT) GO TO 300 IF (NXLAST .EQ. LAST) GO TO 160 ALPHA = 1.0D0 GO TO 180 160 IF (LAST .EQ. 0) GO TO 170 ALPHA = 0.5D0*ALPHA GO TO 180 170 ALPHA = 2.0D0*ALPHA 180 X2 = X1 - (X1 - X0)*G1(IMAX) / (G1(IMAX) - ALPHA*G0(IMAX)) C If X2 is too close to X0 or X1, adjust it inward, by a fractional ---- C distance that is between 0.1 and 0.5. -------------------------------- IF (ABS(X2 - X0) < HALF*HMIN) THEN FRACINT = ABS(X1 - X0)/HMIN FRACSUB = TENTH IF (FRACINT .LE. FIVE) FRACSUB = HALF/FRACINT X2 = X0 + FRACSUB*(X1 - X0) ENDIF IF (ABS(X1 - X2) < HALF*HMIN) THEN FRACINT = ABS(X1 - X0)/HMIN FRACSUB = TENTH IF (FRACINT .LE. FIVE) FRACSUB = HALF/FRACINT X2 = X1 - FRACSUB*(X1 - X0) ENDIF JFLAG = 1 X = X2 C Return to the calling routine to get a value of GX = g(X). ----------- RETURN C Check to see in which interval g changes sign. ----------------------- 200 IMXOLD = IMAX IMAX = 0 TMAX = ZERO ZROOT = .FALSE. DO 220 I = 1,NG IF (ABS(GX(I)) .GT. ZERO) GO TO 210 ZROOT = .TRUE. GO TO 220 C Neither G0(i) nor GX(i) can be zero at this point. ------------------- 210 IF (SIGN(1.0D0,G0(I)) .EQ. SIGN(1.0D0,GX(I))) GO TO 220 T2 = ABS(GX(I)/(GX(I) - G0(I))) IF (T2 .LE. TMAX) GO TO 220 TMAX = T2 IMAX = I 220 CONTINUE IF (IMAX .GT. 0) GO TO 230 SGNCHG = .FALSE. IMAX = IMXOLD GO TO 240 230 SGNCHG = .TRUE. 240 NXLAST = LAST IF (.NOT. SGNCHG) GO TO 250 C Sign change between X0 and X2, so replace X1 with X2. ---------------- X1 = X2 CALL DCOPY (NG, GX, 1, G1, 1) LAST = 1 XROOT = .FALSE. GO TO 270 250 IF (.NOT. ZROOT) GO TO 260 C Zero value at X2 and no sign change in (X0,X2), so X2 is a root. ----- X1 = X2 CALL DCOPY (NG, GX, 1, G1, 1) XROOT = .TRUE. GO TO 270 C No sign change between X0 and X2. Replace X0 with X2. --------------- 260 CONTINUE CALL DCOPY (NG, GX, 1, G0, 1) X0 = X2 LAST = 0 XROOT = .FALSE. 270 IF (ABS(X1-X0) .LE. HMIN) XROOT = .TRUE. GO TO 150 C C Return with X1 as the root. Set JROOT. Set X = X1 and GX = G1. ----- 300 JFLAG = 2 X = X1 CALL DCOPY (NG, G1, 1, GX, 1) DO 320 I = 1,NG JROOT(I) = 0 IF (ABS(G1(I)) .GT. ZERO) GO TO 310 JROOT(I) = 1 GO TO 320 310 IF (SIGN(1.0D0,G0(I)) .NE. SIGN(1.0D0,G1(I))) JROOT(I) = 1 320 CONTINUE RETURN C C No sign change in the interval. Check for zero at right endpoint. --- 400 IF (.NOT. ZROOT) GO TO 420 C C Zero value at X1 and no sign change in (X0,X1). Return JFLAG = 3. --- X = X1 CALL DCOPY (NG, G1, 1, GX, 1) DO 410 I = 1,NG JROOT(I) = 0 IF (ABS(G1(I)) .LE. ZERO) JROOT (I) = 1 410 CONTINUE JFLAG = 3 RETURN C C No sign changes in this interval. Set X = X1, return JFLAG = 4. ----- 420 CALL DCOPY (NG, G1, 1, GX, 1) X = X1 JFLAG = 4 RETURN C----------------------- End of Subroutine DROOTS ---------------------- END *DECK DSRCAR *DECK DSTODPK SUBROUTINE DSTODPK (NEQ, Y, YH, NYH, YH1, EWT, SAVF, SAVX, ACOR, 1 WM, IWM, F, JAC, PSOL,rpar,ipar) EXTERNAL F, JAC, PSOL CKS: added rpar,ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, NYH, IWM DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, SAVX, ACOR, WM DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), 1 SAVX(*), ACOR(*), WM(*), IWM(*) INTEGER IOWND, IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 1 NNI, NLI, NPS, NCFN, NCFL DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION DELT, EPCON, SQRTN, RSQRTN COMMON /DLS001/ CONIT, CRATE, EL(13), ELCO(13,12), 1 HOLD, RMAX, TESCO(3,12), 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 3 IOWND(6), IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLPK01/ DELT, EPCON, SQRTN, RSQRTN, 1 JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 2 NNI, NLI, NPS, NCFN, NCFL C----------------------------------------------------------------------- C DSTODPK performs one step of the integration of an initial value C problem for a system of Ordinary Differential Equations. C----------------------------------------------------------------------- C The following changes were made to generate Subroutine DSTODPK C from Subroutine DSTODE: C 1. The array SAVX was added to the call sequence. C 2. PJAC and SLVS were replaced by PSOL in the call sequence. C 3. The Common block /DLPK01/ was added for communication. C 4. The test constant EPCON is loaded into Common below statement C numbers 125 and 155, and used below statement 400. C 5. The Newton iteration counter MNEWT is set below 220 and 400. C 6. The call to PJAC was replaced with a call to DPKSET (fixed name), C with a longer call sequence, called depending on JACFLG. C 7. The corrector residual is stored in SAVX (not Y) at 360, C and the solution vector is in SAVX in the 380 loop. C 8. SLVS was renamed DSOLPK and includes NEQ, SAVX, EWT, F, and JAC. C SAVX was added because DSOLPK now needs Y and SAVF undisturbed. C 9. The nonlinear convergence failure count NCFN is set at 430. C----------------------------------------------------------------------- C Note: DSTODPK is independent of the value of the iteration method C indicator MITER, when this is .ne. 0, and hence is independent C of the type of chord method used, or the Jacobian structure. C Communication with DSTODPK is done with the following variables: C C NEQ = integer array containing problem size in NEQ(1), and C passed as the NEQ argument in all calls to F and JAC. C Y = an array of length .ge. N used as the Y argument in C all calls to F and JAC. C YH = an NYH by LMAX array containing the dependent variables C and their approximate scaled derivatives, where C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate C j-th derivative of y(i), scaled by H**j/factorial(j) C (j = 0,1,...,NQ). On entry for the first step, the first C two columns of YH must be set from the initial values. C NYH = a constant integer .ge. N, the first dimension of YH. C YH1 = a one-dimensional array occupying the same space as YH. C EWT = an array of length N containing multiplicative weights C for local error measurements. Local errors in y(i) are C compared to 1.0/EWT(i) in various error tests. C SAVF = an array of working storage, of length N. C Also used for input of YH(*,MAXORD+2) when JSTART = -1 C and MAXORD .lt. the current order NQ. C SAVX = an array of working storage, of length N. C ACOR = a work array of length N, used for the accumulated C corrections. On a successful return, ACOR(i) contains C the estimated one-step local error in y(i). C WM,IWM = real and integer work arrays associated with matrix C operations in chord iteration (MITER .ne. 0). C CCMAX = maximum relative change in H*EL0 before DPKSET is called. C H = the step size to be attempted on the next step. C H is altered by the error control algorithm during the C problem. H can be either positive or negative, but its C sign must remain constant throughout the problem. C HMIN = the minimum absolute value of the step size H to be used. C HMXI = inverse of the maximum absolute value of H to be used. C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. C HMIN and HMXI may be changed at any time, but will not C take effect until the next change of H is considered. C TN = the independent variable. TN is updated on each step taken. C JSTART = an integer used for input only, with the following C values and meanings: C 0 perform the first step. C .gt.0 take a new step continuing from the last. C -1 take the next step with a new value of H, MAXORD, C N, METH, MITER, and/or matrix parameters. C -2 take the next step with a new value of H, C but with other inputs unchanged. C On return, JSTART is set to 1 to facilitate continuation. C KFLAG = a completion code with the following meanings: C 0 the step was succesful. C -1 the requested error could not be achieved. C -2 corrector convergence could not be achieved. C -3 fatal error in DPKSET or DSOLPK. C A return with KFLAG = -1 or -2 means either C ABS(H) = HMIN or 10 consecutive failures occurred. C On a return with KFLAG negative, the values of TN and C the YH array are as of the beginning of the last C step, and H is the last step size attempted. C MAXORD = the maximum order of integration method to be allowed. C MAXCOR = the maximum number of corrector iterations allowed. C MSBP = maximum number of steps between DPKSET calls (MITER .gt. 0). C MXNCF = maximum number of convergence failures allowed. C METH/MITER = the method flags. See description in driver. C N = the number of first-order differential equations. C----------------------------------------------------------------------- INTEGER I, I1, IREDO, IRET, J, JB, M, NCF, NEWQ DOUBLE PRECISION DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP, 1 R, RH, RHDN, RHSM, RHUP, TOLD, DVNORM C KARLINE: INITIALISED IREDO, RH TO AVOID COMPILER WARNING - SHOULD HAVE NO EFFECT IREDO = 0 RH = 1.D0 KFLAG = 0 TOLD = TN NCF = 0 IERPJ = 0 IERSL = 0 JCUR = 0 ICF = 0 DELP = 0.0D0 IF (JSTART .GT. 0) GO TO 200 IF (JSTART .EQ. -1) GO TO 100 IF (JSTART .EQ. -2) GO TO 160 C----------------------------------------------------------------------- C On the first call, the order is set to 1, and other variables are C initialized. RMAX is the maximum ratio by which H can be increased C in a single step. It is initially 1.E4 to compensate for the small C initial H, but then is normally equal to 10. If a failure C occurs (in corrector convergence or error test), RMAX is set at 2 C for the next increase. C----------------------------------------------------------------------- LMAX = MAXORD + 1 NQ = 1 L = 2 IALTH = 2 RMAX = 10000.0D0 RC = 0.0D0 EL0 = 1.0D0 CRATE = 0.7D0 HOLD = H MEO = METH NSLP = 0 IPUP = MITER IRET = 3 GO TO 140 C----------------------------------------------------------------------- C The following block handles preliminaries needed when JSTART = -1. C IPUP is set to MITER to force a matrix update. C If an order increase is about to be considered (IALTH = 1), C IALTH is reset to 2 to postpone consideration one more step. C If the caller has changed METH, DCFODE is called to reset C the coefficients of the method. C If the caller has changed MAXORD to a value less than the current C order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly. C If H is to be changed, YH must be rescaled. C If H or METH is being changed, IALTH is reset to L = NQ + 1 C to prevent further changes in H for that many steps. C----------------------------------------------------------------------- 100 IPUP = MITER LMAX = MAXORD + 1 IF (IALTH .EQ. 1) IALTH = 2 IF (METH .EQ. MEO) GO TO 110 CALL DCFODE (METH, ELCO, TESCO) MEO = METH IF (NQ .GT. MAXORD) GO TO 120 IALTH = L IRET = 1 GO TO 150 110 IF (NQ .LE. MAXORD) GO TO 160 120 NQ = MAXORD L = LMAX DO 125 I = 1,L EL(I) = ELCO(I,NQ) 125 CONTINUE NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/(NQ+2) EPCON = CONIT*TESCO(2,NQ) DDN = DVNORM (N, SAVF, EWT)/TESCO(1,L) EXDN = 1.0D0/L RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) RH = MIN(RHDN,1.0D0) IREDO = 3 IF (H .EQ. HOLD) GO TO 170 RH = MIN(RH,ABS(H/HOLD)) H = HOLD GO TO 175 C----------------------------------------------------------------------- C DCFODE is called to get all the integration coefficients for the C current METH. Then the EL vector and related constants are reset C whenever the order NQ is changed, or at the start of the problem. C----------------------------------------------------------------------- 140 CALL DCFODE (METH, ELCO, TESCO) 150 DO 155 I = 1,L EL(I) = ELCO(I,NQ) 155 CONTINUE NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/(NQ+2) EPCON = CONIT*TESCO(2,NQ) IF (IRET .EQ. 1) THEN GOTO 160 ELSE IF (IRET .EQ. 2) THEN GOTO 170 ELSE IF (IRET .EQ. 3) THEN GOTO 200 ENDIF C karline changed from C GO TO (160, 170, 200), IRET C----------------------------------------------------------------------- C If H is being changed, the H ratio RH is checked against C RMAX, HMIN, and HMXI, and the YH array rescaled. IALTH is set to C L = NQ + 1 to prevent a change of H for that many steps, unless C forced by a convergence or error test failure. C----------------------------------------------------------------------- 160 IF (H .EQ. HOLD) GO TO 200 RH = H/HOLD H = HOLD IREDO = 3 GO TO 175 170 RH = MAX(RH,HMIN/ABS(H)) 175 RH = MIN(RH,RMAX) RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) R = 1.0D0 DO 190 J = 2,L R = R*RH DO 180 I = 1,N YH(I,J) = YH(I,J)*R 180 CONTINUE 190 CONTINUE H = H*RH RC = RC*RH IALTH = L IF (IREDO .EQ. 0) GO TO 690 C----------------------------------------------------------------------- C This section computes the predicted values by effectively C multiplying the YH array by the Pascal triangle matrix. C The flag IPUP is set according to whether matrix data is involved C (JACFLG .ne. 0) or not (JACFLG = 0), to trigger a call to DPKSET. C IPUP is set to MITER when RC differs from 1 by more than CCMAX, C and at least every MSBP steps, when JACFLG = 1. C RC is the ratio of new to old values of the coefficient H*EL(1). C----------------------------------------------------------------------- 200 IF (JACFLG .NE. 0) GO TO 202 IPUP = 0 CRATE = 0.7D0 GO TO 205 202 IF (ABS(RC-1.0D0) .GT. CCMAX) IPUP = MITER IF (NST .GE. NSLP+MSBP) IPUP = MITER 205 TN = TN + H I1 = NQNYH + 1 DO 215 JB = 1,NQ I1 = I1 - NYH CDIR$ IVDEP DO 210 I = I1,NQNYH YH1(I) = YH1(I) + YH1(I+NYH) 210 CONTINUE 215 CONTINUE C----------------------------------------------------------------------- C Up to MAXCOR corrector iterations are taken. A convergence test is C made on the RMS-norm of each correction, weighted by the error C weight vector EWT. The sum of the corrections is accumulated in the C vector ACOR(i). The YH array is not altered in the corrector loop. C----------------------------------------------------------------------- 220 M = 0 MNEWT = 0 DO 230 I = 1,N Y(I) = YH(I,1) 230 CONTINUE CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 IF (IPUP .LE. 0) GO TO 250 C----------------------------------------------------------------------- C If indicated, DPKSET is called to update any matrix data needed, C before starting the corrector iteration. C IPUP is set to 0 as an indicator that this has been done. C----------------------------------------------------------------------- CALL DPKSET (NEQ, Y, YH1, EWT, ACOR, SAVF, WM, IWM, F, JAC, &rpar,ipar) IPUP = 0 RC = 1.0D0 NSLP = NST CRATE = 0.7D0 IF (IERPJ .NE. 0) GO TO 430 250 DO 260 I = 1,N ACOR(I) = 0.0D0 260 CONTINUE 270 IF (MITER .NE. 0) GO TO 350 C----------------------------------------------------------------------- C In the case of functional iteration, update Y directly from C the result of the last function evaluation. C----------------------------------------------------------------------- DO 290 I = 1,N SAVF(I) = H*SAVF(I) - YH(I,2) Y(I) = SAVF(I) - ACOR(I) 290 CONTINUE DEL = DVNORM (N, Y, EWT) DO 300 I = 1,N Y(I) = YH(I,1) + EL(1)*SAVF(I) ACOR(I) = SAVF(I) 300 CONTINUE GO TO 400 C----------------------------------------------------------------------- C In the case of the chord method, compute the corrector error, C and solve the linear system with that as right-hand side and C P as coefficient matrix. C----------------------------------------------------------------------- 350 DO 360 I = 1,N SAVX(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) 360 CONTINUE CALL DSOLPK (NEQ, Y, SAVF, SAVX, EWT, WM, IWM, F,PSOL,rpar,ipar) IF (IERSL .LT. 0) GO TO 430 IF (IERSL .GT. 0) GO TO 410 DEL = DVNORM (N, SAVX, EWT) DO 380 I = 1,N ACOR(I) = ACOR(I) + SAVX(I) Y(I) = YH(I,1) + EL(1)*ACOR(I) 380 CONTINUE C----------------------------------------------------------------------- C Test for convergence. If M .gt. 0, an estimate of the convergence C rate constant is stored in CRATE, and this is used in the test. C----------------------------------------------------------------------- 400 IF (M .NE. 0) CRATE = MAX(0.2D0*CRATE,DEL/DELP) DCON = DEL*MIN(1.0D0,1.5D0*CRATE)/EPCON IF (DCON .LE. 1.0D0) GO TO 450 M = M + 1 IF (M .EQ. MAXCOR) GO TO 410 IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 MNEWT = M DELP = DEL CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 GO TO 270 C----------------------------------------------------------------------- C The corrector iteration failed to converge. C If MITER .ne. 0 and the Jacobian is out of date, DPKSET is called for C the next try. Otherwise the YH array is retracted to its values C before prediction, and H is reduced, if possible. If H cannot be C reduced or MXNCF failures have occurred, exit with KFLAG = -2. C----------------------------------------------------------------------- 410 IF (MITER.EQ.0 .OR. JCUR.EQ.1 .OR. JACFLG.EQ.0) GO TO 430 ICF = 1 IPUP = MITER GO TO 220 430 ICF = 2 NCF = NCF + 1 NCFN = NCFN + 1 RMAX = 2.0D0 TN = TOLD I1 = NQNYH + 1 DO 445 JB = 1,NQ I1 = I1 - NYH CDIR$ IVDEP DO 440 I = I1,NQNYH YH1(I) = YH1(I) - YH1(I+NYH) 440 CONTINUE 445 CONTINUE IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670 IF (NCF .EQ. MXNCF) GO TO 670 RH = 0.5D0 IPUP = MITER IREDO = 1 GO TO 170 C----------------------------------------------------------------------- C The corrector has converged. JCUR is set to 0 C to signal that the Jacobian involved may need updating later. C The local error test is made and control passes to statement 500 C if it fails. C----------------------------------------------------------------------- 450 JCUR = 0 IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) IF (M .GT. 0) DSM = DVNORM (N, ACOR, EWT)/TESCO(2,NQ) IF (DSM .GT. 1.0D0) GO TO 500 C----------------------------------------------------------------------- C After a successful step, update the YH array. C Consider changing H if IALTH = 1. Otherwise decrease IALTH by 1. C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for C use in a possible order increase on the next step. C If a change in H is considered, an increase or decrease in order C by one is considered also. A change in H is made only if it is by a C factor of at least 1.1. If not, IALTH is set to 3 to prevent C testing for that many steps. C----------------------------------------------------------------------- KFLAG = 0 IREDO = 0 NST = NST + 1 HU = H NQU = NQ DO 480 J = 1,L DO 470 I = 1,N YH(I,J) = YH(I,J) + EL(J)*ACOR(I) 470 CONTINUE 480 CONTINUE IALTH = IALTH - 1 IF (IALTH .EQ. 0) GO TO 520 IF (IALTH .GT. 1) GO TO 700 IF (L .EQ. LMAX) GO TO 700 DO 490 I = 1,N YH(I,LMAX) = ACOR(I) 490 CONTINUE GO TO 700 C----------------------------------------------------------------------- C The error test failed. KFLAG keeps track of multiple failures. C Restore TN and the YH array to their previous values, and prepare C to try the step again. Compute the optimum step size for this or C one lower order. After 2 or more failures, H is forced to decrease C by a factor of 0.2 or less. C----------------------------------------------------------------------- 500 KFLAG = KFLAG - 1 TN = TOLD I1 = NQNYH + 1 DO 515 JB = 1,NQ I1 = I1 - NYH CDIR$ IVDEP DO 510 I = I1,NQNYH YH1(I) = YH1(I) - YH1(I+NYH) 510 CONTINUE 515 CONTINUE RMAX = 2.0D0 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 IF (KFLAG .LE. -3) GO TO 640 IREDO = 2 RHUP = 0.0D0 GO TO 540 C----------------------------------------------------------------------- C Regardless of the success or failure of the step, factors C RHDN, RHSM, and RHUP are computed, by which H could be multiplied C at order NQ - 1, order NQ, or order NQ + 1, respectively. C In the case of failure, RHUP = 0.0 to avoid an order increase. C the largest of these is determined and the new order chosen C accordingly. If the order is to be increased, we compute one C additional scaled derivative. C----------------------------------------------------------------------- 520 RHUP = 0.0D0 IF (L .EQ. LMAX) GO TO 540 DO 530 I = 1,N SAVF(I) = ACOR(I) - YH(I,LMAX) 530 CONTINUE DUP = DVNORM (N, SAVF, EWT)/TESCO(3,NQ) EXUP = 1.0D0/(L+1) RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) 540 EXSM = 1.0D0/L RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) RHDN = 0.0D0 IF (NQ .EQ. 1) GO TO 560 DDN = DVNORM (N, YH(1,L), EWT)/TESCO(1,NQ) EXDN = 1.0D0/NQ RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) 560 IF (RHSM .GE. RHUP) GO TO 570 IF (RHUP .GT. RHDN) GO TO 590 GO TO 580 570 IF (RHSM .LT. RHDN) GO TO 580 NEWQ = NQ RH = RHSM GO TO 620 580 NEWQ = NQ - 1 RH = RHDN IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 GO TO 620 590 NEWQ = L RH = RHUP IF (RH .LT. 1.1D0) GO TO 610 R = EL(L)/L DO 600 I = 1,N YH(I,NEWQ+1) = ACOR(I)*R 600 CONTINUE GO TO 630 610 IALTH = 3 GO TO 700 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) C----------------------------------------------------------------------- C If there is a change of order, reset NQ, L, and the coefficients. C In any case H is reset according to RH and the YH array is rescaled. C Then exit from 690 if the step was OK, or redo the step otherwise. C----------------------------------------------------------------------- IF (NEWQ .EQ. NQ) GO TO 170 630 NQ = NEWQ L = NQ + 1 IRET = 2 GO TO 150 C----------------------------------------------------------------------- C Control reaches this section if 3 or more failures have occured. C If 10 failures have occurred, exit with KFLAG = -1. C It is assumed that the derivatives that have accumulated in the C YH array have errors of the wrong order. Hence the first C derivative is recomputed, and the order is set to 1. Then C H is reduced by a factor of 10, and the step is retried, C until it succeeds or H reaches HMIN. C----------------------------------------------------------------------- 640 IF (KFLAG .EQ. -10) GO TO 660 RH = 0.1D0 RH = MAX(HMIN/ABS(H),RH) H = H*RH DO 645 I = 1,N Y(I) = YH(I,1) 645 CONTINUE CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 DO 650 I = 1,N YH(I,2) = H*SAVF(I) 650 CONTINUE IPUP = MITER IALTH = 5 IF (NQ .EQ. 1) GO TO 200 NQ = 1 L = 2 IRET = 3 GO TO 150 C----------------------------------------------------------------------- C All returns are made through this section. H is saved in HOLD C to allow the caller to change H on the next step. C----------------------------------------------------------------------- 660 KFLAG = -1 GO TO 720 670 KFLAG = -2 GO TO 720 680 KFLAG = -3 GO TO 720 690 RMAX = 10.0D0 700 R = 1.0D0/TESCO(2,NQU) DO 710 I = 1,N ACOR(I) = ACOR(I)*R 710 CONTINUE 720 HOLD = H JSTART = 1 RETURN C----------------------- End of Subroutine DSTODPK --------------------- END *DECK DPKSET SUBROUTINE DPKSET (NEQ, Y, YSV, EWT, FTEM, SAVF, WM, IWM, F, JAC, &rpar,ipar) EXTERNAL F, JAC CKS: added rpar,ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, IWM DOUBLE PRECISION Y, YSV, EWT, FTEM, SAVF, WM DIMENSION NEQ(*), Y(*), YSV(*), EWT(*), FTEM(*), SAVF(*), 1 WM(*), IWM(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 1 NNI, NLI, NPS, NCFN, NCFL DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION DELT, EPCON, SQRTN, RSQRTN COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLPK01/ DELT, EPCON, SQRTN, RSQRTN, 1 JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 2 NNI, NLI, NPS, NCFN, NCFL C----------------------------------------------------------------------- C DPKSET is called by DSTODPK to interface with the user-supplied C routine JAC, to compute and process relevant parts of C the matrix P = I - H*EL(1)*J , where J is the Jacobian df/dy, C as need for preconditioning matrix operations later. C C In addition to variables described previously, communication C with DPKSET uses the following: C Y = array containing predicted values on entry. C YSV = array containing predicted y, to be saved (YH1 in DSTODPK). C FTEM = work array of length N (ACOR in DSTODPK). C SAVF = array containing f evaluated at predicted y. C WM = real work space for matrices. C Space for preconditioning data starts at WM(LOCWP). C IWM = integer work space. C Space for preconditioning data starts at IWM(LOCIWP). C IERPJ = output error flag, = 0 if no trouble, .gt. 0 if C JAC returned an error flag. C JCUR = output flag = 1 to indicate that the Jacobian matrix C (or approximation) is now current. C This routine also uses Common variables EL0, H, TN, IERPJ, JCUR, NJE. C----------------------------------------------------------------------- INTEGER IER DOUBLE PRECISION HL0 C IERPJ = 0 JCUR = 1 HL0 = EL0*H CALL JAC (F, NEQ, TN, Y, YSV, EWT, SAVF, FTEM, HL0, 1 WM(LOCWP), IWM(LOCIWP), IER,rpar,ipar) NJE = NJE + 1 IF (IER .EQ. 0) RETURN IERPJ = 1 RETURN C----------------------- End of Subroutine DPKSET ---------------------- END *DECK DSOLPK SUBROUTINE DSOLPK (NEQ, Y, SAVF, X, EWT, WM, IWM, F, PSOL, 1 rpar,ipar) EXTERNAL F, PSOL INTEGER NEQ, IWM ,ipar(*) DOUBLE PRECISION Y, SAVF, X, EWT, WM,rpar(*) DIMENSION NEQ(*), Y(*), SAVF(*), X(*), EWT(*), WM(*), IWM(*) INTEGER IXDUM1, IXDUM2, IXDUM3, IXDUM4, IXDUM5, IXDUM6, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 1 NNI, NLI, NPS, NCFN, NCFL DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION DELT, EPCON, SQRTN, RSQRTN COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IXDUM1, IXDUM2, IXDUM3, IXDUM4, IXDUM5, IXDUM6, IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLPK01/ DELT, EPCON, SQRTN, RSQRTN, 1 JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 2 NNI, NLI, NPS, NCFN, NCFL C----------------------------------------------------------------------- C This routine interfaces to one of DSPIOM, DSPIGMR, DPCG, DPCGS, or C DUSOL, for the solution of the linear system arising from a Newton C iteration. It is called if MITER .ne. 0. C In addition to variables described elsewhere, C communication with DSOLPK uses the following variables: C WM = real work space containing data for the algorithm C (Krylov basis vectors, Hessenberg matrix, etc.) C IWM = integer work space containing data for the algorithm C X = the right-hand side vector on input, and the solution vector C on output, of length N. C IERSL = output flag (in Common): C IERSL = 0 means no trouble occurred. C IERSL = 1 means the iterative method failed to converge. C If the preconditioner is out of date, the step C is repeated with a new preconditioner. C Otherwise, the stepsize is reduced (forcing a C new evaluation of the preconditioner) and the C step is repeated. C IERSL = -1 means there was a nonrecoverable error in the C iterative solver, and an error exit occurs. C This routine also uses the Common variables TN, EL0, H, N, MITER, C DELT, EPCON, SQRTN, RSQRTN, MAXL, KMP, MNEWT, NNI, NLI, NPS, NCFL, C LOCWP, LOCIWP. C----------------------------------------------------------------------- INTEGER IFLAG, LB, LDL, LHES, LIOM, LGMR, LPCG, LP, LQ, LR, 1 LV, LW, LWK, LZ, MAXLP1, NPSL DOUBLE PRECISION DELTA, HL0 C IERSL = 0 HL0 = H*EL0 DELTA = DELT*EPCON IF (MITER .EQ. 1) THEN GOTO 100 ELSE IF (MITER .EQ. 2) THEN GOTO 200 ELSE IF (MITER .EQ. 3) THEN GOTO 300 ELSE IF (MITER .EQ. 4) THEN GOTO 400 ELSE IF (MITER .LE. 9) THEN GOTO 900 ENDIF C karline: changed from C GO TO (100, 200, 300, 400, 900, 900, 900, 900, 900), MITER C----------------------------------------------------------------------- C Use the SPIOM algorithm to solve the linear system P*x = -f. C----------------------------------------------------------------------- 100 CONTINUE LV = 1 LB = LV + N*MAXL LHES = LB + N LWK = LHES + MAXL*MAXL CALL DCOPY (N, X, 1, WM(LB), 1) CALL DSCAL (N, RSQRTN, EWT, 1) CALL DSPIOM (NEQ, TN, Y, SAVF, WM(LB), EWT, N, MAXL, KMP, DELTA, 1 HL0, JPRE, MNEWT, F, PSOL, NPSL, X, WM(LV), WM(LHES), IWM, 2 LIOM, WM(LOCWP), IWM(LOCIWP), WM(LWK), IFLAG, rpar,ipar) NNI = NNI + 1 NLI = NLI + LIOM NPS = NPS + NPSL CALL DSCAL (N, SQRTN, EWT, 1) IF (IFLAG .NE. 0) NCFL = NCFL + 1 IF (IFLAG .GE. 2) IERSL = 1 IF (IFLAG .LT. 0) IERSL = -1 RETURN C----------------------------------------------------------------------- C Use the SPIGMR algorithm to solve the linear system P*x = -f. C----------------------------------------------------------------------- 200 CONTINUE MAXLP1 = MAXL + 1 LV = 1 LB = LV + N*MAXL LHES = LB + N + 1 LQ = LHES + MAXL*MAXLP1 LWK = LQ + 2*MAXL LDL = LWK + MIN(1,MAXL-KMP)*N CALL DCOPY (N, X, 1, WM(LB), 1) CALL DSCAL (N, RSQRTN, EWT, 1) CALL DSPIGMR (NEQ, TN, Y, SAVF, WM(LB), EWT, N, MAXL, MAXLP1, KMP, 1 DELTA, HL0, JPRE, MNEWT, F, PSOL, NPSL, X, WM(LV), WM(LHES), 2 WM(LQ), LGMR, WM(LOCWP), IWM(LOCIWP), WM(LWK), WM(LDL), IFLAG, 3 rpar,ipar) NNI = NNI + 1 NLI = NLI + LGMR NPS = NPS + NPSL CALL DSCAL (N, SQRTN, EWT, 1) IF (IFLAG .NE. 0) NCFL = NCFL + 1 IF (IFLAG .GE. 2) IERSL = 1 IF (IFLAG .LT. 0) IERSL = -1 RETURN C----------------------------------------------------------------------- C Use DPCG to solve the linear system P*x = -f C----------------------------------------------------------------------- 300 CONTINUE LR = 1 LP = LR + N LW = LP + N LZ = LW + N LWK = LZ + N CALL DCOPY (N, X, 1, WM(LR), 1) CALL DPCG (NEQ, TN, Y, SAVF, WM(LR), EWT, N, MAXL, DELTA, HL0, 1 JPRE, MNEWT, F, PSOL, NPSL, X, WM(LP), WM(LW), WM(LZ), 2 LPCG, WM(LOCWP), IWM(LOCIWP),WM(LWK),IFLAG,rpar, ipar) NNI = NNI + 1 NLI = NLI + LPCG NPS = NPS + NPSL IF (IFLAG .NE. 0) NCFL = NCFL + 1 IF (IFLAG .GE. 2) IERSL = 1 IF (IFLAG .LT. 0) IERSL = -1 RETURN C----------------------------------------------------------------------- C Use DPCGS to solve the linear system P*x = -f C----------------------------------------------------------------------- 400 CONTINUE LR = 1 LP = LR + N LW = LP + N LZ = LW + N LWK = LZ + N CALL DCOPY (N, X, 1, WM(LR), 1) CALL DPCGS (NEQ, TN, Y, SAVF, WM(LR), EWT, N, MAXL, DELTA, HL0, 1 JPRE, MNEWT, F, PSOL, NPSL, X, WM(LP), WM(LW), WM(LZ), 2 LPCG, WM(LOCWP), IWM(LOCIWP), WM(LWK), IFLAG,rpar,ipar) NNI = NNI + 1 NLI = NLI + LPCG NPS = NPS + NPSL IF (IFLAG .NE. 0) NCFL = NCFL + 1 IF (IFLAG .GE. 2) IERSL = 1 IF (IFLAG .LT. 0) IERSL = -1 RETURN C----------------------------------------------------------------------- C Use DUSOL, which interfaces to PSOL, to solve the linear system C (no Krylov iteration). C----------------------------------------------------------------------- 900 CONTINUE LB = 1 LWK = LB + N CALL DCOPY (N, X, 1, WM(LB), 1) CALL DUSOL (NEQ, TN, Y, SAVF, WM(LB), EWT, N, DELTA, HL0, MNEWT, 1 PSOL, NPSL, X, WM(LOCWP), IWM(LOCIWP), WM(LWK), IFLAG) NNI = NNI + 1 NPS = NPS + NPSL IF (IFLAG .NE. 0) NCFL = NCFL + 1 IF (IFLAG .EQ. 3) IERSL = 1 IF (IFLAG .LT. 0) IERSL = -1 RETURN C----------------------- End of Subroutine DSOLPK ---------------------- END *DECK DSPIOM SUBROUTINE DSPIOM (NEQ, TN, Y, SAVF, B, WGHT, N, MAXL, KMP, DELTA, 1 HL0, JPRE, MNEWT, F, PSOL, NPSL, X, V, HES, IPVT, 2 LIOM, WP, IWP, WK, IFLAG,rpar,ipar) EXTERNAL F, PSOL INTEGER NEQ,N,MAXL,KMP,JPRE,MNEWT,NPSL,IPVT,LIOM,IWP,IFLAG,ipar(*) DOUBLE PRECISION TN,Y,SAVF,B,WGHT,DELTA,HL0,X,V,HES,WP,WK,rpar(*) DIMENSION NEQ(*), Y(*), SAVF(*), B(*), WGHT(*), X(*), V(N,*), 1 HES(MAXL,MAXL), IPVT(*), WP(*), IWP(*), WK(*) C----------------------------------------------------------------------- C This routine solves the linear system A * x = b using a scaled C preconditioned version of the Incomplete Orthogonalization Method. C An initial guess of x = 0 is assumed. C----------------------------------------------------------------------- C C On entry C C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). C C TN = current value of t. C C Y = array containing current dependent variable vector. C C SAVF = array containing current value of f(t,y). C C B = the right hand side of the system A*x = b. C B is also used as work space when computing the C final approximation. C (B is the same as V(*,MAXL+1) in the call to DSPIOM.) C C WGHT = array of length N containing scale factors. C 1/WGHT(i) are the diagonal elements of the diagonal C scaling matrix D. C C N = the order of the matrix A, and the lengths C of the vectors Y, SAVF, B, WGHT, and X. C C MAXL = the maximum allowable order of the matrix HES. C C KMP = the number of previous vectors the new vector VNEW C must be made orthogonal to. KMP .le. MAXL. C C DELTA = tolerance on residuals b - A*x in weighted RMS-norm. C C HL0 = current value of (step size h) * (coefficient l0). C C JPRE = preconditioner type flag. C C MNEWT = Newton iteration counter (.ge. 0). C C WK = real work array of length N used by DATV and PSOL. C C WP = real work array used by preconditioner PSOL. C C IWP = integer work array used by preconditioner PSOL. C C On return C C X = the final computed approximation to the solution C of the system A*x = b. C C V = the N by (LIOM+1) array containing the LIOM C orthogonal vectors V(*,1) to V(*,LIOM). C C HES = the LU factorization of the LIOM by LIOM upper C Hessenberg matrix whose entries are the C scaled inner products of A*V(*,k) and V(*,i). C C IPVT = an integer array containg pivoting information. C It is loaded in DHEFA and used in DHESL. C C LIOM = the number of iterations performed, and current C order of the upper Hessenberg matrix HES. C C NPSL = the number of calls to PSOL. C C IFLAG = integer error flag: C 0 means convergence in LIOM iterations, LIOM.le.MAXL. C 1 means the convergence test did not pass in MAXL C iterations, but the residual norm is .lt. 1, C or .lt. norm(b) if MNEWT = 0, and so X is computed. C 2 means the convergence test did not pass in MAXL C iterations, residual .gt. 1, and X is undefined. C 3 means there was a recoverable error in PSOL C caused by the preconditioner being out of date. C -1 means there was a nonrecoverable error in PSOL. C C----------------------------------------------------------------------- INTEGER I, IER, INFO, J, K, LL, LM1 DOUBLE PRECISION BNRM, BNRM0, PROD, RHO, SNORMW, DNRM2, TEM C karline: initialised RHO to avoid warning RHO = 0.D0 IFLAG = 0 LIOM = 0 NPSL = 0 C----------------------------------------------------------------------- C The initial residual is the vector b. Apply scaling to b, and test C for an immediate return with X = 0 or X = b. C----------------------------------------------------------------------- DO 10 I = 1,N V(I,1) = B(I)*WGHT(I) 10 CONTINUE BNRM0 = DNRM2 (N, V, 1) BNRM = BNRM0 IF (BNRM0 .GT. DELTA) GO TO 30 IF (MNEWT .GT. 0) GO TO 20 CALL DCOPY (N, B, 1, X, 1) RETURN 20 DO 25 I = 1,N X(I) = 0.0D0 25 CONTINUE RETURN 30 CONTINUE C Apply inverse of left preconditioner to vector b. -------------------- IER = 0 IF (JPRE .EQ. 0 .OR. JPRE .EQ. 2) GO TO 55 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, B, 1, IER) NPSL = 1 IF (IER .NE. 0) GO TO 300 C Calculate norm of scaled vector V(*,1) and normalize it. ------------- DO 50 I = 1,N V(I,1) = B(I)*WGHT(I) 50 CONTINUE BNRM = DNRM2(N, V, 1) DELTA = DELTA*(BNRM/BNRM0) 55 TEM = 1.0D0/BNRM CALL DSCAL (N, TEM, V(1,1), 1) C Zero out the HES array. ---------------------------------------------- DO 65 J = 1,MAXL DO 60 I = 1,MAXL HES(I,J) = 0.0D0 60 CONTINUE 65 CONTINUE C----------------------------------------------------------------------- C Main loop on LL = l to compute the vectors V(*,2) to V(*,MAXL). C The running product PROD is needed for the convergence test. C----------------------------------------------------------------------- PROD = 1.0D0 DO 90 LL = 1,MAXL LIOM = LL C----------------------------------------------------------------------- C Call routine DATV to compute VNEW = Abar*v(l), where Abar is C the matrix A with scaling and inverse preconditioner factors applied. C Call routine DORTHOG to orthogonalize the new vector vnew = V(*,l+1). C Call routine DHEFA to update the factors of HES. C----------------------------------------------------------------------- CALL DATV (NEQ, Y, SAVF, V(1,LL), WGHT, X, F, PSOL, V(1,LL+1), 1 WK, WP, IWP, HL0, JPRE, IER, NPSL, rpar,ipar) IF (IER .NE. 0) GO TO 300 CALL DORTHOG (V(1,LL+1), V, HES, N, LL, MAXL, KMP, SNORMW) CALL DHEFA (HES, MAXL, LL, IPVT, INFO, LL) LM1 = LL - 1 IF (LL .GT. 1 .AND. IPVT(LM1) .EQ. LM1) PROD = PROD*HES(LL,LM1) IF (INFO .NE. LL) GO TO 70 C----------------------------------------------------------------------- C The last pivot in HES was found to be zero. C If vnew = 0 or l = MAXL, take an error return with IFLAG = 2. C otherwise, continue the iteration without a convergence test. C----------------------------------------------------------------------- IF (SNORMW .EQ. 0.0D0) GO TO 120 IF (LL .EQ. MAXL) GO TO 120 GO TO 80 C----------------------------------------------------------------------- C Update RHO, the estimate of the norm of the residual b - A*x(l). C test for convergence. If passed, compute approximation x(l). C If failed and l .lt. MAXL, then continue iterating. C----------------------------------------------------------------------- 70 CONTINUE RHO = BNRM*SNORMW*ABS(PROD/HES(LL,LL)) IF (RHO .LE. DELTA) GO TO 200 IF (LL .EQ. MAXL) GO TO 100 C If l .lt. MAXL, store HES(l+1,l) and normalize the vector v(*,l+1). 80 CONTINUE HES(LL+1,LL) = SNORMW TEM = 1.0D0/SNORMW CALL DSCAL (N, TEM, V(1,LL+1), 1) 90 CONTINUE C----------------------------------------------------------------------- C l has reached MAXL without passing the convergence test: C If RHO is not too large, compute a solution anyway and return with C IFLAG = 1. Otherwise return with IFLAG = 2. C----------------------------------------------------------------------- 100 CONTINUE IF (RHO .LE. 1.0D0) GO TO 150 IF (RHO .LE. BNRM .AND. MNEWT .EQ. 0) GO TO 150 120 CONTINUE IFLAG = 2 RETURN 150 IFLAG = 1 C----------------------------------------------------------------------- C Compute the approximation x(l) to the solution. C Since the vector X was used as work space, and the initial guess C of the Newton correction is zero, X must be reset to zero. C----------------------------------------------------------------------- 200 CONTINUE LL = LIOM DO 210 K = 1,LL B(K) = 0.0D0 210 CONTINUE B(1) = BNRM CALL DHESL (HES, MAXL, LL, IPVT, B) DO 220 K = 1,N X(K) = 0.0D0 220 CONTINUE DO 230 I = 1,LL CALL DAXPY (N, B(I), V(1,I), 1, X, 1) 230 CONTINUE DO 240 I = 1,N X(I) = X(I)/WGHT(I) 240 CONTINUE IF (JPRE .LE. 1) RETURN CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, X, 2, IER) NPSL = NPSL + 1 IF (IER .NE. 0) GO TO 300 RETURN C----------------------------------------------------------------------- C This block handles error returns forced by routine PSOL. C----------------------------------------------------------------------- 300 CONTINUE IF (IER .LT. 0) IFLAG = -1 IF (IER .GT. 0) IFLAG = 3 RETURN C----------------------- End of Subroutine DSPIOM ---------------------- END *DECK DATV SUBROUTINE DATV (NEQ, Y, SAVF, V, WGHT, FTEM, F, PSOL, Z, VTEM, 1 WP, IWP, HL0, JPRE, IER, NPSL,rpar,ipar) EXTERNAL F, PSOL INTEGER NEQ, IWP, JPRE, IER, NPSL ,ipar(*) DOUBLE PRECISION Y, SAVF, V, WGHT, FTEM, Z, VTEM, WP, HL0,rpar(*) DIMENSION NEQ(*), Y(*), SAVF(*), V(*), WGHT(*), FTEM(*), Z(*), 1 VTEM(*), WP(*), IWP(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C----------------------------------------------------------------------- C This routine computes the product C C (D-inverse)*(P1-inverse)*(I - hl0*df/dy)*(P2-inverse)*(D*v), C C where D is a diagonal scaling matrix, and P1 and P2 are the C left and right preconditioning matrices, respectively. C v is assumed to have WRMS norm equal to 1. C The product is stored in z. This is computed by a C difference quotient, a call to F, and two calls to PSOL. C----------------------------------------------------------------------- C C On entry C C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). C C Y = array containing current dependent variable vector. C C SAVF = array containing current value of f(t,y). C C V = real array of length N (can be the same array as Z). C C WGHT = array of length N containing scale factors. C 1/WGHT(i) are the diagonal elements of the matrix D. C C FTEM = work array of length N. C C VTEM = work array of length N used to store the C unscaled version of V. C C WP = real work array used by preconditioner PSOL. C C IWP = integer work array used by preconditioner PSOL. C C HL0 = current value of (step size h) * (coefficient l0). C C JPRE = preconditioner type flag. C C C On return C C Z = array of length N containing desired scaled C matrix-vector product. C C IER = error flag from PSOL. C C NPSL = the number of calls to PSOL. C C In addition, this routine uses the Common variables TN, N, NFE. C----------------------------------------------------------------------- INTEGER I DOUBLE PRECISION FAC, RNORM, DNRM2, TEMPN C C Set VTEM = D * V. DO 10 I = 1,N VTEM(I) = V(I)/WGHT(I) 10 CONTINUE IER = 0 IF (JPRE .GE. 2) GO TO 30 C C JPRE = 0 or 1. Save Y in Z and increment Y by VTEM. CALL DCOPY (N, Y, 1, Z, 1) DO 20 I = 1,N Y(I) = Z(I) + VTEM(I) 20 CONTINUE FAC = HL0 GO TO 60 C C JPRE = 2 or 3. Apply inverse of right preconditioner to VTEM. 30 CONTINUE CALL PSOL (NEQ, TN, Y, SAVF, FTEM, HL0, WP, IWP, VTEM, 2, IER) NPSL = NPSL + 1 IF (IER .NE. 0) RETURN C Calculate L-2 norm of (D-inverse) * VTEM. DO 40 I = 1,N Z(I) = VTEM(I)*WGHT(I) 40 CONTINUE TEMPN = DNRM2 (N, Z, 1) RNORM = 1.0D0/TEMPN C Save Y in Z and increment Y by VTEM/norm. CALL DCOPY (N, Y, 1, Z, 1) DO 50 I = 1,N Y(I) = Z(I) + VTEM(I)*RNORM 50 CONTINUE FAC = HL0*TEMPN C C For all JPRE, call F with incremented Y argument, and restore Y. 60 CONTINUE CKS CALL F (NEQ, TN, Y, FTEM, rpar, ipar) NFE = NFE + 1 CALL DCOPY (N, Z, 1, Y, 1) C Set Z = (identity - hl0*Jacobian) * VTEM, using difference quotient. DO 70 I = 1,N Z(I) = FTEM(I) - SAVF(I) 70 CONTINUE DO 80 I = 1,N Z(I) = VTEM(I) - FAC*Z(I) 80 CONTINUE C Apply inverse of left preconditioner to Z, if nontrivial. IF (JPRE .EQ. 0 .OR. JPRE .EQ. 2) GO TO 85 CALL PSOL (NEQ, TN, Y, SAVF, FTEM, HL0, WP, IWP, Z, 1, IER) NPSL = NPSL + 1 IF (IER .NE. 0) RETURN 85 CONTINUE C Apply D-inverse to Z and return. DO 90 I = 1,N Z(I) = Z(I)*WGHT(I) 90 CONTINUE RETURN C----------------------- End of Subroutine DATV ------------------------ END *DECK DORTHOG SUBROUTINE DORTHOG (VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) INTEGER N, LL, LDHES, KMP DOUBLE PRECISION VNEW, V, HES, SNORMW DIMENSION VNEW(*), V(N,*), HES(LDHES,*) C----------------------------------------------------------------------- C This routine orthogonalizes the vector VNEW against the previous C KMP vectors in the V array. It uses a modified Gram-Schmidt C orthogonalization procedure with conditional reorthogonalization. C This is the version of 28 may 1986. C----------------------------------------------------------------------- C C On entry C C VNEW = the vector of length N containing a scaled product C of the Jacobian and the vector V(*,LL). C C V = the N x l array containing the previous LL C orthogonal vectors v(*,1) to v(*,LL). C C HES = an LL x LL upper Hessenberg matrix containing, C in HES(i,k), k.lt.LL, scaled inner products of C A*V(*,k) and V(*,i). C C LDHES = the leading dimension of the HES array. C C N = the order of the matrix A, and the length of VNEW. C C LL = the current order of the matrix HES. C C KMP = the number of previous vectors the new vector VNEW C must be made orthogonal to (KMP .le. MAXL). C C C On return C C VNEW = the new vector orthogonal to V(*,i0) to V(*,LL), C where i0 = MAX(1, LL-KMP+1). C C HES = upper Hessenberg matrix with column LL filled in with C scaled inner products of A*V(*,LL) and V(*,i). C C SNORMW = L-2 norm of VNEW. C C----------------------------------------------------------------------- INTEGER I, I0 DOUBLE PRECISION ARG, DDOT, DNRM2, SUMDSQ, TEM, VNRM C C Get norm of unaltered VNEW for later use. ---------------------------- VNRM = DNRM2 (N, VNEW, 1) C----------------------------------------------------------------------- C Do modified Gram-Schmidt on VNEW = A*v(LL). C Scaled inner products give new column of HES. C Projections of earlier vectors are subtracted from VNEW. C----------------------------------------------------------------------- I0 = MAX(1,LL-KMP+1) DO 10 I = I0,LL HES(I,LL) = DDOT (N, V(1,I), 1, VNEW, 1) TEM = -HES(I,LL) CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) 10 CONTINUE C----------------------------------------------------------------------- C Compute SNORMW = norm of VNEW. C If VNEW is small compared to its input value (in norm), then C reorthogonalize VNEW to V(*,1) through V(*,LL). C Correct if relative correction exceeds 1000*(unit roundoff). C finally, correct SNORMW using the dot products involved. C----------------------------------------------------------------------- SNORMW = DNRM2 (N, VNEW, 1) IF (VNRM + 0.001D0*SNORMW .NE. VNRM) RETURN SUMDSQ = 0.0D0 DO 30 I = I0,LL TEM = -DDOT (N, V(1,I), 1, VNEW, 1) IF (HES(I,LL) + 0.001D0*TEM .EQ. HES(I,LL)) GO TO 30 HES(I,LL) = HES(I,LL) - TEM CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) SUMDSQ = SUMDSQ + TEM**2 30 CONTINUE IF (SUMDSQ .EQ. 0.0D0) RETURN ARG = MAX(0.0D0,SNORMW**2 - SUMDSQ) SNORMW = SQRT(ARG) C RETURN C----------------------- End of Subroutine DORTHOG --------------------- END *DECK DSPIGMR SUBROUTINE DSPIGMR (NEQ, TN, Y, SAVF, B, WGHT, N, MAXL, MAXLP1, 1 KMP, DELTA, HL0, JPRE, MNEWT, F, PSOL, NPSL, X, V, HES, Q, 2 LGMR, WP, IWP, WK, DL, IFLAG,rpar,ipar) EXTERNAL F, PSOL integer ipar(*) double precision rpar(*) INTEGER NEQ,N,MAXL,MAXLP1,KMP,JPRE,MNEWT,NPSL,LGMR,IWP,IFLAG DOUBLE PRECISION TN,Y,SAVF,B,WGHT,DELTA,HL0,X,V,HES,Q,WP,WK,DL DIMENSION NEQ(*), Y(*), SAVF(*), B(*), WGHT(*), X(*), V(N,*), 1 HES(MAXLP1,*), Q(*), WP(*), IWP(*), WK(*), DL(*) C----------------------------------------------------------------------- C This routine solves the linear system A * x = b using a scaled C preconditioned version of the Generalized Minimal Residual method. C An initial guess of x = 0 is assumed. C----------------------------------------------------------------------- C C On entry C C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). C C TN = current value of t. C C Y = array containing current dependent variable vector. C C SAVF = array containing current value of f(t,y). C C B = the right hand side of the system A*x = b. C B is also used as work space when computing C the final approximation. C (B is the same as V(*,MAXL+1) in the call to DSPIGMR.) C C WGHT = the vector of length N containing the nonzero C elements of the diagonal scaling matrix. C C N = the order of the matrix A, and the lengths C of the vectors WGHT, B and X. C C MAXL = the maximum allowable order of the matrix HES. C C MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES. C C KMP = the number of previous vectors the new vector VNEW C must be made orthogonal to. KMP .le. MAXL. C C DELTA = tolerance on residuals b - A*x in weighted RMS-norm. C C HL0 = current value of (step size h) * (coefficient l0). C C JPRE = preconditioner type flag. C C MNEWT = Newton iteration counter (.ge. 0). C C WK = real work array used by routine DATV and PSOL. C C DL = real work array used for calculation of the residual C norm RHO when the method is incomplete (KMP .lt. MAXL). C Not needed or referenced in complete case (KMP = MAXL). C C WP = real work array used by preconditioner PSOL. C C IWP = integer work array used by preconditioner PSOL. C C On return C C X = the final computed approximation to the solution C of the system A*x = b. C C LGMR = the number of iterations performed and C the current order of the upper Hessenberg C matrix HES. C C NPSL = the number of calls to PSOL. C C V = the N by (LGMR+1) array containing the LGMR C orthogonal vectors V(*,1) to V(*,LGMR). C C HES = the upper triangular factor of the QR decomposition C of the (LGMR+1) by lgmr upper Hessenberg matrix whose C entries are the scaled inner-products of A*V(*,i) C and V(*,k). C C Q = real array of length 2*MAXL containing the components C of the Givens rotations used in the QR decomposition C of HES. It is loaded in DHEQR and used in DHELS. C C IFLAG = integer error flag: C 0 means convergence in LGMR iterations, LGMR .le. MAXL. C 1 means the convergence test did not pass in MAXL C iterations, but the residual norm is .lt. 1, C or .lt. norm(b) if MNEWT = 0, and so x is computed. C 2 means the convergence test did not pass in MAXL C iterations, residual .gt. 1, and X is undefined. C 3 means there was a recoverable error in PSOL C caused by the preconditioner being out of date. C -1 means there was a nonrecoverable error in PSOL. C C----------------------------------------------------------------------- INTEGER I, IER, INFO, IP1, I2, J, K, LL, LLP1 DOUBLE PRECISION BNRM,BNRM0,C,DLNRM,PROD,RHO,S,SNORMW,DNRM2,TEM C Karline: Initialised RHO to avoid warning RHO = 0.D0 IFLAG = 0 LGMR = 0 NPSL = 0 C----------------------------------------------------------------------- C The initial residual is the vector b. Apply scaling to b, and test C for an immediate return with X = 0 or X = b. C----------------------------------------------------------------------- DO 10 I = 1,N V(I,1) = B(I)*WGHT(I) 10 CONTINUE BNRM0 = DNRM2 (N, V, 1) BNRM = BNRM0 IF (BNRM0 .GT. DELTA) GO TO 30 IF (MNEWT .GT. 0) GO TO 20 CALL DCOPY (N, B, 1, X, 1) RETURN 20 DO 25 I = 1,N X(I) = 0.0D0 25 CONTINUE RETURN 30 CONTINUE C Apply inverse of left preconditioner to vector b. -------------------- IER = 0 IF (JPRE .EQ. 0 .OR. JPRE .EQ. 2) GO TO 55 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, B, 1, IER) NPSL = 1 IF (IER .NE. 0) GO TO 300 C Calculate norm of scaled vector V(*,1) and normalize it. ------------- DO 50 I = 1,N V(I,1) = B(I)*WGHT(I) 50 CONTINUE BNRM = DNRM2 (N, V, 1) DELTA = DELTA*(BNRM/BNRM0) 55 TEM = 1.0D0/BNRM CALL DSCAL (N, TEM, V(1,1), 1) C Zero out the HES array. ---------------------------------------------- DO 65 J = 1,MAXL DO 60 I = 1,MAXLP1 HES(I,J) = 0.0D0 60 CONTINUE 65 CONTINUE C----------------------------------------------------------------------- C Main loop to compute the vectors V(*,2) to V(*,MAXL). C The running product PROD is needed for the convergence test. C----------------------------------------------------------------------- PROD = 1.0D0 DO 90 LL = 1,MAXL LGMR = LL C----------------------------------------------------------------------- C Call routine DATV to compute VNEW = Abar*v(ll), where Abar is C the matrix A with scaling and inverse preconditioner factors applied. C Call routine DORTHOG to orthogonalize the new vector VNEW = V(*,LL+1). C Call routine DHEQR to update the factors of HES. C----------------------------------------------------------------------- CALL DATV (NEQ, Y, SAVF, V(1,LL), WGHT, X, F, PSOL, V(1,LL+1), 1 WK, WP, IWP, HL0, JPRE, IER, NPSL,rpar,ipar) IF (IER .NE. 0) GO TO 300 CALL DORTHOG (V(1,LL+1), V, HES, N, LL, MAXLP1, KMP, SNORMW) HES(LL+1,LL) = SNORMW CALL DHEQR (HES, MAXLP1, LL, Q, INFO, LL) IF (INFO .EQ. LL) GO TO 120 C----------------------------------------------------------------------- C Update RHO, the estimate of the norm of the residual b - A*xl. C If KMP .lt. MAXL, then the vectors V(*,1),...,V(*,LL+1) are not C necessarily orthogonal for LL .gt. KMP. The vector DL must then C be computed, and its norm used in the calculation of RHO. C----------------------------------------------------------------------- PROD = PROD*Q(2*LL) RHO = ABS(PROD*BNRM) IF ((LL.GT.KMP) .AND. (KMP.LT.MAXL)) THEN IF (LL .EQ. KMP+1) THEN CALL DCOPY (N, V(1,1), 1, DL, 1) DO 75 I = 1,KMP IP1 = I + 1 I2 = I*2 S = Q(I2) C = Q(I2-1) DO 70 K = 1,N DL(K) = S*DL(K) + C*V(K,IP1) 70 CONTINUE 75 CONTINUE ENDIF S = Q(2*LL) C = Q(2*LL-1)/SNORMW LLP1 = LL + 1 DO 80 K = 1,N DL(K) = S*DL(K) + C*V(K,LLP1) 80 CONTINUE DLNRM = DNRM2 (N, DL, 1) RHO = RHO*DLNRM ENDIF C----------------------------------------------------------------------- C Test for convergence. If passed, compute approximation xl. C if failed and LL .lt. MAXL, then continue iterating. C----------------------------------------------------------------------- IF (RHO .LE. DELTA) GO TO 200 IF (LL .EQ. MAXL) GO TO 100 C----------------------------------------------------------------------- C Rescale so that the norm of V(1,LL+1) is one. C----------------------------------------------------------------------- TEM = 1.0D0/SNORMW CALL DSCAL (N, TEM, V(1,LL+1), 1) 90 CONTINUE 100 CONTINUE IF (RHO .LE. 1.0D0) GO TO 150 IF (RHO .LE. BNRM .AND. MNEWT .EQ. 0) GO TO 150 120 CONTINUE IFLAG = 2 RETURN 150 IFLAG = 1 C----------------------------------------------------------------------- C Compute the approximation xl to the solution. C Since the vector X was used as work space, and the initial guess C of the Newton correction is zero, X must be reset to zero. C----------------------------------------------------------------------- 200 CONTINUE LL = LGMR LLP1 = LL + 1 DO 210 K = 1,LLP1 B(K) = 0.0D0 210 CONTINUE B(1) = BNRM CALL DHELS (HES, MAXLP1, LL, Q, B) DO 220 K = 1,N X(K) = 0.0D0 220 CONTINUE DO 230 I = 1,LL CALL DAXPY (N, B(I), V(1,I), 1, X, 1) 230 CONTINUE DO 240 I = 1,N X(I) = X(I)/WGHT(I) 240 CONTINUE IF (JPRE .LE. 1) RETURN CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, X, 2, IER) NPSL = NPSL + 1 IF (IER .NE. 0) GO TO 300 RETURN C----------------------------------------------------------------------- C This block handles error returns forced by routine PSOL. C----------------------------------------------------------------------- 300 CONTINUE IF (IER .LT. 0) IFLAG = -1 IF (IER .GT. 0) IFLAG = 3 C RETURN C----------------------- End of Subroutine DSPIGMR --------------------- END *DECK DPCG SUBROUTINE DPCG (NEQ, TN, Y, SAVF, R, WGHT, N, MAXL, DELTA, HL0, 1 JPRE, MNEWT, F, PSOL, NPSL, X, P, W, Z, LPCG, WP, IWP, WK, IFLAG, 2 rpar,ipar) EXTERNAL F, PSOL INTEGER NEQ, N, MAXL, JPRE, MNEWT, NPSL, LPCG, IWP, IFLAG,ipar(*) DOUBLE PRECISION TN,Y,SAVF,R,WGHT,DELTA,HL0,X,P,W,Z,WP,WK,rpar(*) DIMENSION NEQ(*), Y(*), SAVF(*), R(*), WGHT(*), X(*), P(*), W(*), 1 Z(*), WP(*), IWP(*), WK(*) C----------------------------------------------------------------------- C This routine computes the solution to the system A*x = b using a C preconditioned version of the Conjugate Gradient algorithm. C It is assumed here that the matrix A and the preconditioner C matrix M are symmetric positive definite or nearly so. C----------------------------------------------------------------------- C C On entry C C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). C C TN = current value of t. C C Y = array containing current dependent variable vector. C C SAVF = array containing current value of f(t,y). C C R = the right hand side of the system A*x = b. C C WGHT = array of length N containing scale factors. C 1/WGHT(i) are the diagonal elements of the diagonal C scaling matrix D. C C N = the order of the matrix A, and the lengths C of the vectors Y, SAVF, R, WGHT, P, W, Z, WK, and X. C C MAXL = the maximum allowable number of iterates. C C DELTA = tolerance on residuals b - A*x in weighted RMS-norm. C C HL0 = current value of (step size h) * (coefficient l0). C C JPRE = preconditioner type flag. C C MNEWT = Newton iteration counter (.ge. 0). C C WK = real work array used by routine DATP. C C WP = real work array used by preconditioner PSOL. C C IWP = integer work array used by preconditioner PSOL. C C On return C C X = the final computed approximation to the solution C of the system A*x = b. C C LPCG = the number of iterations performed, and current C order of the upper Hessenberg matrix HES. C C NPSL = the number of calls to PSOL. C C IFLAG = integer error flag: C 0 means convergence in LPCG iterations, LPCG .le. MAXL. C 1 means the convergence test did not pass in MAXL C iterations, but the residual norm is .lt. 1, C or .lt. norm(b) if MNEWT = 0, and so X is computed. C 2 means the convergence test did not pass in MAXL C iterations, residual .gt. 1, and X is undefined. C 3 means there was a recoverable error in PSOL C caused by the preconditioner being out of date. C 4 means there was a zero denominator in the algorithm. C The system matrix or preconditioner matrix is not C sufficiently close to being symmetric pos. definite. C -1 means there was a nonrecoverable error in PSOL. C C----------------------------------------------------------------------- INTEGER I, IER DOUBLE PRECISION ALPHA,BETA,BNRM,PTW,RNRM,DDOT,DVNORM,ZTR,ZTR0 C IFLAG = 0 NPSL = 0 LPCG = 0 DO 10 I = 1,N X(I) = 0.0D0 10 CONTINUE BNRM = DVNORM (N, R, WGHT) C Test for immediate return with X = 0 or X = b. ----------------------- IF (BNRM .GT. DELTA) GO TO 20 IF (MNEWT .GT. 0) RETURN CALL DCOPY (N, R, 1, X, 1) RETURN C 20 ZTR = 0.0D0 C Loop point for PCG iterations. --------------------------------------- 30 CONTINUE LPCG = LPCG + 1 CALL DCOPY (N, R, 1, Z, 1) IER = 0 IF (JPRE .EQ. 0) GO TO 40 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, Z, 3, IER) NPSL = NPSL + 1 IF (IER .NE. 0) GO TO 100 40 CONTINUE ZTR0 = ZTR ZTR = DDOT (N, Z, 1, R, 1) IF (LPCG .NE. 1) GO TO 50 CALL DCOPY (N, Z, 1, P, 1) GO TO 70 50 CONTINUE IF (ZTR0 .EQ. 0.0D0) GO TO 200 BETA = ZTR/ZTR0 DO 60 I = 1,N P(I) = Z(I) + BETA*P(I) 60 CONTINUE 70 CONTINUE C----------------------------------------------------------------------- C Call DATP to compute A*p and return the answer in W. C----------------------------------------------------------------------- CALL DATP (NEQ, Y, SAVF, P, WGHT, HL0, WK, F, W, rpar,ipar) C PTW = DDOT (N, P, 1, W, 1) IF (PTW .EQ. 0.0D0) GO TO 200 ALPHA = ZTR/PTW CALL DAXPY (N, ALPHA, P, 1, X, 1) ALPHA = -ALPHA CALL DAXPY (N, ALPHA, W, 1, R, 1) RNRM = DVNORM (N, R, WGHT) IF (RNRM .LE. DELTA) RETURN IF (LPCG .LT. MAXL) GO TO 30 IFLAG = 2 IF (RNRM .LE. 1.0D0) IFLAG = 1 IF (RNRM .LE. BNRM .AND. MNEWT .EQ. 0) IFLAG = 1 RETURN C----------------------------------------------------------------------- C This block handles error returns from PSOL. C----------------------------------------------------------------------- 100 CONTINUE IF (IER .LT. 0) IFLAG = -1 IF (IER .GT. 0) IFLAG = 3 RETURN C----------------------------------------------------------------------- C This block handles division by zero errors. C----------------------------------------------------------------------- 200 CONTINUE IFLAG = 4 RETURN C----------------------- End of Subroutine DPCG ------------------------ END *DECK DPCGS SUBROUTINE DPCGS (NEQ, TN, Y, SAVF, R, WGHT, N, MAXL, DELTA, HL0, 1 JPRE, MNEWT, F, PSOL, NPSL, X, P, W, Z, LPCG, WP, IWP, WK, IFLAG, 2 rpar,ipar) EXTERNAL F, PSOL INTEGER NEQ, N, MAXL, JPRE, MNEWT, NPSL, LPCG, IWP, IFLAG,ipar(*) DOUBLE PRECISION TN,Y,SAVF,R,WGHT,DELTA,HL0,X,P,W,Z,WP,WK,rpar(*) DIMENSION NEQ(*), Y(*), SAVF(*), R(*), WGHT(*), X(*), P(*), W(*), 1 Z(*), WP(*), IWP(*), WK(*) C----------------------------------------------------------------------- C This routine computes the solution to the system A*x = b using a C scaled preconditioned version of the Conjugate Gradient algorithm. C It is assumed here that the scaled matrix D**-1 * A * D and the C scaled preconditioner D**-1 * M * D are close to being C symmetric positive definite. C----------------------------------------------------------------------- C C On entry C C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). C C TN = current value of t. C C Y = array containing current dependent variable vector. C C SAVF = array containing current value of f(t,y). C C R = the right hand side of the system A*x = b. C C WGHT = array of length N containing scale factors. C 1/WGHT(i) are the diagonal elements of the diagonal C scaling matrix D. C C N = the order of the matrix A, and the lengths C of the vectors Y, SAVF, R, WGHT, P, W, Z, WK, and X. C C MAXL = the maximum allowable number of iterates. C C DELTA = tolerance on residuals b - A*x in weighted RMS-norm. C C HL0 = current value of (step size h) * (coefficient l0). C C JPRE = preconditioner type flag. C C MNEWT = Newton iteration counter (.ge. 0). C C WK = real work array used by routine DATP. C C WP = real work array used by preconditioner PSOL. C C IWP = integer work array used by preconditioner PSOL. C C On return C C X = the final computed approximation to the solution C of the system A*x = b. C C LPCG = the number of iterations performed, and current C order of the upper Hessenberg matrix HES. C C NPSL = the number of calls to PSOL. C C IFLAG = integer error flag: C 0 means convergence in LPCG iterations, LPCG .le. MAXL. C 1 means the convergence test did not pass in MAXL C iterations, but the residual norm is .lt. 1, C or .lt. norm(b) if MNEWT = 0, and so X is computed. C 2 means the convergence test did not pass in MAXL C iterations, residual .gt. 1, and X is undefined. C 3 means there was a recoverable error in PSOL C caused by the preconditioner being out of date. C 4 means there was a zero denominator in the algorithm. C the scaled matrix or scaled preconditioner is not C sufficiently close to being symmetric pos. definite. C -1 means there was a nonrecoverable error in PSOL. C C----------------------------------------------------------------------- INTEGER I, IER DOUBLE PRECISION ALPHA, BETA, BNRM, PTW, RNRM, DVNORM, ZTR, ZTR0 C IFLAG = 0 NPSL = 0 LPCG = 0 DO 10 I = 1,N X(I) = 0.0D0 10 CONTINUE BNRM = DVNORM (N, R, WGHT) C Test for immediate return with X = 0 or X = b. ----------------------- IF (BNRM .GT. DELTA) GO TO 20 IF (MNEWT .GT. 0) RETURN CALL DCOPY (N, R, 1, X, 1) RETURN C 20 ZTR = 0.0D0 C Loop point for PCG iterations. --------------------------------------- 30 CONTINUE LPCG = LPCG + 1 CALL DCOPY (N, R, 1, Z, 1) IER = 0 IF (JPRE .EQ. 0) GO TO 40 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, Z, 3, IER) NPSL = NPSL + 1 IF (IER .NE. 0) GO TO 100 40 CONTINUE ZTR0 = ZTR ZTR = 0.0D0 DO 45 I = 1,N ZTR = ZTR + Z(I)*R(I)*WGHT(I)**2 45 CONTINUE IF (LPCG .NE. 1) GO TO 50 CALL DCOPY (N, Z, 1, P, 1) GO TO 70 50 CONTINUE IF (ZTR0 .EQ. 0.0D0) GO TO 200 BETA = ZTR/ZTR0 DO 60 I = 1,N P(I) = Z(I) + BETA*P(I) 60 CONTINUE 70 CONTINUE C----------------------------------------------------------------------- C Call DATP to compute A*p and return the answer in W. C----------------------------------------------------------------------- CALL DATP (NEQ, Y, SAVF, P, WGHT, HL0, WK, F, W, rpar,ipar) C PTW = 0.0D0 DO 80 I = 1,N PTW = PTW + P(I)*W(I)*WGHT(I)**2 80 CONTINUE IF (PTW .EQ. 0.0D0) GO TO 200 ALPHA = ZTR/PTW CALL DAXPY (N, ALPHA, P, 1, X, 1) ALPHA = -ALPHA CALL DAXPY (N, ALPHA, W, 1, R, 1) RNRM = DVNORM (N, R, WGHT) IF (RNRM .LE. DELTA) RETURN IF (LPCG .LT. MAXL) GO TO 30 IFLAG = 2 IF (RNRM .LE. 1.0D0) IFLAG = 1 IF (RNRM .LE. BNRM .AND. MNEWT .EQ. 0) IFLAG = 1 RETURN C----------------------------------------------------------------------- C This block handles error returns from PSOL. C----------------------------------------------------------------------- 100 CONTINUE IF (IER .LT. 0) IFLAG = -1 IF (IER .GT. 0) IFLAG = 3 RETURN C----------------------------------------------------------------------- C This block handles division by zero errors. C----------------------------------------------------------------------- 200 CONTINUE IFLAG = 4 RETURN C----------------------- End of Subroutine DPCGS ----------------------- END *DECK DATP SUBROUTINE DATP (NEQ, Y, SAVF, P, WGHT, HL0, WK, F, W,rpar,ipar) EXTERNAL F INTEGER NEQ, ipar(*) DOUBLE PRECISION Y, SAVF, P, WGHT, HL0, WK, W, rpar(*) DIMENSION NEQ(*), Y(*), SAVF(*), P(*), WGHT(*), WK(*), W(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C----------------------------------------------------------------------- C This routine computes the product C C w = (I - hl0*df/dy)*p C C This is computed by a call to F and a difference quotient. C----------------------------------------------------------------------- C C On entry C C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). C C Y = array containing current dependent variable vector. C C SAVF = array containing current value of f(t,y). C C P = real array of length N. C C WGHT = array of length N containing scale factors. C 1/WGHT(i) are the diagonal elements of the matrix D. C C WK = work array of length N. C C On return C C C W = array of length N containing desired C matrix-vector product. C C In addition, this routine uses the Common variables TN, N, NFE. C----------------------------------------------------------------------- INTEGER I DOUBLE PRECISION FAC, PNRM, RPNRM, DVNORM C PNRM = DVNORM (N, P, WGHT) RPNRM = 1.0D0/PNRM CALL DCOPY (N, Y, 1, W, 1) DO 20 I = 1,N Y(I) = W(I) + P(I)*RPNRM 20 CONTINUE CKS CALL F (NEQ, TN, Y, WK, rpar, ipar) NFE = NFE + 1 CALL DCOPY (N, W, 1, Y, 1) FAC = HL0*PNRM DO 40 I = 1,N W(I) = P(I) - FAC*(WK(I) - SAVF(I)) 40 CONTINUE RETURN C----------------------- End of Subroutine DATP ------------------------ END *DECK DUSOL SUBROUTINE DUSOL (NEQ, TN, Y, SAVF, B, WGHT, N, DELTA, HL0, MNEWT, 1 PSOL, NPSL, X, WP, IWP, WK, IFLAG) EXTERNAL PSOL INTEGER NEQ, N, MNEWT, NPSL, IWP, IFLAG DOUBLE PRECISION TN, Y, SAVF, B, WGHT, DELTA, HL0, X, WP, WK DIMENSION NEQ(*), Y(*), SAVF(*), B(*), WGHT(*), X(*), 1 WP(*), IWP(*), WK(*) C----------------------------------------------------------------------- C This routine solves the linear system A * x = b using only a call C to the user-supplied routine PSOL (no Krylov iteration). C If the norm of the right-hand side vector b is smaller than DELTA, C the vector X returned is X = b (if MNEWT = 0) or X = 0 otherwise. C PSOL is called with an LR argument of 0. C----------------------------------------------------------------------- C C On entry C C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). C C TN = current value of t. C C Y = array containing current dependent variable vector. C C SAVF = array containing current value of f(t,y). C C B = the right hand side of the system A*x = b. C C WGHT = the vector of length N containing the nonzero C elements of the diagonal scaling matrix. C C N = the order of the matrix A, and the lengths C of the vectors WGHT, B and X. C C DELTA = tolerance on residuals b - A*x in weighted RMS-norm. C C HL0 = current value of (step size h) * (coefficient l0). C C MNEWT = Newton iteration counter (.ge. 0). C C WK = real work array used by PSOL. C C WP = real work array used by preconditioner PSOL. C C IWP = integer work array used by preconditioner PSOL. C C On return C C X = the final computed approximation to the solution C of the system A*x = b. C C NPSL = the number of calls to PSOL. C C IFLAG = integer error flag: C 0 means no trouble occurred. C 3 means there was a recoverable error in PSOL C caused by the preconditioner being out of date. C -1 means there was a nonrecoverable error in PSOL. C C----------------------------------------------------------------------- INTEGER I, IER DOUBLE PRECISION BNRM, DVNORM C IFLAG = 0 NPSL = 0 C----------------------------------------------------------------------- C Test for an immediate return with X = 0 or X = b. C----------------------------------------------------------------------- BNRM = DVNORM (N, B, WGHT) IF (BNRM .GT. DELTA) GO TO 30 IF (MNEWT .GT. 0) GO TO 10 CALL DCOPY (N, B, 1, X, 1) RETURN 10 DO 20 I = 1,N X(I) = 0.0D0 20 CONTINUE RETURN C Make call to PSOL and copy result from B to X. ----------------------- 30 IER = 0 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, B, 0, IER) NPSL = 1 IF (IER .NE. 0) GO TO 100 CALL DCOPY (N, B, 1, X, 1) RETURN C----------------------------------------------------------------------- C This block handles error returns forced by routine PSOL. C----------------------------------------------------------------------- 100 CONTINUE IF (IER .LT. 0) IFLAG = -1 IF (IER .GT. 0) IFLAG = 3 RETURN C----------------------- End of Subroutine DUSOL ----------------------- END *DECK DSRCPK *DECK DHEFA SUBROUTINE DHEFA (A, LDA, N, IPVT, INFO, JOB) INTEGER LDA, N, IPVT(*), INFO, JOB DOUBLE PRECISION A(LDA,*) C----------------------------------------------------------------------- C This routine is a modification of the LINPACK routine DGEFA and C performs an LU decomposition of an upper Hessenberg matrix A. C There are two options available: C C (1) performing a fresh factorization C (2) updating the LU factors by adding a row and a C column to the matrix A. C----------------------------------------------------------------------- C DHEFA factors an upper Hessenberg matrix by elimination. C C On entry C C A DOUBLE PRECISION(LDA, N) C the matrix to be factored. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C JOB INTEGER C JOB = 1 means that a fresh factorization of the C matrix A is desired. C JOB .ge. 2 means that the current factorization of A C will be updated by the addition of a row C and a column. C C On return C C A an upper triangular matrix and the multipliers C which were used to obtain it. C The factorization can be written A = L*U where C L is a product of permutation and unit lower C triangular matrices and U is upper triangular. C C IPVT INTEGER(N) C an integer vector of pivot indices. C C INFO INTEGER C = 0 normal value. C = k if U(k,k) .eq. 0.0 . This is not an error C condition for this subroutine, but it does C indicate that DHESL will divide by zero if called. C C Modification of LINPACK, by Peter Brown, LLNL. C Written 7/20/83. This version dated 6/20/01. C C BLAS called: DAXPY, IDAMAX C----------------------------------------------------------------------- INTEGER IDAMAX, J, K, KM1, KP1, L, NM1 DOUBLE PRECISION T C IF (JOB .GT. 1) GO TO 80 C C A new facorization is desired. This is essentially the LINPACK C code with the exception that we know there is only one nonzero C element below the main diagonal. C C Gaussian elimination with partial pivoting C INFO = 0 NM1 = N - 1 IF (NM1 .LT. 1) GO TO 70 DO 60 K = 1, NM1 KP1 = K + 1 C C Find L = pivot index C L = IDAMAX (2, A(K,K), 1) + K - 1 IPVT(K) = L C C Zero pivot implies this column already triangularized C IF (A(L,K) .EQ. 0.0D0) GO TO 40 C C Interchange if necessary C IF (L .EQ. K) GO TO 10 T = A(L,K) A(L,K) = A(K,K) A(K,K) = T 10 CONTINUE C C Compute multipliers C T = -1.0D0/A(K,K) A(K+1,K) = A(K+1,K)*T C C Row elimination with column indexing C DO 30 J = KP1, N T = A(L,J) IF (L .EQ. K) GO TO 20 A(L,J) = A(K,J) A(K,J) = T 20 CONTINUE CALL DAXPY (N-K, T, A(K+1,K), 1, A(K+1,J), 1) 30 CONTINUE GO TO 50 40 CONTINUE INFO = K 50 CONTINUE 60 CONTINUE 70 CONTINUE IPVT(N) = N IF (A(N,N) .EQ. 0.0D0) INFO = N RETURN C C The old factorization of A will be updated. A row and a column C has been added to the matrix A. C N-1 is now the old order of the matrix. C 80 CONTINUE NM1 = N - 1 C C Perform row interchanges on the elements of the new column, and C perform elimination operations on the elements using the multipliers. C IF (NM1 .LE. 1) GO TO 105 DO 100 K = 2,NM1 KM1 = K - 1 L = IPVT(KM1) T = A(L,N) IF (L .EQ. KM1) GO TO 90 A(L,N) = A(KM1,N) A(KM1,N) = T 90 CONTINUE A(K,N) = A(K,N) + A(K,KM1)*T 100 CONTINUE 105 CONTINUE C C Complete update of factorization by decomposing last 2x2 block. C INFO = 0 C C Find L = pivot index C L = IDAMAX (2, A(NM1,NM1), 1) + NM1 - 1 IPVT(NM1) = L C C Zero pivot implies this column already triangularized C IF (A(L,NM1) .EQ. 0.0D0) GO TO 140 C C Interchange if necessary C IF (L .EQ. NM1) GO TO 110 T = A(L,NM1) A(L,NM1) = A(NM1,NM1) A(NM1,NM1) = T 110 CONTINUE C C Compute multipliers C T = -1.0D0/A(NM1,NM1) A(N,NM1) = A(N,NM1)*T C C Row elimination with column indexing C T = A(L,N) IF (L .EQ. NM1) GO TO 120 A(L,N) = A(NM1,N) A(NM1,N) = T 120 CONTINUE A(N,N) = A(N,N) + T*A(N,NM1) GO TO 150 140 CONTINUE INFO = NM1 150 CONTINUE IPVT(N) = N IF (A(N,N) .EQ. 0.0D0) INFO = N RETURN C----------------------- End of Subroutine DHEFA ----------------------- END *DECK DHESL SUBROUTINE DHESL (A, LDA, N, IPVT, B) INTEGER LDA, N, IPVT(*) DOUBLE PRECISION A(LDA,*), B(*) C----------------------------------------------------------------------- C This is essentially the LINPACK routine DGESL except for changes C due to the fact that A is an upper Hessenberg matrix. C----------------------------------------------------------------------- C DHESL solves the real system A * x = b C using the factors computed by DHEFA. C C On entry C C A DOUBLE PRECISION(LDA, N) C the output from DHEFA. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C IPVT INTEGER(N) C the pivot vector from DHEFA. C C B DOUBLE PRECISION(N) C the right hand side vector. C C On return C C B the solution vector x . C C Modification of LINPACK, by Peter Brown, LLNL. C Written 7/20/83. This version dated 6/20/01. C C BLAS called: DAXPY C----------------------------------------------------------------------- INTEGER K, KB, L, NM1 DOUBLE PRECISION T C NM1 = N - 1 C C Solve A * x = b C First solve L*y = b C IF (NM1 .LT. 1) GO TO 30 DO 20 K = 1, NM1 L = IPVT(K) T = B(L) IF (L .EQ. K) GO TO 10 B(L) = B(K) B(K) = T 10 CONTINUE B(K+1) = B(K+1) + T*A(K+1,K) 20 CONTINUE 30 CONTINUE C C Now solve U*x = y C DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/A(K,K) T = -B(K) CALL DAXPY (K-1, T, A(1,K), 1, B(1), 1) 40 CONTINUE RETURN C----------------------- End of Subroutine DHESL ----------------------- END *DECK DHEQR SUBROUTINE DHEQR (A, LDA, N, Q, INFO, IJOB) INTEGER LDA, N, INFO, IJOB DOUBLE PRECISION A(LDA,*), Q(*) C----------------------------------------------------------------------- C This routine performs a QR decomposition of an upper C Hessenberg matrix A. There are two options available: C C (1) performing a fresh decomposition C (2) updating the QR factors by adding a row and a C column to the matrix A. C----------------------------------------------------------------------- C DHEQR decomposes an upper Hessenberg matrix by using Givens C rotations. C C On entry C C A DOUBLE PRECISION(LDA, N) C the matrix to be decomposed. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C A is an (N+1) by N Hessenberg matrix. C C IJOB INTEGER C = 1 means that a fresh decomposition of the C matrix A is desired. C .ge. 2 means that the current decomposition of A C will be updated by the addition of a row C and a column. C On return C C A the upper triangular matrix R. C The factorization can be written Q*A = R, where C Q is a product of Givens rotations and R is upper C triangular. C C Q DOUBLE PRECISION(2*N) C the factors c and s of each Givens rotation used C in decomposing A. C C INFO INTEGER C = 0 normal value. C = k if A(k,k) .eq. 0.0 . This is not an error C condition for this subroutine, but it does C indicate that DHELS will divide by zero C if called. C C Modification of LINPACK, by Peter Brown, LLNL. C Written 1/13/86. This version dated 6/20/01. C----------------------------------------------------------------------- INTEGER I, IQ, J, K, KM1, KP1, NM1 DOUBLE PRECISION C, S, T, T1, T2 C IF (IJOB .GT. 1) GO TO 70 C C A new facorization is desired. C C QR decomposition without pivoting C INFO = 0 DO 60 K = 1, N KM1 = K - 1 KP1 = K + 1 C C Compute kth column of R. C First, multiply the kth column of A by the previous C k-1 Givens rotations. C IF (KM1 .LT. 1) GO TO 20 DO 10 J = 1, KM1 I = 2*(J-1) + 1 T1 = A(J,K) T2 = A(J+1,K) C = Q(I) S = Q(I+1) A(J,K) = C*T1 - S*T2 A(J+1,K) = S*T1 + C*T2 10 CONTINUE C C Compute Givens components c and s C 20 CONTINUE IQ = 2*KM1 + 1 T1 = A(K,K) T2 = A(KP1,K) IF (T2 .NE. 0.0D0) GO TO 30 C = 1.0D0 S = 0.0D0 GO TO 50 30 CONTINUE IF (ABS(T2) .LT. ABS(T1)) GO TO 40 T = T1/T2 S = -1.0D0/SQRT(1.0D0+T*T) C = -S*T GO TO 50 40 CONTINUE T = T2/T1 C = 1.0D0/SQRT(1.0D0+T*T) S = -C*T 50 CONTINUE Q(IQ) = C Q(IQ+1) = S A(K,K) = C*T1 - S*T2 IF (A(K,K) .EQ. 0.0D0) INFO = K 60 CONTINUE RETURN C C The old factorization of A will be updated. A row and a column C has been added to the matrix A. C N by N-1 is now the old size of the matrix. C 70 CONTINUE NM1 = N - 1 C C Multiply the new column by the N previous Givens rotations. C DO 100 K = 1,NM1 I = 2*(K-1) + 1 T1 = A(K,N) T2 = A(K+1,N) C = Q(I) S = Q(I+1) A(K,N) = C*T1 - S*T2 A(K+1,N) = S*T1 + C*T2 100 CONTINUE C C Complete update of decomposition by forming last Givens rotation, C and multiplying it times the column vector (A(N,N), A(N+1,N)). C INFO = 0 T1 = A(N,N) T2 = A(N+1,N) IF (T2 .NE. 0.0D0) GO TO 110 C = 1.0D0 S = 0.0D0 GO TO 130 110 CONTINUE IF (ABS(T2) .LT. ABS(T1)) GO TO 120 T = T1/T2 S = -1.0D0/SQRT(1.0D0+T*T) C = -S*T GO TO 130 120 CONTINUE T = T2/T1 C = 1.0D0/SQRT(1.0D0+T*T) S = -C*T 130 CONTINUE IQ = 2*N - 1 Q(IQ) = C Q(IQ+1) = S A(N,N) = C*T1 - S*T2 IF (A(N,N) .EQ. 0.0D0) INFO = N RETURN C----------------------- End of Subroutine DHEQR ----------------------- END *DECK DHELS SUBROUTINE DHELS (A, LDA, N, Q, B) INTEGER LDA, N DOUBLE PRECISION A(LDA,*), B(*), Q(*) C----------------------------------------------------------------------- C This is part of the LINPACK routine DGESL with changes C due to the fact that A is an upper Hessenberg matrix. C----------------------------------------------------------------------- C DHELS solves the least squares problem C C min (b-A*x, b-A*x) C C using the factors computed by DHEQR. C C On entry C C A DOUBLE PRECISION(LDA, N) C the output from DHEQR which contains the upper C triangular factor R in the QR decomposition of A. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C A is originally an (N+1) by N matrix. C C Q DOUBLE PRECISION(2*N) C The coefficients of the N givens rotations C used in the QR factorization of A. C C B DOUBLE PRECISION(N+1) C the right hand side vector. C C On return C C B the solution vector x . C C Modification of LINPACK, by Peter Brown, LLNL. C Written 1/13/86. This version dated 6/20/01. C C BLAS called: DAXPY C----------------------------------------------------------------------- INTEGER IQ, K, KB, KP1 DOUBLE PRECISION C, S, T, T1, T2 C C Minimize (b-A*x, b-A*x) C First form Q*b. C DO 20 K = 1, N KP1 = K + 1 IQ = 2*(K-1) + 1 C = Q(IQ) S = Q(IQ+1) T1 = B(K) T2 = B(KP1) B(K) = C*T1 - S*T2 B(KP1) = S*T1 + C*T2 20 CONTINUE C C Now solve R*x = Q*b. C DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/A(K,K) T = -B(K) CALL DAXPY (K-1, T, A(1,K), 1, B(1), 1) 40 CONTINUE RETURN C----------------------- End of Subroutine DHELS ----------------------- END *DECK DLHIN SUBROUTINE DLHIN (NEQ, N, T0, Y0, YDOT, F, TOUT, UROUND, 1 EWT, ITOL, ATOL, Y, TEMP, H0, NITER, IER, rpar,ipar) EXTERNAL F DOUBLE PRECISION T0, Y0, YDOT, TOUT, UROUND, EWT, ATOL, Y, 1 TEMP, H0 INTEGER NEQ, N, ITOL, NITER, IER integer ipar(*) double precision rpar(*) DIMENSION NEQ(*), Y0(*), YDOT(*), EWT(*), ATOL(*), Y(*), TEMP(*) C----------------------------------------------------------------------- C Call sequence input -- NEQ, N, T0, Y0, YDOT, F, TOUT, UROUND, C EWT, ITOL, ATOL, Y, TEMP C Call sequence output -- H0, NITER, IER C Common block variables accessed -- None C C Subroutines called by DLHIN: F, DCOPY C Function routines called by DLHIN: DVNORM C----------------------------------------------------------------------- C This routine computes the step size, H0, to be attempted on the C first step, when the user has not supplied a value for this. C C First we check that TOUT - T0 differs significantly from zero. Then C an iteration is done to approximate the initial second derivative C and this is used to define H from WRMS-norm(H**2 * yddot / 2) = 1. C A bias factor of 1/2 is applied to the resulting h. C The sign of H0 is inferred from the initial values of TOUT and T0. C C Communication with DLHIN is done with the following variables: C C NEQ = NEQ array of solver, passed to F. C N = size of ODE system, input. C T0 = initial value of independent variable, input. C Y0 = vector of initial conditions, input. C YDOT = vector of initial first derivatives, input. C F = name of subroutine for right-hand side f(t,y), input. C TOUT = first output value of independent variable C UROUND = machine unit roundoff C EWT, ITOL, ATOL = error weights and tolerance parameters C as described in the driver routine, input. C Y, TEMP = work arrays of length N. C H0 = step size to be attempted, output. C NITER = number of iterations (and of f evaluations) to compute H0, C output. C IER = the error flag, returned with the value C IER = 0 if no trouble occurred, or C IER = -1 if TOUT and t0 are considered too close to proceed. C----------------------------------------------------------------------- C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION AFI, ATOLI, DELYI, HALF, HG, HLB, HNEW, HRAT, 1 HUB, HUN, PT1, T1, TDIST, TROUND, TWO, DVNORM, YDDNRM INTEGER I, ITER C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE HALF, HUN, PT1, TWO DATA HALF /0.5D0/, HUN /100.0D0/, PT1 /0.1D0/, TWO /2.0D0/ C NITER = 0 TDIST = ABS(TOUT - T0) TROUND = UROUND*MAX(ABS(T0),ABS(TOUT)) IF (TDIST .LT. TWO*TROUND) GO TO 100 C C Set a lower bound on H based on the roundoff level in T0 and TOUT. --- HLB = HUN*TROUND C Set an upper bound on H based on TOUT-T0 and the initial Y and YDOT. - HUB = PT1*TDIST ATOLI = ATOL(1) DO 10 I = 1,N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) DELYI = PT1*ABS(Y0(I)) + ATOLI AFI = ABS(YDOT(I)) IF (AFI*HUB .GT. DELYI) HUB = DELYI/AFI 10 CONTINUE C C Set initial guess for H as geometric mean of upper and lower bounds. - ITER = 0 HG = SQRT(HLB*HUB) C If the bounds have crossed, exit with the mean value. ---------------- IF (HUB .LT. HLB) THEN H0 = HG GO TO 90 ENDIF C C Looping point for iteration. ----------------------------------------- 50 CONTINUE C Estimate the second derivative as a difference quotient in f. -------- T1 = T0 + HG DO 60 I = 1,N Y(I) = Y0(I) + HG*YDOT(I) 60 CONTINUE CKS CALL F (NEQ, T1, Y, TEMP, rpar, ipar) DO 70 I = 1,N TEMP(I) = (TEMP(I) - YDOT(I))/HG 70 CONTINUE YDDNRM = DVNORM (N, TEMP, EWT) C Get the corresponding new value of H. -------------------------------- IF (YDDNRM*HUB*HUB .GT. TWO) THEN HNEW = SQRT(TWO/YDDNRM) ELSE HNEW = SQRT(HG*HUB) ENDIF ITER = ITER + 1 C----------------------------------------------------------------------- C Test the stopping conditions. C Stop if the new and previous H values differ by a factor of .lt. 2. C Stop if four iterations have been done. Also, stop with previous H C if hnew/hg .gt. 2 after first iteration, as this probably means that C the second derivative value is bad because of cancellation error. C----------------------------------------------------------------------- IF (ITER .GE. 4) GO TO 80 HRAT = HNEW/HG IF ( (HRAT .GT. HALF) .AND. (HRAT .LT. TWO) ) GO TO 80 IF ( (ITER .GE. 2) .AND. (HNEW .GT. TWO*HG) ) THEN HNEW = HG GO TO 80 ENDIF HG = HNEW GO TO 50 C C Iteration done. Apply bounds, bias factor, and sign. ---------------- 80 H0 = HNEW*HALF IF (H0 .LT. HLB) H0 = HLB IF (H0 .GT. HUB) H0 = HUB 90 H0 = SIGN(H0, TOUT - T0) C Restore Y array from Y0, then exit. ---------------------------------- CALL DCOPY (N, Y0, 1, Y, 1) NITER = ITER IER = 0 RETURN C Error return for TOUT - T0 too small. -------------------------------- 100 IER = -1 RETURN C----------------------- End of Subroutine DLHIN ----------------------- END deSolve/src/dvode.f0000644000176000001440000031754113572134422013760 0ustar ripleyusersC Original authors: Peter N. Brown,, Alan C. Hindmarsh, C Geore D. Byrne (see references and author statement below) C C Adapted for use in R package deSolve by the deSolve authors. C C********************************************************************* C MAIN VODE DRIVER C********************************************************************* SUBROUTINE DVODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, & & ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF, & & RPAR, IPAR) EXTERNAL F, JAC DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK, RPAR INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, & & MF, IPAR C KARLINE: CHANGED RTOL(1),ATOL(1) : was: RTOL(LRW),ATOL(LIW)!!! C Thomas: changed (1) to (*) DIMENSION Y(NEQ), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW), & & RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Revision History (YYMMDD) C 890615 Date Written C 890922 Added interrupt/restart ability, minor changes throughout. C 910228 Minor revisions in line format, prologue, etc. C 920227 Modifications by D. Pang: C (1) Applied subgennam to get generic intrinsic names. C (2) Changed intrinsic names to generic in comments. C (3) Added *DECK lines before each routine. C 920721 Names of routines and labeled Common blocks changed, so as C to be unique in combined single/double precision code (ACH). C 920722 Minor revisions to prologue (ACH). C 920831 Conversion to double precision done (ACH). C----------------------------------------------------------------------- C References.. C C 1. P. N. Brown, G. D. Byrne, and A. C. Hindmarsh, "VODE: A Variable C Coefficient ODE Solver," SIAM J. Sci. Stat. Comput., 10 (1989), C pp. 1038-1051. Also, LLNL Report UCRL-98412, June 1988. C 2. G. D. Byrne and A. C. Hindmarsh, "A Polyalgorithm for the C Numerical Solution of Ordinary Differential Equations," C ACM Trans. Math. Software, 1 (1975), pp. 71-96. C 3. A. C. Hindmarsh and G. D. Byrne, "EPISODE: An Effective Package C for the Integration of Systems of Ordinary Differential C Equations," LLNL Report UCID-30112, Rev. 1, April 1977. C 4. G. D. Byrne and A. C. Hindmarsh, "EPISODEB: An Experimental C Package for the Integration of Systems of Ordinary Differential C Equations with Banded Jacobians," LLNL Report UCID-30132, April C 1976. C 5. A. C. Hindmarsh, "ODEPACK, a Systematized Collection of ODE C Solvers," in Scientific Computing, R. S. Stepleman et al., eds., C North-Holland, Amsterdam, 1983, pp. 55-64. C 6. K. R. Jackson and R. Sacks-Davis, "An Alternative Implementation C of Variable Step-Size Multistep Formulas for Stiff ODEs," ACM C Trans. Math. Software, 6 (1980), pp. 295-318. C----------------------------------------------------------------------- C Authors.. C C Peter N. Brown and Alan C. Hindmarsh C Computing and Mathematics Research Division, L-316 C Lawrence Livermore National Laboratory C Livermore, CA 94550 C and C George D. Byrne C Exxon Research and Engineering Co. C Clinton Township C Route 22 East C Annandale, NJ 08801 C----------------------------------------------------------------------- C Summary of usage. C C Communication between the user and the DVODE package, for normal C situations, is summarized here. This summary describes only a subset C of the full set of options available. See the full description for C details, including optional communication, nonstandard options, C and instructions for special situations. See also the example C problem (with program and output) following this summary. C C A. First provide a subroutine of the form.. C C SUBROUTINE F (NEQ, T, Y, YDOT, RPAR, IPAR) C DOUBLE PRECISION T, Y, YDOT, RPAR C DIMENSION Y(NEQ), YDOT(NEQ) C C which supplies the vector function f by loading YDOT(i) with f(i). C C B. Next determine (or guess) whether or not the problem is stiff. C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue C whose real part is negative and large in magnitude, compared to the C reciprocal of the t span of interest. If the problem is nonstiff, C use a method flag MF = 10. If it is stiff, there are four standard C choices for MF (21, 22, 24, 25), and DVODE requires the Jacobian C matrix in some form. In these cases (MF .gt. 0), DVODE will use a C saved copy of the Jacobian matrix. If this is undesirable because of C storage limitations, set MF to the corresponding negative value C (-21, -22, -24, -25). (See full description of MF below.) C The Jacobian matrix is regarded either as full (MF = 21 or 22), C or banded (MF = 24 or 25). In the banded case, DVODE requires two C half-bandwidth parameters ML and MU. These are, respectively, the C widths of the lower and upper parts of the band, excluding the main C diagonal. Thus the band consists of the locations (i,j) with C i-ML .le. j .le. i+MU, and the full bandwidth is ML+MU+1. C C C. If the problem is stiff, you are encouraged to supply the Jacobian C directly (MF = 21 or 24), but if this is not feasible, DVODE will C compute it internally by difference quotients (MF = 22 or 25). C If you are supplying the Jacobian, provide a subroutine of the form.. C C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, RPAR, IPAR) C DOUBLE PRECISION T, Y, PD, RPAR C DIMENSION Y(NEQ), PD(NROWPD,NEQ) C C which supplies df/dy by loading PD as follows.. C For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j), C the partial derivative of f(i) with respect to y(j). (Ignore the C ML and MU arguments in this case.) C For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with C df(i)/dy(j), i.e. load the diagonal lines of df/dy into the rows of C PD from the top down. C In either case, only nonzero elements need be loaded. C C D. Write a main program which calls subroutine DVODE once for C each point at which answers are desired. This should also provide C for possible use of logical unit 6 for output of error messages C by DVODE. On the first call to DVODE, supply arguments as follows.. C F = Name of subroutine for right-hand side vector f. C This name must be declared external in calling program. C NEQ = Number of first order ODE-s. C Y = Array of initial values, of length NEQ. C T = The initial value of the independent variable. C TOUT = First point where output is desired (.ne. T). C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. C RTOL = Relative tolerance parameter (scalar). C ATOL = Absolute tolerance parameter (scalar or array). C The estimated local error in Y(i) will be controlled so as C to be roughly less (in magnitude) than C EWT(i) = RTOL*abs(Y(i)) + ATOL if ITOL = 1, or C EWT(i) = RTOL*abs(Y(i)) + ATOL(i) if ITOL = 2. C Thus the local error test passes if, in each component, C either the absolute error is less than ATOL (or ATOL(i)), C or the relative error is less than RTOL. C Use RTOL = 0.0 for pure absolute error control, and C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error C control. Caution.. Actual (global) errors may exceed these C local tolerances, so choose them conservatively. C ITASK = 1 for normal computation of output values of Y at t = TOUT. C ISTATE = Integer flag (input and output). Set ISTATE = 1. C IOPT = 0 to indicate no optional input used. C RWORK = Real work array of length at least.. C 20 + 16*NEQ for MF = 10, C 22 + 9*NEQ + 2*NEQ**2 for MF = 21 or 22, C 22 + 11*NEQ + (3*ML + 2*MU)*NEQ for MF = 24 or 25. C LRW = Declared length of RWORK (in user's DIMENSION statement). C IWORK = Integer work array of length at least.. C 30 for MF = 10, C 30 + NEQ for MF = 21, 22, 24, or 25. C If MF = 24 or 25, input in IWORK(1),IWORK(2) the lower C and upper half-bandwidths ML,MU. C LIW = Declared length of IWORK (in user's DIMENSION). C JAC = Name of subroutine for Jacobian matrix (MF = 21 or 24). C If used, this name must be declared external in calling C program. If not used, pass a dummy name. C MF = Method flag. Standard values are.. C 10 for nonstiff (Adams) method, no Jacobian used. C 21 for stiff (BDF) method, user-supplied full Jacobian. C 22 for stiff method, internally generated full Jacobian. C 24 for stiff method, user-supplied banded Jacobian. C 25 for stiff method, internally generated banded Jacobian. C RPAR,IPAR = user-defined real and integer arrays passed to F and JAC. C Note that the main program must declare arrays Y, RWORK, IWORK, C and possibly ATOL, RPAR, and IPAR. C C E. The output from the first call (or any call) is.. C Y = Array of computed values of y(t) vector. C T = Corresponding value of independent variable (normally TOUT). C ISTATE = 2 if DVODE was successful, negative otherwise. C -1 means excess work done on this call. (Perhaps wrong MF.) C -2 means excess accuracy requested. (Tolerances too small.) C -3 means illegal input detected. (See printed message.) C -4 means repeated error test failures. (Check all input.) C -5 means repeated convergence failures. (Perhaps bad C Jacobian supplied or wrong choice of MF or tolerances.) C -6 means error weight became zero during problem. (Solution C component i vanished, and ATOL or ATOL(i) = 0.) C C F. To continue the integration after a successful return, simply C reset TOUT and call DVODE again. No other parameters need be reset. C C----------------------------------------------------------------------- C Other Routines in the DVODE Package. C C In addition to subroutine DVODE, the DVODE package includes the C following subroutines and function routines.. C DVHIN computes an approximate step size for the initial step. C DVINDY computes an interpolated value of the y vector at t = TOUT. C DVSTEP is the core integrator, which does one step of the C integration and the associated error control. C DVSET sets all method coefficients and test constants. C DVNLSD solves the underlying nonlinear system -- the corrector. C DVJAC computes and preprocesses the Jacobian matrix J = df/dy C and the Newton iteration matrix P = I - (h/l1)*J. C DVSOL manages solution of linear system in chord iteration. C DVJUST adjusts the history array on a change of order. C DEWSET sets the error weight vector EWT before each step. C DVNORM computes the weighted r.m.s. norm of a vector. C DVSRCO is a user-callable routines to save and restore C the contents of the internal COMMON blocks. C DACOPY is a routine to copy one two-dimensional array to another. C DGEFA and DGESL are routines from LINPACK for solving full C systems of linear algebraic equations. C DGBFA and DGBSL are routines from LINPACK for solving banded C linear systems. C DAXPY, DSCAL, and DCOPY are basic linear algebra modules (BLAS). C D1MACH sets the unit roundoff of the machine. C XERRWD, LUNSAV, and MFLGSV handle the printing of all C error messages and warnings. XERRWD is machine-dependent. C Note.. DVNORM, D1MACH, LUNSAV, and MFLGSV are function routines. C All the others are subroutines. C C The intrinsic and external routines used by the DVODE package are.. C ABS, MAX, MIN, REAL, SIGN, SQRT, and WRITE. C C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block DVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C C Type declarations for labeled COMMON block DVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C EXTERNAL DVNLSD LOGICAL IHIT DOUBLE PRECISION ATOLI, BIG, EWTI, FOUR, H0, HMAX, HMX, HUN, ONE, & & PT2, RH, RTOLI, SIZE, TCRIT, TNEXT, TOLSF, TP, TWO, ZERO INTEGER I, IER, IFLAG, IMXER, JCO, KGO, LENIW, LENJ, LENP, LENRW, & & LENWM, LF0, MBAND, MFA, ML, MORD, MU, MXHNL0, MXSTP0, NITER, & & NSLAST C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION D1MACH, DVNORM C DIMENSION MORD(2) SAVE MORD, MXHNL0, MXSTP0 SAVE ZERO, ONE, TWO, FOUR, PT2, HUN COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU(13), TQ(5), TN, UROUND, & & ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA MORD(1) /12/, MORD(2) /5/, MXSTP0 /500/, MXHNL0 /10/ DATA ZERO /0.0D0/, ONE /1.0D0/, TWO /2.0D0/, FOUR /4.0D0/, & & PT2 /0.2D0/, HUN /100.0D0/ C----------------------------------------------------------------------- C Block A. C This code block is executed on every call. C It tests ISTATE and ITASK for legality and branches appropriately. C If ISTATE .gt. 1 but the flag INIT shows that initialization has C not yet been done, an error return occurs. C If ISTATE = 1 and TOUT = T, return immediately. C----------------------------------------------------------------------- C KARLINE: INITIALISED IHIT TO AVOID COMPILER WARNINGS - SHOULD HAVE NO EFFEXT IHIT = .TRUE. IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 IF (ISTATE .EQ. 1) GO TO 10 IF (INIT .NE. 1) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) RETURN C----------------------------------------------------------------------- C Block B. C The next code block is executed for the initial call (ISTATE = 1), C or for a continuation call with parameter changes (ISTATE = 3). C It contains checking of all input and various initializations. C C First check legality of the non-optional input NEQ, ITOL, IOPT, C MF, ML, and MU. C----------------------------------------------------------------------- 20 IF (NEQ .LE. 0) GO TO 604 IF (ISTATE .EQ. 1) GO TO 25 IF (NEQ .GT. N) GO TO 605 25 N = NEQ IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 JSV = SIGN(1,MF) C Karline: applied changes from 941222 MFA = ABS(MF) METH = MFA/10 MITER = MFA - 10*METH IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 IF (MITER .LE. 3) GO TO 30 ML = IWORK(1) MU = IWORK(2) IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 30 CONTINUE C Next process and check the optional input. --------------------------- IF (IOPT .EQ. 1) GO TO 40 MAXORD = MORD(METH) MXSTEP = MXSTP0 MXHNIL = MXHNL0 IF (ISTATE .EQ. 1) H0 = ZERO HMXI = ZERO HMIN = ZERO GO TO 60 40 MAXORD = IWORK(5) IF (MAXORD .LT. 0) GO TO 611 IF (MAXORD .EQ. 0) MAXORD = 100 MAXORD = MIN(MAXORD,MORD(METH)) MXSTEP = IWORK(6) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .NE. 1) GO TO 50 H0 = RWORK(5) IF ((TOUT - T)*H0 .LT. ZERO) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. ZERO) GO TO 615 HMXI = ZERO IF (HMAX .GT. ZERO) HMXI = ONE/HMAX HMIN = RWORK(7) IF (HMIN .LT. ZERO) GO TO 616 C----------------------------------------------------------------------- C Set work array pointers and check lengths LRW and LIW. C Pointers to segments of RWORK and IWORK are named by prefixing L to C the name of the segment. E.g., the segment YH starts at RWORK(LYH). C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR. C Within WM, LOCJS is the location of the saved Jacobian (JSV .gt. 0). C----------------------------------------------------------------------- 60 LYH = 21 IF (ISTATE .EQ. 1) NYH = N LWM = LYH + (MAXORD + 1)*NYH JCO = MAX(0,JSV) IF (MITER .EQ. 0) LENWM = 0 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN LENWM = 2 + (1 + JCO)*N*N LOCJS = N*N + 3 ENDIF IF (MITER .EQ. 3) LENWM = 2 + N IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN MBAND = ML + MU + 1 LENP = (MBAND + ML)*N LENJ = MBAND*N LENWM = 2 + LENP + JCO*LENJ LOCJS = LENP + 3 ENDIF LEWT = LWM + LENWM LSAVF = LEWT + N LACOR = LSAVF + N LENRW = LACOR + N - 1 IWORK(17) = LENRW LIWM = 1 LENIW = 30 + N IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 30 IWORK(18) = LENIW IF (LENRW .GT. LRW) GO TO 617 IF (LENIW .GT. LIW) GO TO 618 C Check RTOL and ATOL for legality. ------------------------------------ RTOLI = RTOL(1) ATOLI = ATOL(1) DO 70 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. ZERO) GO TO 619 IF (ATOLI .LT. ZERO) GO TO 620 70 CONTINUE IF (ISTATE .EQ. 1) GO TO 100 C If ISTATE = 3, set flag to signal parameter changes to DVSTEP. ------- JSTART = -1 IF (NQ .LE. MAXORD) GO TO 90 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- CALL DCOPY (N, RWORK(LWM), 1, RWORK(LSAVF), 1) C Reload WM(1) = RWORK(LWM), since LWM may have changed. --------------- 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) GO TO 200 C Karline: correction 19981111 added C----------------------------------------------------------------------- C Block C. C The next block is for the initial call only (ISTATE = 1). C It contains all remaining initializations, the initial call to F, C and the calculation of the initial step size. C The error weights in EWT are inverted after being loaded. C----------------------------------------------------------------------- 100 UROUND = D1MACH(4) TN = T IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. ZERO) GO TO 625 IF (H0 .NE. ZERO .AND. (T + H0 - TCRIT)*H0 .GT. ZERO) & & H0 = TCRIT - T 110 JSTART = 0 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) CCMXJ = PT2 MSBJ = 50 NHNIL = 0 NST = 0 NJE = 0 NNI = 0 NCFN = 0 NETF = 0 NLU = 0 NSLJ = 0 NSLAST = 0 HU = ZERO NQU = 0 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- LF0 = LYH + NYH CALL F (N, T, Y, RWORK(LF0), RPAR, IPAR) NFE = 1 C Load the initial value vector in YH. --------------------------------- CALL DCOPY (N, Y, 1, RWORK(LYH), 1) C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- NQ = 1 H = ONE CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 120 I = 1,N IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 621 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) 120 CONTINUE IF (H0 .NE. ZERO) GO TO 180 C Call DVHIN to set initial step size H0 to be attempted. -------------- CALL DVHIN (N, T, RWORK(LYH), RWORK(LF0), F, RPAR, IPAR, TOUT, & & UROUND, RWORK(LEWT), ITOL, ATOL, Y, RWORK(LACOR), H0, & & NITER, IER) NFE = NFE + NITER IF (IER .NE. 0) GO TO 622 C Adjust H0 if necessary to meet HMAX bound. --------------------------- 180 RH = ABS(H0)*HMXI IF (RH .GT. ONE) H0 = H0/RH C Load H with H0 and scale YH(*,2) by H0. ------------------------------ H = H0 CALL DSCAL (N, H0, RWORK(LF0), 1) GO TO 270 C----------------------------------------------------------------------- C Block D. C The next code block is for continuation calls only (ISTATE = 2 or 3) C and is to check stop conditions before taking a step. C----------------------------------------------------------------------- 200 NSLAST = NST KUTH = 0 C GO TO (210, 250, 220, 230, 240), ITASK SELECT CASE (ITASK) CASE (1) GOTO 210 CASE (2) GOTO 250 CASE (3) GOTO 220 CASE (4) GOTO 230 CASE (5) GOTO 240 END SELECT 210 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(ONE + HUN*UROUND) IF ((TP - TOUT)*H .GT. ZERO) GO TO 623 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 IF ((TCRIT - TOUT)*H .LT. ZERO) GO TO 625 IF ((TN - TOUT)*H .LT. ZERO) GO TO 245 CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 245 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + HNEW*(ONE + FOUR*UROUND) IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 H = (TCRIT - TN)*(ONE - FOUR*UROUND) KUTH = 1 C----------------------------------------------------------------------- C Block E. C The next block is normally executed for all calls and contains C the call to the one-step core integrator DVSTEP. C C This is a looping point for the integration steps. C C First check for too many steps being taken, update EWT (if not at C start of problem), check for too much accuracy being requested, and C check for H below the roundoff level in T. C----------------------------------------------------------------------- 250 CONTINUE IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 260 I = 1,N IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 510 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) 260 CONTINUE 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) IF (TOLSF .LE. ONE) GO TO 280 TOLSF = TOLSF*TWO IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 call rprintf( & 'dvode -- Warning.. Internal T (=R1) and H (=R2) are' // char(0)) call rprintf( & ' such that in the machine, T + H = T on the next step' & // char(0)) call rprintf( & ' (H = step size). Solver will continue anyway.' & // char(0)) call rprintfd2('In above message, R1 = %g, R2 = %g' // char(0), & TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 call rprintf( & 'dvode -- Above warning has been issued I1 times. ') call rprintf( & ' it will not be issued again for this problem.' & // char(0)) call rprintfi1('In above message, I1 = %i' // char(0), MXHNIL) 290 CONTINUE C----------------------------------------------------------------------- C CALL DVSTEP (Y, YH, NYH, YH, EWT, SAVF, VSAV, ACOR, C WM, IWM, F, JAC, F, DVNLSD, RPAR, IPAR) C----------------------------------------------------------------------- CALL DVSTEP (Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), & & RWORK(LSAVF), Y, RWORK(LACOR), RWORK(LWM), IWORK(LIWM), & & F, JAC, F, DVNLSD, RPAR, IPAR) KGO = 1 - KFLAG C Branch on KFLAG. Note..In this version, KFLAG can not be set to -3. C KFLAG .eq. 0, -1, -2 C GO TO (300, 530, 540), KGO SELECT CASE(KGO) CASE(1) GOTO 300 CASE(2) GOTO 530 CASE(3) GOTO 540 END SELECT C----------------------------------------------------------------------- C Block F. C The following block handles the case of a successful return from the C core integrator (KFLAG = 0). Test for stop conditions. C----------------------------------------------------------------------- 300 INIT = 1 KUTH = 0 C GO TO (310, 400, 330, 340, 350), ITASK SELECT CASE(ITASK) CASE(1) GOTO 310 CASE(2) GOTO 400 CASE(3) GOTO 330 CASE(4) GOTO 340 CASE(5) GOTO 350 END SELECT C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 310 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 330 IF ((TN - TOUT)*H .GE. ZERO) GO TO 400 GO TO 250 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 340 IF ((TN - TOUT)*H .LT. ZERO) GO TO 345 CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 345 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + HNEW*(ONE + FOUR*UROUND) IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 H = (TCRIT - TN)*(ONE - FOUR*UROUND) KUTH = 1 GO TO 250 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 350 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX C----------------------------------------------------------------------- C Block G. C The following block handles all successful returns from DVODE. C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. C ISTATE is set to 2, and the optional output is loaded into the work C arrays before returning. C----------------------------------------------------------------------- 400 CONTINUE CALL DCOPY (N, RWORK(LYH), 1, Y, 1) T = TN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 IF (IHIT) T = TCRIT 420 ISTATE = 2 RWORK(11) = HU RWORK(12) = HNEW RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NEWQ IWORK(19) = NLU IWORK(20) = NNI IWORK(21) = NCFN IWORK(22) = NETF RETURN C----------------------------------------------------------------------- C Block H. C The following block handles all unsuccessful returns other than C those for illegal input. First the error message routine is called. C if there was an error test or convergence test failure, IMXER is set. C Then Y is loaded from YH, T is set to TN, and the illegal input C The optional output is loaded into the work arrays before returning. C----------------------------------------------------------------------- C The maximum number of steps was taken before reaching TOUT. ---------- 500 call rprintf( 1 'dvode -- At current T (=R1), MXSTEP (=I1) steps' // char(0)) call rprintf( 2 ' taken on this call before reaching TOUT' // char(0)) call rprintfdi( & ' with: R1 = %g, I1=%i' // char(0), TN, MXSTEP) ISTATE = -1 GO TO 580 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 510 EWTI = RWORK(LEWT+I-1) call rprintf( 1 'dvode -- At T (=R1), EWT(=I1) has become < 0 ' // char(0)) call rprintfdi( & ' with R1 = %g, I1 = %i' //char(0), TN, I) ISTATE = -6 GO TO 580 C Too much accuracy requested for machine precision. ------------------- 520 call rprintf( 1 'dvode -- At T (=R1), too much accuracy requested' // char(0)) call rprintf( 2 ' for precision of machine.. see TOLSF (=R2)' // char(0)) call rprintfd2( & ' with R1 = %g, R2 = %g' //char(0), TN , TOLSF ) RWORK(14) = TOLSF ISTATE = -2 GO TO 580 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 530 call rprintf( 1 'dvode -- At T (=R1), and step size H (=R2) the error'//char(0)) call rprintf( 2 ' test failed repeatedly or with abs(H) = HMIN' //char(0)) call rprintfd2( & ' with R1 = %g, R2 = %g' //char(0), TN, H ) ISTATE = -4 GO TO 560 C KFLAG = -2. Convergence failed repeatedly or with abs(H) = HMIN. ---- 540 call rprintf( 1 'dvode -- At T (=R1), and step size H (=R2) the' // char(0)) call rprintf( 2 ' corrector converged failed repeatedly' // char(0)) call rprintf( 3 ' or with abs(H) = HMIN ' // char(0)) call rprintfd2( & ' with: R1= %g, R2 = %g' // char(0), TN, H) ISTATE = -5 C Compute IMXER if relevant. ------------------------------------------- 560 BIG = ZERO IMXER = 1 DO 570 I = 1,N SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) IF (BIG .GE. SIZE) GO TO 570 BIG = SIZE IMXER = I 570 CONTINUE IWORK(16) = IMXER C Set Y vector, T, and optional output. -------------------------------- 580 CONTINUE CALL DCOPY (N, RWORK(LYH), 1, Y, 1) T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = NLU IWORK(20) = NNI IWORK(21) = NCFN IWORK(22) = NETF RETURN C----------------------------------------------------------------------- C Block I. C The following block handles all error returns due to illegal input C (ISTATE = -3), as detected before calling the core integrator. C First the error message routine is called. If the illegal input C is a negative ISTATE, the run is aborted (apparent infinite loop). C----------------------------------------------------------------------- 601 call rprintfi1( 1 'dvode -- ISTATE (=I1) illegal %i' // char(0), ISTATE) IF (ISTATE .LT. 0) GO TO 800 GO TO 700 602 call rprintfi1( 1 'dvode -- ITASK (=I1) illegal %i' // char(0), ITASK) GO TO 700 603 call rprintfi1( 1 'dvode -- ISTATE (=I1) >1 but dvode not initialised %i' & // char(0), ISTATE) GO TO 700 604 call rprintfi1( 1 'dvode -- NEQ (=I1) <1 %i' // char(0), NEQ) GO TO 700 605 call rprintfi2( 1 'dvode -- ISTATE =3 and NEQ increased (I1 to I2), %i, %i' & // char(0), N, NEQ) GO TO 700 606 call rprintfi1( 1 'dvode -- ITOL (=I1) illegal %i' // char(0), ITOL) GO TO 700 607 call rprintfi1( 1 'dvode -- IOPT (=I1) illegal %i' // char(0), IOPT) GO TO 700 608 call rprintfi1( 1 'dvode -- MF (=I1) illegal %i' // char(0), MF) GO TO 700 609 call rprintfi2( 1 'dvode -- ML (=I1) illegal: <0 or >=neq (+I2) %i, %i' & // char(0), ML,NEQ) GO TO 700 610 call rprintfi2( 1 'dvode -- MU (=I1) illegal: <= 0 or > neq (=I2) %i, %i' & // char(0), MU,NEQ) GO TO 700 611 call rprintfi1( 1 'dvode -- MAXORD (=I1) < 0 %i' // char(0), MAXORD) GO TO 700 612 call rprintfi1( 1 'dvode -- MXSTEP (=I1) < 0 %i' // char(0), MXSTEP) GO TO 700 613 call rprintfi1( 1 'dvode -- MXHNIL (=I1) < 0 %i' // char(0), MXHNIL) GO TO 700 614 call rprintfd2( 1 'dvode -- TOUT (=R1) behind T (=R2) %g, %g' & // char(0), TOUT, T ) GO TO 700 615 call rprintfd1( 1 'dvode -- HMAX (=R1) <= 0 %g' // char(0), HMAX) GO TO 700 616 call rprintfd1( 1 'dvode -- HMIN (=R1) <=0 %g' // char(0), HMIN) GO TO 700 617 CONTINUE call rprintfi2( 1 'dvode -- RWORK length needed, LENRW (=I1) exceeds LRW (=I2) & %i, %i' // char(0), LENRW, LRW) GO TO 700 618 CONTINUE call rprintfi2( 1 'dvode -- IWORK length needed, LENIW (=I1) exceeds LIW (=I2) & %i, %i' // char(0), LENIW, LIW) GO TO 700 619 call rprintfid( 1 'dvode -- RTOL(I1) is R1 < 0 %i, %g' // char(0), I, RTOLI) GO TO 700 620 call rprintfid( 1 'dvode -- ATOL (I1) is R1 < 0 %i, %g' // char(0), I, ATOLI ) GO TO 700 621 EWTI = RWORK(LEWT+I-1) call rprintfid( 1 'dvode -- EWT (I1) is R1 <= 0 %i, %g' // char(0), I, EWTI) GO TO 700 622 CONTINUE call rprintfd2( 1 'dvode -- TOUT (=R1) too close to T (=R2) to start integration' & // '%g, %g' // char(0), TOUT, T ) GO TO 700 623 CONTINUE call rprintfi1( 1 'dvode -- ITASK = I1 %i', ITASK) call rprintfd2( 2 'and TOUT (=R1) behind TCUR-HU (=R2) %g, %g' & // char(0), TOUT, TP) GO TO 700 624 CONTINUE call rprintfd2( 1 'dvode -- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2)' & // ' &g, %g' // char(0), TCRIT, TN) GO TO 700 625 CONTINUE call rprintfd2( 1 'dvode -- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2)' & // ' %g, %g' // char(0), TCRIT, TOUT) GO TO 700 626 call rprintf( 1 'dvode -- at start of problem, too much accuracy' // char(0)) call rprintfd1( 2 ' requested for precision of machine.. & see TOLSF (=R1) %g' // char(0), TOLSF) RWORK(14) = TOLSF GO TO 700 627 call rprintfid( 1 'dvode -- trouble from DVINDY. ITASK = I1, TOUT = R1 %i, %g' & // char(0), ITASK, TOUT) C 700 CONTINUE ISTATE = -3 RETURN C 800 call rprintf( 1 'dvode -- run aborted.. apparent infinite loop' // char(0)) RETURN C----------------------- End of Subroutine DVODE ----------------------- END C*********************************************************************** CDECK DVHIN SUBROUTINE DVHIN (N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND, & & EWT, ITOL, ATOL, Y, TEMP, H0, NITER, IER) EXTERNAL F DOUBLE PRECISION T0, Y0, YDOT, RPAR, TOUT, UROUND, EWT, ATOL, Y, & & TEMP, H0 INTEGER N, IPAR, ITOL, NITER, IER DIMENSION Y0(*), YDOT(*), EWT(*), ATOL(*), Y(*), & & TEMP(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call sequence input -- N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND, C EWT, ITOL, ATOL, Y, TEMP C Call sequence output -- H0, NITER, IER C COMMON block variables accessed -- None C C Subroutines called by DVHIN.. F C Function routines called by DVHIN.. DVNORM C----------------------------------------------------------------------- C This routine computes the step size, H0, to be attempted on the C first step, when the user has not supplied a value for this. C C First we check that TOUT - T0 differs significantly from zero. Then C an iteration is done to approximate the initial second derivative C and this is used to define h from w.r.m.s.norm(h**2 * yddot / 2) = 1. C A bias factor of 1/2 is applied to the resulting h. C The sign of H0 is inferred from the initial values of TOUT and T0. C C Communication with DVHIN is done with the following variables.. C C N = Size of ODE system, input. C T0 = Initial value of independent variable, input. C Y0 = Vector of initial conditions, input. C YDOT = Vector of initial first derivatives, input. C F = Name of subroutine for right-hand side f(t,y), input. C RPAR, IPAR = Dummy names for user's real and integer work arrays. C TOUT = First output value of independent variable C UROUND = Machine unit roundoff C EWT, ITOL, ATOL = Error weights and tolerance parameters C as described in the driver routine, input. C Y, TEMP = Work arrays of length N. C H0 = Step size to be attempted, output. C NITER = Number of iterations (and of f evaluations) to compute H0, C output. C IER = The error flag, returned with the value C IER = 0 if no trouble occurred, or C IER = -1 if TOUT and T0 are considered too close to proceed. C----------------------------------------------------------------------- C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION AFI, ATOLI, DELYI, HALF, HG, HLB, HNEW, HRAT, & & HUB, HUN, PT1, T1, TDIST, TROUND, TWO, YDDNRM,H INTEGER I, ITER C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION DVNORM C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE HALF, HUN, PT1, TWO DATA HALF /0.5D0/, HUN /100.0D0/, PT1 /0.1D0/, TWO /2.0D0/ C NITER = 0 TDIST = ABS(TOUT - T0) TROUND = UROUND*MAX(ABS(T0),ABS(TOUT)) IF (TDIST .LT. TWO*TROUND) GO TO 100 C C Set a lower bound on h based on the roundoff level in T0 and TOUT. --- HLB = HUN*TROUND C Set an upper bound on h based on TOUT-T0 and the initial Y and YDOT. - HUB = PT1*TDIST ATOLI = ATOL(1) DO 10 I = 1, N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) DELYI = PT1*ABS(Y0(I)) + ATOLI AFI = ABS(YDOT(I)) IF (AFI*HUB .GT. DELYI) HUB = DELYI/AFI 10 CONTINUE C C Set initial guess for h as geometric mean of upper and lower bounds. - ITER = 0 HG = SQRT(HLB*HUB) C If the bounds have crossed, exit with the mean value. ---------------- IF (HUB .LT. HLB) THEN H0 = HG GO TO 90 ENDIF C C Looping point for iteration. ----------------------------------------- 50 CONTINUE C Estimate the second derivative as a difference quotient in f. -------- H = SIGN (HG, TOUT - T0) C Revision 941222 included (KS) T1 = T0 + H DO 60 I = 1, N Y(I) = Y0(I) + H*YDOT(I) 60 CONTINUE CALL F (N, T1, Y, TEMP, RPAR, IPAR) DO 70 I = 1, N TEMP(I) = (TEMP(I) - YDOT(I))/H 70 CONTINUE YDDNRM = DVNORM (N, TEMP, EWT) C Get the corresponding new value of h. -------------------------------- IF (YDDNRM*HUB*HUB .GT. TWO) THEN HNEW = SQRT(TWO/YDDNRM) ELSE HNEW = SQRT(HG*HUB) ENDIF ITER = ITER + 1 C----------------------------------------------------------------------- C Test the stopping conditions. C Stop if the new and previous h values differ by a factor of .lt. 2. C Stop if four iterations have been done. Also, stop with previous h C if HNEW/HG .gt. 2 after first iteration, as this probably means that C the second derivative value is bad because of cancellation error. C----------------------------------------------------------------------- IF (ITER .GE. 4) GO TO 80 HRAT = HNEW/HG IF ( (HRAT .GT. HALF) .AND. (HRAT .LT. TWO) ) GO TO 80 IF ( (ITER .GE. 2) .AND. (HNEW .GT. TWO*HG) ) THEN HNEW = HG GO TO 80 ENDIF HG = HNEW GO TO 50 C C Iteration done. Apply bounds, bias factor, and sign. Then exit. ---- 80 H0 = HNEW*HALF IF (H0 .LT. HLB) H0 = HLB IF (H0 .GT. HUB) H0 = HUB 90 H0 = SIGN(H0, TOUT - T0) NITER = ITER IER = 0 RETURN C Error return for TOUT - T0 too small. -------------------------------- 100 IER = -1 RETURN C----------------------- End of Subroutine DVHIN ----------------------- END CDECK DVINDY C*********************************************************************** SUBROUTINE DVINDY (T, K, YH, LDYH, DKY, IFLAG) DOUBLE PRECISION T, YH, DKY INTEGER K, LDYH, IFLAG DIMENSION YH(LDYH,*), DKY(*) C----------------------------------------------------------------------- C Call sequence input -- T, K, YH, LDYH C Call sequence output -- DKY, IFLAG C COMMON block variables accessed.. C /DVOD01/ -- H, TN, UROUND, L, N, NQ C /DVOD02/ -- HU C C Subroutines called by DVINDY.. DSCAL, XERRWD C Function routines called by DVINDY.. None C----------------------------------------------------------------------- C DVINDY computes interpolated values of the K-th derivative of the C dependent variable vector y, and stores it in DKY. This routine C is called within the package with K = 0 and T = TOUT, but may C also be called by the user for any K up to the current order. C (See detailed instructions in the usage documentation.) C----------------------------------------------------------------------- C The computed values in DKY are gotten by interpolation using the C Nordsieck history array YH. This array corresponds uniquely to a C vector-valued polynomial of degree NQCUR or less, and DKY is set C to the K-th derivative of this polynomial at T. C The formula for DKY is.. C q C DKY(i) = sum c(j,K) * (T - TN)**(j-K) * H**(-j) * YH(i,j+1) C j=K C where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, TN = TCUR, H = HCUR. C The quantities NQ = NQCUR, L = NQ+1, N, TN, and H are C communicated by COMMON. The above sum is done in reverse order. C IFLAG is returned negative if either K or T is out of bounds. C C Discussion above and comments in driver explain all variables. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block DVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C C Type declarations for labeled COMMON block DVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION C, HUN, R, S, TFUZZ, TN1, TP, ZERO INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE HUN, ZERO C COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU(13), TQ(5), TN, UROUND, & & ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA HUN /100.0D0/, ZERO /0.0D0/ C IFLAG = 0 IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 TFUZZ = HUN*UROUND*(TN + HU) TP = TN - HU - TFUZZ TN1 = TN + TFUZZ IF ((T-TP)*(T-TN1) .GT. ZERO) GO TO 90 C S = (T - TN)/H IC = 1 IF (K .EQ. 0) GO TO 15 JJ1 = L - K DO 10 JJ = JJ1, NQ IC = IC*JJ 10 CONTINUE 15 C = REAL(IC) DO 20 I = 1, N DKY(I) = C*YH(I,L) 20 CONTINUE IF (K .EQ. NQ) GO TO 55 JB2 = NQ - K DO 50 JB = 1, JB2 J = NQ - JB JP1 = J + 1 IC = 1 IF (K .EQ. 0) GO TO 35 JJ1 = JP1 - K DO 30 JJ = JJ1, J IC = IC*JJ 30 CONTINUE 35 C = REAL(IC) DO 40 I = 1, N DKY(I) = C*YH(I,JP1) + S*DKY(I) 40 CONTINUE 50 CONTINUE IF (K .EQ. 0) RETURN 55 R = H**(-K) CALL DSCAL (N, R, DKY, 1) RETURN C 80 call rprinti1( 1 'dvode -- DVINDY -- K (=I1) illegal ', K) IFLAG = -1 RETURN 90 call rprintd1( 1 'dvode -- DVINDY -- T (=R1) illegal ', T) call rprintd2( 1 'dvode -- T not in interval TCUR-HU (=R1) to TCUR (=R2) ', 2 TP,TN) IFLAG = -2 RETURN C----------------------- End of Subroutine DVINDY ---------------------- END C*********************************************************************** CDECK DVSTEP SUBROUTINE DVSTEP (Y, YH, LDYH, YH1, EWT, SAVF, VSAV, ACOR, & & WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR) EXTERNAL F, JAC, PSOL, VNLS DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, VSAV, ACOR, WM, RPAR INTEGER LDYH, IWM, IPAR DIMENSION Y(*), YH(LDYH,*), YH1(*), EWT(*), SAVF(*), VSAV(*), & & ACOR(*), WM(*), IWM(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call sequence input -- Y, YH, LDYH, YH1, EWT, SAVF, VSAV, C ACOR, WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR C Call sequence output -- YH, ACOR, WM, IWM C COMMON block variables accessed.. C /DVOD01/ ACNRM, EL(13), H, HMIN, HMXI, HNEW, HSCAL, RC, TAU(13), C TQ(5), TN, JCUR, JSTART, KFLAG, KUTH, C L, LMAX, MAXORD, MITER, N, NEWQ, NQ, NQWAIT C /DVOD02/ HU, NCFN, NETF, NFE, NQU, NST C C Subroutines called by DVSTEP.. F, DAXPY, DCOPY, DSCAL, C DVJUST, VNLS, DVSET C Function routines called by DVSTEP.. DVNORM C----------------------------------------------------------------------- C DVSTEP performs one step of the integration of an initial value C problem for a system of ordinary differential equations. C DVSTEP calls subroutine VNLS for the solution of the nonlinear system C arising in the time step. Thus it is independent of the problem C Jacobian structure and the type of nonlinear system solution method. C DVSTEP returns a completion flag KFLAG (in COMMON). C A return with KFLAG = -1 or -2 means either ABS(H) = HMIN or 10 C consecutive failures occurred. On a return with KFLAG negative, C the values of TN and the YH array are as of the beginning of the last C step, and H is the last step size attempted. C C Communication with DVSTEP is done with the following variables.. C C Y = An array of length N used for the dependent variable vector. C YH = An LDYH by LMAX array containing the dependent variables C and their approximate scaled derivatives, where C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate C j-th derivative of y(i), scaled by H**j/factorial(j) C (j = 0,1,...,NQ). On entry for the first step, the first C two columns of YH must be set from the initial values. C LDYH = A constant integer .ge. N, the first dimension of YH. C N is the number of ODEs in the system. C YH1 = A one-dimensional array occupying the same space as YH. C EWT = An array of length N containing multiplicative weights C for local error measurements. Local errors in y(i) are C compared to 1.0/EWT(i) in various error tests. C SAVF = An array of working storage, of length N. C also used for input of YH(*,MAXORD+2) when JSTART = -1 C and MAXORD .lt. the current order NQ. C VSAV = A work array of length N passed to subroutine VNLS. C ACOR = A work array of length N, used for the accumulated C corrections. On a successful return, ACOR(i) contains C the estimated one-step local error in y(i). C WM,IWM = Real and integer work arrays associated with matrix C operations in VNLS. C F = Dummy name for the user supplied subroutine for f. C JAC = Dummy name for the user supplied Jacobian subroutine. C PSOL = Dummy name for the subroutine passed to VNLS, for C possible use there. C VNLS = Dummy name for the nonlinear system solving subroutine, C whose real name is dependent on the method used. C RPAR, IPAR = Dummy names for user's real and integer work arrays. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block DVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C C Type declarations for labeled COMMON block DVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION ADDON, BIAS1,BIAS2,BIAS3, CNQUOT, DDN, DSM, DUP, & & ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF, & & ETAQ, ETAQM1, ETAQP1, FLOTL, ONE, ONEPSM, & & R, THRESH, TOLD, ZERO INTEGER I, I1, I2, IBACK, J, JB, KFC, KFH, MXNCF, NCF, NFLAG C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION DVNORM C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE ADDON, BIAS1, BIAS2, BIAS3, & & ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF, & & KFC, KFH, MXNCF, ONEPSM, THRESH, ONE, ZERO C----------------------------------------------------------------------- COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU(13), TQ(5), TN, UROUND, & & ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA KFC/-3/, KFH/-7/, MXNCF/10/ DATA ADDON /1.0D-6/, BIAS1 /6.0D0/, BIAS2 /6.0D0/, & & BIAS3 /10.0D0/, ETACF /0.25D0/, ETAMIN /0.1D0/, & & ETAMXF /0.2D0/, ETAMX1 /1.0D4/, ETAMX2 /10.0D0/, & & ETAMX3 /10.0D0/, ONEPSM /1.00001D0/, THRESH /1.5D0/ DATA ONE/1.0D0/, ZERO/0.0D0/ C KFLAG = 0 TOLD = TN NCF = 0 JCUR = 0 NFLAG = 0 ETAQM1 = 0.D0 ! KARLINE INITIALISED TO AVOID WARNING... IF (JSTART .GT. 0) GO TO 20 IF (JSTART .EQ. -1) GO TO 100 C----------------------------------------------------------------------- C On the first call, the order is set to 1, and other variables are C initialized. ETAMAX is the maximum ratio by which H can be increased C in a single step. It is normally 1.5, but is larger during the C first 10 steps to compensate for the small initial H. If a failure C occurs (in corrector convergence or error test), ETAMAX is set to 1 C for the next increase. C----------------------------------------------------------------------- LMAX = MAXORD + 1 NQ = 1 L = 2 NQNYH = NQ*LDYH TAU(1) = H PRL1 = ONE RC = ZERO ETAMAX = ETAMX1 NQWAIT = 2 HSCAL = H GO TO 200 C----------------------------------------------------------------------- C Take preliminary actions on a normal continuation step (JSTART.GT.0). C If the driver changed H, then ETA must be reset and NEWH set to 1. C If a change of order was dictated on the previous step, then C it is done here and appropriate adjustments in the history are made. C On an order decrease, the history array is adjusted by DVJUST. C On an order increase, the history array is augmented by a column. C On a change of step size H, the history array YH is rescaled. C----------------------------------------------------------------------- 20 CONTINUE IF (KUTH .EQ. 1) THEN ETA = MIN(ETA,H/HSCAL) NEWH = 1 ENDIF 50 IF (NEWH .EQ. 0) GO TO 200 IF (NEWQ .EQ. NQ) GO TO 150 IF (NEWQ .LT. NQ) THEN CALL DVJUST (YH, LDYH, -1) NQ = NEWQ L = NQ + 1 NQWAIT = L GO TO 150 ENDIF IF (NEWQ .GT. NQ) THEN CALL DVJUST (YH, LDYH, 1) NQ = NEWQ L = NQ + 1 NQWAIT = L GO TO 150 ENDIF C----------------------------------------------------------------------- C The following block handles preliminaries needed when JSTART = -1. C If N was reduced, zero out part of YH to avoid undefined references. C If MAXORD was reduced to a value less than the tentative order NEWQ, C then NQ is set to MAXORD, and a new H ratio ETA is chosen. C Otherwise, we take the same preliminary actions as for JSTART .gt. 0. C In any case, NQWAIT is reset to L = NQ + 1 to prevent further C changes in order for that many steps. C The new H ratio ETA is limited by the input H if KUTH = 1, C by HMIN if KUTH = 0, and by HMXI in any case. C Finally, the history array YH is rescaled. C----------------------------------------------------------------------- 100 CONTINUE LMAX = MAXORD + 1 IF (N .EQ. LDYH) GO TO 120 I1 = 1 + (NEWQ + 1)*LDYH I2 = (MAXORD + 1)*LDYH IF (I1 .GT. I2) GO TO 120 DO 110 I = I1, I2 YH1(I) = ZERO 110 CONTINUE 120 IF (NEWQ .LE. MAXORD) GO TO 140 FLOTL = REAL(LMAX) IF (MAXORD .LT. NQ-1) THEN DDN = DVNORM (N, SAVF, EWT)/TQ(1) ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON) ENDIF CKS: value ETAQ used before its value defined IF (MAXORD .EQ. NQ .AND. NEWQ .EQ. NQ+1) ETA = ETAQ IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ+1) THEN CKS: value ETAMQ1 used before its value defined ETA = ETAQM1 CALL DVJUST (YH, LDYH, -1) ENDIF IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ) THEN DDN = DVNORM (N, SAVF, EWT)/TQ(1) ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON) CALL DVJUST (YH, LDYH, -1) ENDIF ETA = MIN(ETA,ONE) NQ = MAXORD L = LMAX 140 IF (KUTH .EQ. 1) ETA = MIN(ETA,ABS(H/HSCAL)) IF (KUTH .EQ. 0) ETA = MAX(ETA,HMIN/ABS(HSCAL)) ETA = ETA/MAX(ONE,ABS(HSCAL)*HMXI*ETA) NEWH = 1 NQWAIT = L IF (NEWQ .LE. MAXORD) GO TO 50 C Rescale the history array for a change in H by a factor of ETA. ------ 150 R = ONE DO 180 J = 2, L R = R*ETA CALL DSCAL (N, R, YH(1,J), 1 ) 180 CONTINUE H = HSCAL*ETA HSCAL = H RC = RC*ETA NQNYH = NQ*LDYH C----------------------------------------------------------------------- C This section computes the predicted values by effectively C multiplying the YH array by the Pascal triangle matrix. C DVSET is called to calculate all integration coefficients. C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. C----------------------------------------------------------------------- 200 TN = TN + H I1 = NQNYH + 1 DO 220 JB = 1, NQ I1 = I1 - LDYH DO 210 I = I1, NQNYH YH1(I) = YH1(I) + YH1(I+LDYH) 210 CONTINUE 220 CONTINUE CALL DVSET RL1 = ONE/EL(2) RC = RC*(RL1/PRL1) PRL1 = RL1 C C Call the nonlinear system solver. ------------------------------------ C CALL VNLS (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM, & & F, JAC, PSOL, NFLAG, RPAR, IPAR) C IF (NFLAG .EQ. 0) GO TO 450 C----------------------------------------------------------------------- C The VNLS routine failed to achieve convergence (NFLAG .NE. 0). C The YH array is retracted to its values before prediction. C The step size H is reduced and the step is retried, if possible. C Otherwise, an error exit is taken. C----------------------------------------------------------------------- NCF = NCF + 1 NCFN = NCFN + 1 ETAMAX = ONE TN = TOLD I1 = NQNYH + 1 DO 430 JB = 1, NQ I1 = I1 - LDYH DO 420 I = I1, NQNYH YH1(I) = YH1(I) - YH1(I+LDYH) 420 CONTINUE 430 CONTINUE IF (NFLAG .LT. -1) GO TO 680 IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 670 IF (NCF .EQ. MXNCF) GO TO 670 ETA = ETACF ETA = MAX(ETA,HMIN/ABS(H)) NFLAG = -1 GO TO 150 C----------------------------------------------------------------------- C The corrector has converged (NFLAG = 0). The local error test is C made and control passes to statement 500 if it fails. C----------------------------------------------------------------------- 450 CONTINUE DSM = ACNRM/TQ(2) IF (DSM .GT. ONE) GO TO 500 C----------------------------------------------------------------------- C After a successful step, update the YH and TAU arrays and decrement C NQWAIT. If NQWAIT is then 1 and NQ .lt. MAXORD, then ACOR is saved C for use in a possible order increase on the next step. C If ETAMAX = 1 (a failure occurred this step), keep NQWAIT .ge. 2. C----------------------------------------------------------------------- KFLAG = 0 NST = NST + 1 HU = H NQU = NQ DO 470 IBACK = 1, NQ I = L - IBACK TAU(I+1) = TAU(I) 470 CONTINUE TAU(1) = H DO 480 J = 1, L CALL DAXPY (N, EL(J), ACOR, 1, YH(1,J), 1 ) 480 CONTINUE NQWAIT = NQWAIT - 1 IF ((L .EQ. LMAX) .OR. (NQWAIT .NE. 1)) GO TO 490 CALL DCOPY (N, ACOR, 1, YH(1,LMAX), 1 ) CONP = TQ(5) 490 IF (ETAMAX .NE. ONE) GO TO 560 IF (NQWAIT .LT. 2) NQWAIT = 2 NEWQ = NQ NEWH = 0 ETA = ONE HNEW = H GO TO 690 C----------------------------------------------------------------------- C The error test failed. KFLAG keeps track of multiple failures. C Restore TN and the YH array to their previous values, and prepare C to try the step again. Compute the optimum step size for the C same order. After repeated failures, H is forced to decrease C more rapidly. C----------------------------------------------------------------------- 500 KFLAG = KFLAG - 1 NETF = NETF + 1 NFLAG = -2 TN = TOLD I1 = NQNYH + 1 DO 520 JB = 1, NQ I1 = I1 - LDYH DO 510 I = I1, NQNYH YH1(I) = YH1(I) - YH1(I+LDYH) 510 CONTINUE 520 CONTINUE IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 660 ETAMAX = ONE IF (KFLAG .LE. KFC) GO TO 530 C Compute ratio of new H to current H at the current order. ------------ FLOTL = REAL(L) ETA = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON) ETA = MAX(ETA,HMIN/ABS(H),ETAMIN) IF ((KFLAG .LE. -2) .AND. (ETA .GT. ETAMXF)) ETA = ETAMXF GO TO 150 C----------------------------------------------------------------------- C Control reaches this section if 3 or more consecutive failures C have occurred. It is assumed that the elements of the YH array C have accumulated errors of the wrong order. The order is reduced C by one, if possible. Then H is reduced by a factor of 0.1 and C the step is retried. After a total of 7 consecutive failures, C an exit is taken with KFLAG = -1. C----------------------------------------------------------------------- 530 IF (KFLAG .EQ. KFH) GO TO 660 IF (NQ .EQ. 1) GO TO 540 ETA = MAX(ETAMIN,HMIN/ABS(H)) CALL DVJUST (YH, LDYH, -1) L = NQ NQ = NQ - 1 NQWAIT = L GO TO 150 540 ETA = MAX(ETAMIN,HMIN/ABS(H)) H = H*ETA HSCAL = H TAU(1) = H CALL F (N, TN, Y, SAVF, RPAR, IPAR) NFE = NFE + 1 DO 550 I = 1, N YH(I,2) = H*SAVF(I) 550 CONTINUE NQWAIT = 10 GO TO 200 C----------------------------------------------------------------------- C If NQWAIT = 0, an increase or decrease in order by one is considered. C Factors ETAQ, ETAQM1, ETAQP1 are computed by which H could C be multiplied at order q, q-1, or q+1, respectively. C The largest of these is determined, and the new order and C step size set accordingly. C A change of H or NQ is made only if H increases by at least a C factor of THRESH. If an order change is considered and rejected, C then NQWAIT is set to 2 (reconsider it after 2 steps). C----------------------------------------------------------------------- C Compute ratio of new H to current H at the current order. ------------ 560 FLOTL = REAL(L) ETAQ = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON) IF (NQWAIT .NE. 0) GO TO 600 NQWAIT = 2 ETAQM1 = ZERO IF (NQ .EQ. 1) GO TO 570 C Compute ratio of new H to current H at the current order less one. --- DDN = DVNORM (N, YH(1,L), EWT)/TQ(1) ETAQM1 = ONE/((BIAS1*DDN)**(ONE/(FLOTL - ONE)) + ADDON) 570 ETAQP1 = ZERO IF (L .EQ. LMAX) GO TO 580 C Compute ratio of new H to current H at current order plus one. ------- CNQUOT = (TQ(5)/CONP)*(H/TAU(2))**L DO 575 I = 1, N SAVF(I) = ACOR(I) - CNQUOT*YH(I,LMAX) 575 CONTINUE DUP = DVNORM (N, SAVF, EWT)/TQ(3) ETAQP1 = ONE/((BIAS3*DUP)**(ONE/(FLOTL + ONE)) + ADDON) 580 IF (ETAQ .GE. ETAQP1) GO TO 590 IF (ETAQP1 .GT. ETAQM1) GO TO 620 GO TO 610 590 IF (ETAQ .LT. ETAQM1) GO TO 610 600 ETA = ETAQ NEWQ = NQ GO TO 630 610 ETA = ETAQM1 NEWQ = NQ - 1 GO TO 630 620 ETA = ETAQP1 NEWQ = NQ + 1 CALL DCOPY (N, ACOR, 1, YH(1,LMAX), 1) C Test tentative new H against THRESH, ETAMAX, and HMXI, then exit. ---- 630 IF (ETA .LT. THRESH .OR. ETAMAX .EQ. ONE) GO TO 640 ETA = MIN(ETA,ETAMAX) ETA = ETA/MAX(ONE,ABS(H)*HMXI*ETA) NEWH = 1 HNEW = H*ETA GO TO 690 640 NEWQ = NQ NEWH = 0 ETA = ONE HNEW = H GO TO 690 C----------------------------------------------------------------------- C All returns are made through this section. C On a successful return, ETAMAX is reset and ACOR is scaled. C----------------------------------------------------------------------- 660 KFLAG = -1 GO TO 720 670 KFLAG = -2 GO TO 720 680 IF (NFLAG .EQ. -2) KFLAG = -3 IF (NFLAG .EQ. -3) KFLAG = -4 GO TO 720 690 ETAMAX = ETAMX3 IF (NST .LE. 10) ETAMAX = ETAMX2 R = ONE/TQ(2) CALL DSCAL (N, R, ACOR, 1) 720 JSTART = 1 RETURN C----------------------- End of Subroutine DVSTEP ---------------------- END C*********************************************************************** CDECK DVSET SUBROUTINE DVSET C----------------------------------------------------------------------- C Call sequence communication.. None C COMMON block variables accessed.. C /DVOD01/ -- EL(13), H, TAU(13), TQ(5), L(= NQ + 1), C METH, NQ, NQWAIT C C Subroutines called by DVSET.. None C Function routines called by DVSET.. None C----------------------------------------------------------------------- C DVSET is called by DVSTEP and sets coefficients for use there. C C For each order NQ, the coefficients in EL are calculated by use of C the generating polynomial lambda(x), with coefficients EL(i). C lambda(x) = EL(1) + EL(2)*x + ... + EL(NQ+1)*(x**NQ). C For the backward differentiation formulas, C NQ-1 C lambda(x) = (1 + x/xi*(NQ)) * product (1 + x/xi(i) ) . C i = 1 C For the Adams formulas, C NQ-1 C (d/dx) lambda(x) = c * product (1 + x/xi(i) ) , C i = 1 C lambda(-1) = 0, lambda(0) = 1, C where c is a normalization constant. C In both cases, xi(i) is defined by C H*xi(i) = t sub n - t sub (n-i) C = H + TAU(1) + TAU(2) + ... TAU(i-1). C C C In addition to variables described previously, communication C with DVSET uses the following.. C TAU = A vector of length 13 containing the past NQ values C of H. C EL = A vector of length 13 in which vset stores the C coefficients for the corrector formula. C TQ = A vector of length 5 in which vset stores constants C used for the convergence test, the error test, and the C selection of H at a new order. C METH = The basic method indicator. C NQ = The current order. C L = NQ + 1, the length of the vector stored in EL, and C the number of columns of the YH array being used. C NQWAIT = A counter controlling the frequency of order changes. C An order change is about to be considered if NQWAIT = 1. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block DVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION AHATN0, ALPH0, CNQM1, CORTES, CSUM, ELP, EM, & & EM0, FLOTI, FLOTL, FLOTNQ, HSUM, ONE, RXI, RXIS, S, SIX, & & T1, T2, T3, T4, T5, T6, TWO, XI, ZERO INTEGER I, IBACK, J, JP1, NQM1, NQM2 C DIMENSION EM(13) C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE CORTES, ONE, SIX, TWO, ZERO C COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU(13), TQ(5), TN, UROUND, & & ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C DATA CORTES /0.1D0/ DATA ONE /1.0D0/, SIX /6.0D0/, TWO /2.0D0/, ZERO /0.0D0/ C FLOTL = REAL(L) NQM1 = NQ - 1 NQM2 = NQ - 2 C GO TO (100, 200), METH SELECT CASE (METH) CASE(1) GOTO 100 CASE(2) GOTO 200 END SELECT C C Set coefficients for Adams methods. ---------------------------------- 100 IF (NQ .NE. 1) GO TO 110 EL(1) = ONE EL(2) = ONE TQ(1) = ONE TQ(2) = TWO TQ(3) = SIX*TQ(2) TQ(5) = ONE GO TO 300 110 HSUM = H EM(1) = ONE FLOTNQ = FLOTL - ONE DO 115 I = 2, L EM(I) = ZERO 115 CONTINUE DO 150 J = 1, NQM1 IF ((J .NE. NQM1) .OR. (NQWAIT .NE. 1)) GO TO 130 S = ONE CSUM = ZERO DO 120 I = 1, NQM1 CSUM = CSUM + S*EM(I)/REAL(I+1) S = -S 120 CONTINUE TQ(1) = EM(NQM1)/(FLOTNQ*CSUM) 130 RXI = H/HSUM DO 140 IBACK = 1, J I = (J + 2) - IBACK EM(I) = EM(I) + EM(I-1)*RXI 140 CONTINUE HSUM = HSUM + TAU(J) 150 CONTINUE C Compute integral from -1 to 0 of polynomial and of x times it. ------- S = ONE EM0 = ZERO CSUM = ZERO DO 160 I = 1, NQ FLOTI = REAL(I) EM0 = EM0 + S*EM(I)/FLOTI CSUM = CSUM + S*EM(I)/(FLOTI+ONE) S = -S 160 CONTINUE C In EL, form coefficients of normalized integrated polynomial. -------- S = ONE/EM0 EL(1) = ONE DO 170 I = 1, NQ EL(I+1) = S*EM(I)/REAL(I) 170 CONTINUE XI = HSUM/H TQ(2) = XI*EM0/CSUM TQ(5) = XI/EL(L) IF (NQWAIT .NE. 1) GO TO 300 C For higher order control constant, multiply polynomial by 1+x/xi(q). - RXI = ONE/XI DO 180 IBACK = 1, NQ I = (L + 1) - IBACK EM(I) = EM(I) + EM(I-1)*RXI 180 CONTINUE C Compute integral of polynomial. -------------------------------------- S = ONE CSUM = ZERO DO 190 I = 1, L CSUM = CSUM + S*EM(I)/REAL(I+1) S = -S 190 CONTINUE TQ(3) = FLOTL*EM0/CSUM GO TO 300 C C Set coefficients for BDF methods. ------------------------------------ 200 DO 210 I = 3, L EL(I) = ZERO 210 CONTINUE EL(1) = ONE EL(2) = ONE ALPH0 = -ONE AHATN0 = -ONE HSUM = H RXI = ONE RXIS = ONE IF (NQ .EQ. 1) GO TO 240 DO 230 J = 1, NQM2 C In EL, construct coefficients of (1+x/xi(1))*...*(1+x/xi(j+1)). ------ HSUM = HSUM + TAU(J) RXI = H/HSUM JP1 = J + 1 ALPH0 = ALPH0 - ONE/REAL(JP1) DO 220 IBACK = 1, JP1 I = (J + 3) - IBACK EL(I) = EL(I) + EL(I-1)*RXI 220 CONTINUE 230 CONTINUE ALPH0 = ALPH0 - ONE/REAL(NQ) RXIS = -EL(2) - ALPH0 HSUM = HSUM + TAU(NQM1) RXI = H/HSUM AHATN0 = -EL(2) - RXI DO 235 IBACK = 1, NQ I = (NQ + 2) - IBACK EL(I) = EL(I) + EL(I-1)*RXIS 235 CONTINUE 240 T1 = ONE - AHATN0 + ALPH0 T2 = ONE + REAL(NQ)*T1 TQ(2) = ABS(ALPH0*T2/T1) TQ(5) = ABS(T2/(EL(L)*RXI/RXIS)) IF (NQWAIT .NE. 1) GO TO 300 CNQM1 = RXIS/EL(L) T3 = ALPH0 + ONE/REAL(NQ) T4 = AHATN0 + RXI ELP = T3/(ONE - T4 + T3) TQ(1) = ABS(ELP/CNQM1) HSUM = HSUM + TAU(NQ) RXI = H/HSUM T5 = ALPH0 - ONE/REAL(NQ+1) T6 = AHATN0 - RXI ELP = T2/(ONE - T6 + T5) TQ(3) = ABS(ELP*RXI*(FLOTL + ONE)*T5) 300 TQ(4) = CORTES*TQ(2) RETURN C----------------------- End of Subroutine DVSET ----------------------- END C*********************************************************************** CDECK DVJUST SUBROUTINE DVJUST (YH, LDYH, IORD) DOUBLE PRECISION YH INTEGER LDYH, IORD DIMENSION YH(LDYH,*) C----------------------------------------------------------------------- C Call sequence input -- YH, LDYH, IORD C Call sequence output -- YH C COMMON block input -- NQ, METH, LMAX, HSCAL, TAU(13), N C COMMON block variables accessed.. C /DVOD01/ -- HSCAL, TAU(13), LMAX, METH, N, NQ, C C Subroutines called by DVJUST.. DAXPY C Function routines called by DVJUST.. None C----------------------------------------------------------------------- C This subroutine adjusts the YH array on reduction of order, C and also when the order is increased for the stiff option (METH = 2). C Communication with DVJUST uses the following.. C IORD = An integer flag used when METH = 2 to indicate an order C increase (IORD = +1) or an order decrease (IORD = -1). C HSCAL = Step size H used in scaling of Nordsieck array YH. C (If IORD = +1, DVJUST assumes that HSCAL = TAU(1).) C See References 1 and 2 for details. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block DVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION ALPH0, ALPH1, HSUM, ONE, PROD, T1, XI,XIOLD, ZERO INTEGER I, IBACK, J, JP1, LP1, NQM1, NQM2, NQP1 C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE ONE, ZERO C COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU(13), TQ(5), TN, UROUND, & & ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C DATA ONE /1.0D0/, ZERO /0.0D0/ C IF ((NQ .EQ. 2) .AND. (IORD .NE. 1)) RETURN NQM1 = NQ - 1 NQM2 = NQ - 2 C GO TO (100, 200), METH SELECT CASE (METH) CASE(1) GOTO 100 CASE(2) GOTO 200 END SELECT C----------------------------------------------------------------------- C Nonstiff option... C Check to see if the order is being increased or decreased. C----------------------------------------------------------------------- 100 CONTINUE IF (IORD .EQ. 1) GO TO 180 C Order decrease. ------------------------------------------------------ DO 110 J = 1, LMAX EL(J) = ZERO 110 CONTINUE EL(2) = ONE HSUM = ZERO DO 130 J = 1, NQM2 C Construct coefficients of x*(x+xi(1))*...*(x+xi(j)). ----------------- HSUM = HSUM + TAU(J) XI = HSUM/HSCAL JP1 = J + 1 DO 120 IBACK = 1, JP1 I = (J + 3) - IBACK EL(I) = EL(I)*XI + EL(I-1) 120 CONTINUE 130 CONTINUE C Construct coefficients of integrated polynomial. --------------------- DO 140 J = 2, NQM1 EL(J+1) = REAL(NQ)*EL(J)/REAL(J) 140 CONTINUE C Subtract correction terms from YH array. ----------------------------- DO 170 J = 3, NQ DO 160 I = 1, N YH(I,J) = YH(I,J) - YH(I,L)*EL(J) 160 CONTINUE 170 CONTINUE RETURN C Order increase. ------------------------------------------------------ C Zero out next column in YH array. ------------------------------------ 180 CONTINUE LP1 = L + 1 DO 190 I = 1, N YH(I,LP1) = ZERO 190 CONTINUE RETURN C----------------------------------------------------------------------- C Stiff option... C Check to see if the order is being increased or decreased. C----------------------------------------------------------------------- 200 CONTINUE IF (IORD .EQ. 1) GO TO 300 C Order decrease. ------------------------------------------------------ DO 210 J = 1, LMAX EL(J) = ZERO 210 CONTINUE EL(3) = ONE HSUM = ZERO DO 230 J = 1,NQM2 C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- HSUM = HSUM + TAU(J) XI = HSUM/HSCAL JP1 = J + 1 DO 220 IBACK = 1, JP1 I = (J + 4) - IBACK EL(I) = EL(I)*XI + EL(I-1) 220 CONTINUE 230 CONTINUE C Subtract correction terms from YH array. ----------------------------- DO 250 J = 3,NQ DO 240 I = 1, N YH(I,J) = YH(I,J) - YH(I,L)*EL(J) 240 CONTINUE 250 CONTINUE RETURN C Order increase. ------------------------------------------------------ 300 DO 310 J = 1, LMAX EL(J) = ZERO 310 CONTINUE EL(3) = ONE ALPH0 = -ONE ALPH1 = ONE PROD = ONE XIOLD = ONE HSUM = HSCAL IF (NQ .EQ. 1) GO TO 340 DO 330 J = 1, NQM1 C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- JP1 = J + 1 HSUM = HSUM + TAU(JP1) XI = HSUM/HSCAL PROD = PROD*XI ALPH0 = ALPH0 - ONE/REAL(JP1) ALPH1 = ALPH1 + ONE/XI DO 320 IBACK = 1, JP1 I = (J + 4) - IBACK EL(I) = EL(I)*XIOLD + EL(I-1) 320 CONTINUE XIOLD = XI 330 CONTINUE 340 CONTINUE T1 = (-ALPH0 - ALPH1)/PROD C Load column L + 1 in YH array. --------------------------------------- LP1 = L + 1 DO 350 I = 1, N YH(I,LP1) = T1*YH(I,LMAX) 350 CONTINUE C Add correction terms to YH array. ------------------------------------ NQP1 = NQ + 1 DO 370 J = 3, NQP1 CALL DAXPY (N, EL(J), YH(1,LP1), 1, YH(1,J), 1 ) 370 CONTINUE RETURN C----------------------- End of Subroutine DVJUST ---------------------- END C*********************************************************************** CDECK DVNLSD SUBROUTINE DVNLSD (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM, & & F, JAC, PDUM, NFLAG, RPAR, IPAR) EXTERNAL F, JAC, PDUM DOUBLE PRECISION Y, YH, VSAV, SAVF, EWT, ACOR, WM, RPAR INTEGER LDYH, IWM, NFLAG, IPAR DIMENSION Y(*), YH(LDYH,*), VSAV(*), SAVF(*), EWT(*), ACOR(*), & & IWM(*), WM(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call sequence input -- Y, YH, LDYH, SAVF, EWT, ACOR, IWM, WM, C F, JAC, NFLAG, RPAR, IPAR C Call sequence output -- YH, ACOR, WM, IWM, NFLAG C COMMON block variables accessed.. C /DVOD01/ ACNRM, CRATE, DRC, H, RC, RL1, TQ(5), TN, ICF, C JCUR, METH, MITER, N, NSLP C /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Subroutines called by DVNLSD.. F, DAXPY, DCOPY, DSCAL, DVJAC, DVSOL C Function routines called by DVNLSD.. DVNORM C----------------------------------------------------------------------- C Subroutine DVNLSD is a nonlinear system solver, which uses functional C iteration or a chord (modified Newton) method. For the chord method C direct linear algebraic system solvers are used. Subroutine DVNLSD C then handles the corrector phase of this integration package. C C Communication with DVNLSD is done with the following variables. (For C more details, please see the comments in the driver subroutine.) C C Y = The dependent variable, a vector of length N, input. C YH = The Nordsieck (Taylor) array, LDYH by LMAX, input C and output. On input, it contains predicted values. C LDYH = A constant .ge. N, the first dimension of YH, input. C VSAV = Unused work array. C SAVF = A work array of length N. C EWT = An error weight vector of length N, input. C ACOR = A work array of length N, used for the accumulated C corrections to the predicted y vector. C WM,IWM = Real and integer work arrays associated with matrix C operations in chord iteration (MITER .ne. 0). C F = Dummy name for user supplied routine for f. C JAC = Dummy name for user supplied Jacobian routine. C PDUM = Unused dummy subroutine name. Included for uniformity C over collection of integrators. C NFLAG = Input/output flag, with values and meanings as follows.. C INPUT C 0 first call for this time step. C -1 convergence failure in previous call to DVNLSD. C -2 error test failure in DVSTEP. C OUTPUT C 0 successful completion of nonlinear solver. C -1 convergence failure or singular matrix. C -2 unrecoverable error in matrix preprocessing C (cannot occur here). C -3 unrecoverable error in solution (cannot occur C here). C RPAR, IPAR = Dummy names for user's real and integer work arrays. C C IPUP = Own variable flag with values and meanings as follows.. C 0, do not update the Newton matrix. C MITER .ne. 0, update Newton matrix, because it is the C initial step, order was changed, the error C test failed, or an update is indicated by C the scalar RC or step counter NST. C C For more details, see comments in driver subroutine. C----------------------------------------------------------------------- C Type declarations for labeled COMMON block DVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C C Type declarations for labeled COMMON block DVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION CCMAX, CRDOWN, CSCALE, DCON, DEL, DELP, ONE, & & RDIV, TWO, ZERO INTEGER I, IERPJ, IERSL, M, MAXCOR, MSBP C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION DVNORM C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE CCMAX, CRDOWN, MAXCOR, MSBP, RDIV, ONE, TWO, ZERO C COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU(13), TQ(5), TN, UROUND, & & ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA CCMAX /0.3D0/, CRDOWN /0.3D0/, MAXCOR /3/, MSBP /20/, & & RDIV /2.0D0/ DATA ONE /1.0D0/, TWO /2.0D0/, ZERO /0.0D0/ C----------------------------------------------------------------------- C On the first step, on a change of method order, or after a C nonlinear convergence failure with NFLAG = -2, set IPUP = MITER C to force a Jacobian update when MITER .ne. 0. C----------------------------------------------------------------------- IF (JSTART .EQ. 0) NSLP = 0 IF (NFLAG .EQ. 0) ICF = 0 IF (NFLAG .EQ. -2) IPUP = MITER IF ( (JSTART .EQ. 0) .OR. (JSTART .EQ. -1) ) IPUP = MITER C If this is functional iteration, set CRATE .eq. 1 and drop to 220 IF (MITER .EQ. 0) THEN CRATE = ONE GO TO 220 ENDIF C----------------------------------------------------------------------- C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. C When RC differs from 1 by more than CCMAX, IPUP is set to MITER C to force DVJAC to be called, if a Jacobian is involved. C In any case, DVJAC is called at least every MSBP steps. C----------------------------------------------------------------------- DRC = ABS(RC-ONE) IF (DRC .GT. CCMAX .OR. NST .GE. NSLP+MSBP) IPUP = MITER C----------------------------------------------------------------------- C Up to MAXCOR corrector iterations are taken. A convergence test is C made on the r.m.s. norm of each correction, weighted by the error C weight vector EWT. The sum of the corrections is accumulated in the C vector ACOR(i). The YH array is not altered in the corrector loop. C----------------------------------------------------------------------- 220 M = 0 DELP = ZERO CALL DCOPY (N, YH(1,1), 1, Y, 1 ) CALL F (N, TN, Y, SAVF, RPAR, IPAR) NFE = NFE + 1 IF (IPUP .LE. 0) GO TO 250 C----------------------------------------------------------------------- C If indicated, the matrix P = I - h*rl1*J is reevaluated and C preprocessed before starting the corrector iteration. IPUP is set C to 0 as an indicator that this has been done. C----------------------------------------------------------------------- CALL DVJAC (Y, YH, LDYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, IERPJ, & & RPAR, IPAR) IPUP = 0 RC = ONE DRC = ZERO CRATE = ONE NSLP = NST C If matrix is singular, take error return to force cut in step size. -- IF (IERPJ .NE. 0) GO TO 430 250 DO 260 I = 1,N ACOR(I) = ZERO 260 CONTINUE C This is a looping point for the corrector iteration. ----------------- 270 IF (MITER .NE. 0) GO TO 350 C----------------------------------------------------------------------- C In the case of functional iteration, update Y directly from C the result of the last function evaluation. C----------------------------------------------------------------------- DO 280 I = 1,N SAVF(I) = RL1*(H*SAVF(I) - YH(I,2)) 280 CONTINUE DO 290 I = 1,N Y(I) = SAVF(I) - ACOR(I) 290 CONTINUE DEL = DVNORM (N, Y, EWT) DO 300 I = 1,N Y(I) = YH(I,1) + SAVF(I) 300 CONTINUE CALL DCOPY (N, SAVF, 1, ACOR, 1) GO TO 400 C----------------------------------------------------------------------- C In the case of the chord method, compute the corrector error, C and solve the linear system with that as right-hand side and C P as coefficient matrix. The correction is scaled by the factor C 2/(1+RC) to account for changes in h*rl1 since the last DVJAC call. C----------------------------------------------------------------------- 350 DO 360 I = 1,N Y(I) = (RL1*H)*SAVF(I) - (RL1*YH(I,2) + ACOR(I)) 360 CONTINUE CALL DVSOL (WM, IWM, Y, IERSL) NNI = NNI + 1 IF (IERSL .GT. 0) GO TO 410 IF (METH .EQ. 2 .AND. RC .NE. ONE) THEN CSCALE = TWO/(ONE + RC) CALL DSCAL (N, CSCALE, Y, 1) ENDIF DEL = DVNORM (N, Y, EWT) CALL DAXPY (N, ONE, Y, 1, ACOR, 1) DO 380 I = 1,N Y(I) = YH(I,1) + ACOR(I) 380 CONTINUE C----------------------------------------------------------------------- C Test for convergence. If M .gt. 0, an estimate of the convergence C rate constant is stored in CRATE, and this is used in the test. C----------------------------------------------------------------------- 400 IF (M .NE. 0) CRATE = MAX(CRDOWN*CRATE,DEL/DELP) DCON = DEL*MIN(ONE,CRATE)/TQ(4) IF (DCON .LE. ONE) GO TO 450 M = M + 1 IF (M .EQ. MAXCOR) GO TO 410 IF (M .GE. 2 .AND. DEL .GT. RDIV*DELP) GO TO 410 DELP = DEL CALL F (N, TN, Y, SAVF, RPAR, IPAR) NFE = NFE + 1 GO TO 270 C 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 ICF = 1 IPUP = MITER GO TO 220 C 430 CONTINUE NFLAG = -1 ICF = 2 IPUP = MITER RETURN C C Return for successful step. ------------------------------------------ 450 NFLAG = 0 JCUR = 0 ICF = 0 IF (M .EQ. 0) ACNRM = DEL IF (M .GT. 0) ACNRM = DVNORM (N, ACOR, EWT) RETURN C----------------------- End of Subroutine DVNLSD ---------------------- END C*********************************************************************** CDECK DVJAC SUBROUTINE DVJAC (Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, F, JAC, & & IERPJ, RPAR, IPAR) EXTERNAL F, JAC DOUBLE PRECISION Y, YH, EWT, FTEM, SAVF, WM, RPAR INTEGER LDYH, IWM, IERPJ, IPAR DIMENSION Y(*), YH(LDYH,*), EWT(*), FTEM(*), SAVF(*), & & WM(*), IWM(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call sequence input -- Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, C F, JAC, RPAR, IPAR C Call sequence output -- WM, IWM, IERPJ C COMMON block variables accessed.. C /DVOD01/ CCMXJ, DRC, H, RL1, TN, UROUND, ICF, JCUR, LOCJS, C MSBJ, NSLJ C /DVOD02/ NFE, NST, NJE, NLU C C Subroutines called by DVJAC.. F, JAC, DACOPY, DCOPY, DGBFA, DGEFA, C DSCAL C Function routines called by DVJAC.. DVNORM C----------------------------------------------------------------------- C DVJAC is called by DVSTEP to compute and process the matrix C P = I - h*rl1*J , where J is an approximation to the Jacobian. C Here J is computed by the user-supplied routine JAC if C MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5. C If MITER = 3, a diagonal approximation to J is used. C If JSV = -1, J is computed from scratch in all cases. C If JSV = 1 and MITER = 1, 2, 4, or 5, and if the saved value of J is C considered acceptable, then P is constructed from the saved J. C J is stored in wm and replaced by P. If MITER .ne. 3, P is then C subjected to LU decomposition in preparation for later solution C of linear systems with P as coefficient matrix. This is done C by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5. C C Communication with DVJAC is done with the following variables. (For C more details, please see the comments in the driver subroutine.) C Y = Vector containing predicted values on entry. C YH = The Nordsieck array, an LDYH by LMAX array, input. C LDYH = A constant .ge. N, the first dimension of YH, input. C EWT = An error weight vector of length N. C SAVF = Array containing f evaluated at predicted y, input. C WM = Real work space for matrices. In the output, it containS C the inverse diagonal matrix if MITER = 3 and the LU C decomposition of P if MITER is 1, 2 , 4, or 5. C Storage of matrix elements starts at WM(3). C Storage of the saved Jacobian starts at WM(LOCJS). C WM also contains the following matrix-related data.. C WM(1) = SQRT(UROUND), used in numerical Jacobian step. C WM(2) = H*RL1, saved for later use if MITER = 3. C IWM = Integer work space containing pivot information, C starting at IWM(31), if MITER is 1, 2, 4, or 5. C IWM also contains band parameters ML = IWM(1) and C MU = IWM(2) if MITER is 4 or 5. C F = Dummy name for the user supplied subroutine for f. C JAC = Dummy name for the user supplied Jacobian subroutine. C RPAR, IPAR = Dummy names for user's real and integer work arrays. C RL1 = 1/EL(2) (input). C IERPJ = Output error flag, = 0 if no trouble, 1 if the P C matrix is found to be singular. C JCUR = Output flag to indicate whether the Jacobian matrix C (or approximation) is now current. C JCUR = 0 means J is not current. C JCUR = 1 means J is current. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block DVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C C Type declarations for labeled COMMON block DVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION CON, DI, FAC, HRL1, ONE, PT1, R, R0, SRUR, THOU, & & YI, YJ, YJJ, ZERO INTEGER I, I1, I2, IER, II, J, J1, JJ, JOK, LENP, MBA, MBAND, & & MEB1, MEBAND, ML, ML3, MU, NP1 C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION DVNORM C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this subroutine. C----------------------------------------------------------------------- SAVE ONE, PT1, THOU, ZERO C----------------------------------------------------------------------- COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU(13), TQ(5), TN, UROUND, & & ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA ONE /1.0D0/, THOU /1000.0D0/, ZERO /0.0D0/, PT1 /0.1D0/ C IERPJ = 0 HRL1 = H*RL1 C See whether J should be evaluated (JOK = -1) or not (JOK = 1). ------- JOK = JSV IF (JSV .EQ. 1) THEN IF (NST .EQ. 0 .OR. NST .GT. NSLJ+MSBJ) JOK = -1 IF (ICF .EQ. 1 .AND. DRC .LT. CCMXJ) JOK = -1 IF (ICF .EQ. 2) JOK = -1 ENDIF C End of setting JOK. -------------------------------------------------- C IF (JOK .EQ. -1 .AND. MITER .EQ. 1) THEN C If JOK = -1 and MITER = 1, call JAC to evaluate Jacobian. ------------ NJE = NJE + 1 NSLJ = NST JCUR = 1 LENP = N*N DO 110 I = 1,LENP WM(I+2) = ZERO 110 CONTINUE CALL JAC (N, TN, Y, 0, 0, WM(3), N, RPAR, IPAR) IF (JSV .EQ. 1) CALL DCOPY (LENP, WM(3), 1, WM(LOCJS), 1) ENDIF C IF (JOK .EQ. -1 .AND. MITER .EQ. 2) THEN C If MITER = 2, make N calls to F to approximate the Jacobian. --------- NJE = NJE + 1 NSLJ = NST JCUR = 1 FAC = DVNORM (N, SAVF, EWT) R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC IF (R0 .EQ. ZERO) R0 = ONE SRUR = WM(1) J1 = 2 DO 230 J = 1,N YJ = Y(J) R = MAX(SRUR*ABS(YJ),R0/EWT(J)) Y(J) = Y(J) + R FAC = ONE/R CALL F (N, TN, Y, FTEM, RPAR, IPAR) DO 220 I = 1,N WM(I+J1) = (FTEM(I) - SAVF(I))*FAC 220 CONTINUE Y(J) = YJ J1 = J1 + N 230 CONTINUE NFE = NFE + N LENP = N*N IF (JSV .EQ. 1) CALL DCOPY (LENP, WM(3), 1, WM(LOCJS), 1) ENDIF C IF (JOK .EQ. 1 .AND. (MITER .EQ. 1 .OR. MITER .EQ. 2)) THEN JCUR = 0 LENP = N*N CALL DCOPY (LENP, WM(LOCJS), 1, WM(3), 1) ENDIF C IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN C Multiply Jacobian by scalar, add identity, and do LU decomposition. -- CON = -HRL1 CALL DSCAL (LENP, CON, WM(3), 1) J = 3 NP1 = N + 1 DO 250 I = 1,N WM(J) = WM(J) + ONE J = J + NP1 250 CONTINUE NLU = NLU + 1 CALL DGEFA (WM(3), N, N, IWM(31), IER) IF (IER .NE. 0) IERPJ = 1 RETURN ENDIF C End of code block for MITER = 1 or 2. -------------------------------- C IF (MITER .EQ. 3) THEN C If MITER = 3, construct a diagonal approximation to J and P. --------- NJE = NJE + 1 JCUR = 1 WM(2) = HRL1 R = RL1*PT1 DO 310 I = 1,N Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) 310 CONTINUE CALL F (N, TN, Y, WM(3), RPAR, IPAR) NFE = NFE + 1 DO 320 I = 1,N R0 = H*SAVF(I) - YH(I,2) DI = PT1*R0 - H*(WM(I+2) - SAVF(I)) WM(I+2) = ONE IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 IF (ABS(DI) .EQ. ZERO) GO TO 330 WM(I+2) = PT1*R0/DI 320 CONTINUE RETURN 330 IERPJ = 1 RETURN ENDIF C End of code block for MITER = 3. ------------------------------------- C C Set constants for MITER = 4 or 5. ------------------------------------ ML = IWM(1) MU = IWM(2) ML3 = ML + 3 MBAND = ML + MU + 1 MEBAND = MBAND + ML LENP = MEBAND*N C IF (JOK .EQ. -1 .AND. MITER .EQ. 4) THEN C If JOK = -1 and MITER = 4, call JAC to evaluate Jacobian. ------------ NJE = NJE + 1 NSLJ = NST JCUR = 1 DO 410 I = 1,LENP WM(I+2) = ZERO 410 CONTINUE CALL JAC (N, TN, Y, ML, MU, WM(ML3), MEBAND, RPAR, IPAR) IF (JSV .EQ. 1) & & CALL DACOPY (MBAND, N, WM(ML3), MEBAND, WM(LOCJS), MBAND) ENDIF C IF (JOK .EQ. -1 .AND. MITER .EQ. 5) THEN C If MITER = 5, make N calls to F to approximate the Jacobian. --------- NJE = NJE + 1 NSLJ = NST JCUR = 1 MBA = MIN(MBAND,N) MEB1 = MEBAND - 1 SRUR = WM(1) FAC = DVNORM (N, SAVF, EWT) R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC IF (R0 .EQ. ZERO) R0 = ONE DO 560 J = 1,MBA DO 530 I = J,N,MBAND YI = Y(I) R = MAX(SRUR*ABS(YI),R0/EWT(I)) Y(I) = Y(I) + R 530 CONTINUE CALL F (N, TN, Y, FTEM, RPAR, IPAR) DO 550 JJ = J,N,MBAND Y(JJ) = YH(JJ,1) YJJ = Y(JJ) R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) FAC = ONE/R I1 = MAX(JJ-MU,1) I2 = MIN(JJ+ML,N) II = JJ*MEB1 - ML + 2 DO 540 I = I1,I2 WM(II+I) = (FTEM(I) - SAVF(I))*FAC 540 CONTINUE 550 CONTINUE 560 CONTINUE NFE = NFE + MBA IF (JSV .EQ. 1) & & CALL DACOPY (MBAND, N, WM(ML3), MEBAND, WM(LOCJS), MBAND) ENDIF C IF (JOK .EQ. 1) THEN JCUR = 0 CALL DACOPY (MBAND, N, WM(LOCJS), MBAND, WM(ML3), MEBAND) ENDIF C C Multiply Jacobian by scalar, add identity, and do LU decomposition. CON = -HRL1 CALL DSCAL (LENP, CON, WM(3), 1 ) II = MBAND + 2 DO 580 I = 1,N WM(II) = WM(II) + ONE II = II + MEBAND 580 CONTINUE NLU = NLU + 1 CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(31), IER) IF (IER .NE. 0) IERPJ = 1 RETURN C End of code block for MITER = 4 or 5. -------------------------------- C C----------------------- End of Subroutine DVJAC ----------------------- END C*********************************************************************** CDECK DACOPY SUBROUTINE DACOPY (NROW, NCOL, A, NROWA, B, NROWB) DOUBLE PRECISION A, B INTEGER NROW, NCOL, NROWA, NROWB DIMENSION A(NROWA,NCOL), B(NROWB,NCOL) C----------------------------------------------------------------------- C Call sequence input -- NROW, NCOL, A, NROWA, NROWB C Call sequence output -- B C COMMON block variables accessed -- None C C Subroutines called by DACOPY.. DCOPY C Function routines called by DACOPY.. None C----------------------------------------------------------------------- C This routine copies one rectangular array, A, to another, B, C where A and B may have different row dimensions, NROWA and NROWB. C The data copied consists of NROW rows and NCOL columns. C----------------------------------------------------------------------- INTEGER IC C DO 20 IC = 1,NCOL CALL DCOPY (NROW, A(1,IC), 1, B(1,IC), 1) 20 CONTINUE C RETURN C----------------------- End of Subroutine DACOPY ---------------------- END C*********************************************************************** CDECK DVSOL SUBROUTINE DVSOL (WM, IWM, X, IERSL) DOUBLE PRECISION WM, X INTEGER IWM, IERSL DIMENSION WM(*), IWM(*), X(*) C----------------------------------------------------------------------- C Call sequence input -- WM, IWM, X C Call sequence output -- X, IERSL C COMMON block variables accessed.. C /DVOD01/ -- H, RL1, MITER, N C C Subroutines called by DVSOL.. DGESL, DGBSL C Function routines called by DVSOL.. None C----------------------------------------------------------------------- C This routine manages the solution of the linear system arising from C a chord iteration. It is called if MITER .ne. 0. C If MITER is 1 or 2, it calls DGESL to accomplish this. C If MITER = 3 it updates the coefficient H*RL1 in the diagonal C matrix, and then computes the solution. C If MITER is 4 or 5, it calls DGBSL. C Communication with DVSOL uses the following variables.. C WM = Real work space containing the inverse diagonal matrix if C MITER = 3 and the LU decomposition of the matrix otherwise. C Storage of matrix elements starts at WM(3). C WM also contains the following matrix-related data.. C WM(1) = SQRT(UROUND) (not used here), C WM(2) = HRL1, the previous value of H*RL1, used if MITER = 3. C IWM = Integer work space containing pivot information, starting at C IWM(31), if MITER is 1, 2, 4, or 5. IWM also contains band C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. C X = The right-hand side vector on input, and the solution vector C on output, of length N. C IERSL = Output flag. IERSL = 0 if no trouble occurred. C IERSL = 1 if a singular matrix arose with MITER = 3. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block DVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C C Type declarations for local variables -------------------------------- C INTEGER I, MEBAND, ML, MU DOUBLE PRECISION DI, HRL1, ONE, PHRL1, R, ZERO C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE ONE, ZERO C COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU(13), TQ(5), TN, UROUND, & & ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C DATA ONE /1.0D0/, ZERO /0.0D0/ C IERSL = 0 C GO TO (100, 100, 300, 400, 400), MITER SELECT CASE (MITER) CASE(1) GOTO 100 CASE(2) GOTO 100 CASE(3) GOTO 300 CASE(4) GOTO 400 CASE(5) GOTO 400 END SELECT 100 CALL DGESL (WM(3), N, N, IWM(31), X, 0) RETURN C 300 PHRL1 = WM(2) HRL1 = H*RL1 WM(2) = HRL1 IF (HRL1 .EQ. PHRL1) GO TO 330 R = HRL1/PHRL1 DO 320 I = 1,N DI = ONE - R*(ONE - ONE/WM(I+2)) IF (ABS(DI) .EQ. ZERO) GO TO 390 WM(I+2) = ONE/DI 320 CONTINUE C 330 DO 340 I = 1,N X(I) = WM(I+2)*X(I) 340 CONTINUE RETURN 390 IERSL = 1 RETURN C 400 ML = IWM(1) MU = IWM(2) MEBAND = 2*ML + MU + 1 CALL DGBSL (WM(3), MEBAND, N, ML, MU, IWM(31), X, 0) RETURN C----------------------- End of Subroutine DVSOL ----------------------- END C******************************************************************** C of xidamax C******************************************************************** C of xDscal C******************************************************************** C of xdaxpy C******************************************************************** C of xDDOT C*********************************************************************** deSolve/src/call_rkFixed.c0000644000176000001440000002351213274246454015243 0ustar ripleyusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >=2 */ /* General RK Solver for methods with fixed step size */ /*==========================================================================*/ #include "rk_util.h" #include "externalptr.h" SEXP call_rkFixed(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc, SEXP Parms, SEXP eventfunc, SEXP elist, SEXP Nout, SEXP Rho, SEXP Tcrit, SEXP Verbose, SEXP Hini, SEXP Rpar, SEXP Ipar, SEXP Method, SEXP Maxsteps, SEXP Flist) { /** Initialization **/ int nprot = 0; double *tt = NULL, *xs = NULL; double *y, *f, *Fj, *tmp, *FF, *rr; SEXP R_yout; double *y0, *y1, *dy1, *out, *yout; double t, dt, tmax; int fsal = FALSE; /* fixed step methods have no FSAL */ int interpolate = TRUE; /* polynomial interpolation is done by default */ int i = 0, j=0, it=0, it_tot=0, it_ext=0, nt = 0, neq=0; int isForcing, isEvent; /**************************************************************************/ /****** Processing of Arguments ******/ /**************************************************************************/ double tcrit = REAL(Tcrit)[0]; double hini = REAL(Hini)[0]; int maxsteps = INTEGER(Maxsteps)[0]; int nout = INTEGER(Nout)[0]; /* number of global outputs if func is in a DLL */ int verbose = INTEGER(Verbose)[0]; int stage = (int)REAL(getListElement(Method, "stage"))[0]; SEXP R_A, R_B1, R_C; double *A, *bb1, *cc=NULL; PROTECT(R_A = getListElement(Method, "A")); nprot++; A = REAL(R_A); PROTECT(R_B1 = getListElement(Method, "b1")); nprot++; bb1 = REAL(R_B1); PROTECT(R_C = getListElement(Method, "c")); nprot++; if (length(R_C)) cc = REAL(R_C); double qerr = REAL(getListElement(Method, "Qerr"))[0]; PROTECT(Times = AS_NUMERIC(Times)); nprot++; tt = NUMERIC_POINTER(Times); nt = length(Times); PROTECT(Xstart = AS_NUMERIC(Xstart)); nprot++; xs = NUMERIC_POINTER(Xstart); neq = length(Xstart); /*------------------------------------------------------------------------*/ /* timesteps (for advection computation in ReacTran) */ /*------------------------------------------------------------------------*/ if (hini > 0) for (i = 0; i < 2; i++) timesteps[i] = fmin(hini, tt[1] - tt[0]); else for (i = 0; i < 2; i++) timesteps[i] = tt[1] - tt[0]; /**************************************************************************/ /****** DLL, ipar, rpar (to be compatible with lsoda) ******/ /**************************************************************************/ int isDll = FALSE; int lrpar= 0, lipar = 0; int *ipar = NULL; if (inherits(Func, "NativeSymbol")) { /* function is a dll */ isDll = TRUE; if (nout > 0) isOut = TRUE; lrpar = nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ isDll = FALSE; isOut = FALSE; lipar = 3; /* in lsoda = 1 */ lrpar = nout; /* in lsoda = 1 */ } out = (double *) R_alloc(lrpar, sizeof(double)); ipar = (int *) R_alloc(lipar, sizeof(int)); ipar[0] = nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; if (isDll == 1) { /* other elements of ipar are set in R-function lsodx via argument *ipar* */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* out: first nout elements of out are reserved for output variables other elements are set via argument *rpar* */ for (j = 0; j < nout; j++) out[j] = 0.0; for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j]; } /*------------------------------------------------------------------------*/ /* Allocation of Workspace */ /*------------------------------------------------------------------------*/ y0 = (double *) R_alloc(neq, sizeof(double)); y1 = (double *) R_alloc(neq, sizeof(double)); dy1 = (double *) R_alloc(neq, sizeof(double)); f = (double *) R_alloc(neq, sizeof(double)); y = (double *) R_alloc(neq, sizeof(double)); Fj = (double *) R_alloc(neq, sizeof(double)); tmp = (double *) R_alloc(neq, sizeof(double)); FF = (double *) R_alloc(neq * stage, sizeof(double)); rr = (double *) R_alloc(neq * 5, sizeof(double)); /* matrix for polynomial interpolation */ SEXP R_nknots; int nknots = 6; /* 6 = 5th order polynomials by default*/ int iknots = 0; /* counter for knots buffer */ double *yknots; PROTECT(R_nknots = getListElement(Method, "nknots")); nprot++; if (length(R_nknots)) nknots = INTEGER(R_nknots)[0] + 1; if (nknots < 2) {nknots=1; interpolate = FALSE;} yknots = (double *) R_alloc((neq + 1) * (nknots + 1), sizeof(double)); /* matrix for holding states and global outputs */ PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); nprot++; yout = REAL(R_yout); /* initialize outputs with NA first */ for (i = 0; i < nt * (neq + nout + 1); i++) yout[i] = NA_REAL; /* attribute that stores state information, similar to lsoda */ SEXP R_istate; int *istate; PROTECT(R_istate = allocVector(INTSXP, 22)); nprot++; istate = INTEGER(R_istate); istate[0] = 0; /* assume succesful return */ for (i = 0; i < 22; i++) istate[i] = 0; /*------------------------------------------------------------------------*/ /* Initialization of Parameters (for DLL functions) */ /*------------------------------------------------------------------------*/ PROTECT(Y = allocVector(REALSXP,(neq))); nprot++; if (Initfunc != NA_STRING) { if (inherits(Initfunc, "NativeSymbol")) { init_func_type *initializer; PROTECT(de_gparms = Parms); nprot++; initializer = (init_func_type *) R_ExternalPtrAddrFn_(Initfunc); initializer(Initdeparms); } } /* assign global variables of the event function */ n_eq = neq; R_envir = Rho; isForcing = initForcings(Flist); isEvent = initEvents(elist, eventfunc, 0); if (isEvent) interpolate = FALSE; /*------------------------------------------------------------------------*/ /* Initialization of Integration Loop */ /*------------------------------------------------------------------------*/ yout[0] = tt[0]; /* initial time */ yknots[0] = tt[0]; /* for polynomial interpolation */ for (i = 0; i < neq; i++) { y0[i] = xs[i]; /* initial values */ yout[(i + 1) * nt] = y0[i]; /* output array */ yknots[iknots + nknots * (i + 1)] = xs[i]; /* for polynomials */ } iknots++; t = tt[0]; tmax = fmax(tt[nt - 1], tcrit); /* Initialization of work arrays (to be on the safe side, remove this later) */ for (i = 0; i < neq; i++) { y1[i] = 0; Fj[i] = 0; for (j= 0; j < stage; j++) { FF[i + j * neq] = 0; } } /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ it = 1; /* step counter; zero element is initial state */ it_ext = 0; /* counter for external time step (dense output) */ it_tot = 0; /* total number of time steps */ if (interpolate) { /* integrate over the whole time step and interpolate internally */ rk_fixed( fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, maxsteps, nt, &iknots, &it, &it_ext, &it_tot, istate, ipar, t, tmax, hini, &dt, tt, y0, y1, dy1, f, y, Fj, tmp, FF, rr, A, out, bb1, cc, yknots, yout, Func, Parms, Rho ); } else { /* integrate until next time step and return */ for (int j = 0; j < nt - 1; j++) { t = tt[j]; tmax = fmin(tt[j + 1], tcrit); dt = tmax - t; if (isEvent) { updateevent(&t, y0, istate); } rk_fixed( fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, maxsteps, nt, &iknots, &it, &it_ext, &it_tot, istate, ipar, t, tmax, fmin(hini, fabs(dt)) * sign(dt), // <----- hini for backward steps (still experimental) &dt, tt, y0, y1, dy1, f, y, Fj, tmp, FF, rr, A, out, bb1, cc, yknots, yout, Func, Parms, Rho ); /* in this mode, internal interpolation is skipped, so we can simply store the results at the end of each call */ yout[j + 1] = tmax; for (i = 0; i < neq; i++) yout[j + 1 + nt * (1 + i)] = y1[i]; } } /*====================================================================*/ /* call derivs again to get global outputs */ /* j = -1 suppresses unnecessary internal copying */ /*====================================================================*/ if(nout > 0) { for (int j = 0; j < nt; j++) { t = yout[j]; for (i = 0; i < neq; i++) tmp[i] = yout[j + nt * (1 + i)]; derivs(Func, t, tmp, Parms, Rho, FF, out, -1, neq, ipar, isDll, isForcing); for (i = 0; i < nout; i++) { yout[j + nt * (1 + neq + i)] = out[i]; } } } /* attach diagnostic information (codes are compatible to lsoda) */ setIstate(R_yout, R_istate, istate, it_tot, stage, fsal, qerr, 0); /* verbose printing in debugging mode*/ if (verbose) { Rprintf("Number of time steps it = %d, it_ext = %d, it_tot = %d\n", it, it_ext, it_tot); Rprintf("Maxsteps %d\n", maxsteps); } /* release R resources */ timesteps[0] = 0; timesteps[1] = 0; UNPROTECT(nprot); return(R_yout); } deSolve/src/DLLutil.c0000644000176000001440000000400413274246344014156 0ustar ripleyusers/* Functions to test compiled code implementation of ODE and DAE */ #include #include #include "deSolve.h" #include "externalptr.h" SEXP call_DLL(SEXP y, SEXP dY, SEXP time, SEXP func, SEXP initfunc, SEXP parms, SEXP nOut, SEXP Rpar, SEXP Ipar, SEXP Type, SEXP flist) { SEXP yout; double *ytmp, *dy, tin, *delta, cj; int ny, j, type, ires, isDll, isForcing, nout=0, ntot=0; C_deriv_func_type *derivs; C_res_func_type *res; int nprot = 0; ny = LENGTH(y); type = INTEGER(Type)[0]; /* function is a dll ?*/ if (inherits(func, "NativeSymbol")) { isDll = 1; } else { isDll = 0; } /* initialise output, parameters, forcings ... */ initOutR(isDll, &nout, &ntot, ny, nOut, Rpar, Ipar); //initParms(initfunc, parms); if (initfunc != NA_STRING) { if (inherits(initfunc, "NativeSymbol")) { init_func_type *initializer; PROTECT(de_gparms = parms); nprot++; initializer = (init_func_type *) R_ExternalPtrAddrFn_(initfunc); initializer(Initdeparms); } } // end inline initParms isForcing = initForcings(flist); PROTECT(yout = allocVector(REALSXP,ntot)); nprot++; tin = REAL(time)[0]; ytmp = (double *) R_alloc(ny, sizeof(double)); for (j = 0; j < ny; j++) ytmp[j] = REAL(y)[j]; dy = (double *) R_alloc(ny, sizeof(double)); for (j = 0; j < ny; j++) dy[j] = REAL(dY)[j]; if(isForcing == 1) updatedeforc(&tin); if (type == 1) { derivs = (C_deriv_func_type *) R_ExternalPtrAddrFn_(func); derivs (&ny, &tin, ytmp, dy, out, ipar) ; for (j = 0; j < ny; j++) REAL(yout)[j] = dy[j]; } else { res = (C_res_func_type *) R_ExternalPtrAddrFn_(func); delta = (double *) R_alloc(ny, sizeof(double)); for (j = 0; j < ny; j++) delta[j] = 0.; res (&tin, ytmp, dy, &cj, delta, &ires, out, ipar) ; for (j = 0; j < ny; j++) REAL(yout)[j] = delta[j]; } if (nout > 0) { for (j = 0; j < nout; j++) REAL(yout)[j + ny] = out[j]; } UNPROTECT(nprot); return(yout); } deSolve/src/dlinpk.f0000644000176000001440000003554013564604217014141 0ustar ripleyusersC The code in this file is was taken from daspk.tgz from C https://www.netlib.org/ode/ C Author: Cleve Moler, University of New Mexico, Argonne National Lab. C C Adapted for use in R package deSolve by the deSolve authors. C subroutine dgefa(a,lda,n,ipvt,info) integer lda,n,ipvt(*),info double precision a(lda,*) c c dgefa factors a double precision matrix by gaussian elimination. c c dgefa is usually called by dgeco, but it can be called c directly with a saving in time if rcond is not needed. c (time for dgeco) = (1 + 9/n)*(time for dgefa) . c c on entry c c a double precision(lda, n) c the matrix to be factored. c c lda integer c the leading dimension of the array a . c c n integer c the order of the matrix a . c c on return c c a an upper triangular matrix and the multipliers c which were used to obtain it. c the factorization can be written a = l*u where c l is a product of permutation and unit lower c triangular matrices and u is upper triangular. c c ipvt integer(n) c an integer vector of pivot indices. c c info integer c = 0 normal value. c = k if u(k,k) .eq. 0.0 . this is not an error c condition for this subroutine, but it does c indicate that dgesl or dgedi will divide by zero c if called. use rcond in dgeco for a reliable c indication of singularity. c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas daxpy,dscal,idamax c c internal variables c double precision t integer idamax,j,k,kp1,l,nm1 c c c gaussian elimination with partial pivoting c info = 0 nm1 = n - 1 if (nm1 .lt. 1) go to 70 do 60 k = 1, nm1 kp1 = k + 1 c c find l = pivot index c l = idamax(n-k+1,a(k,k),1) + k - 1 ipvt(k) = l c c zero pivot implies this column already triangularized c if (a(l,k) .eq. 0.0d0) go to 40 c c interchange if necessary c if (l .eq. k) go to 10 t = a(l,k) a(l,k) = a(k,k) a(k,k) = t 10 continue c c compute multipliers c t = -1.0d0/a(k,k) call dscal(n-k,t,a(k+1,k),1) c c row elimination with column indexing c do 30 j = kp1, n t = a(l,j) if (l .eq. k) go to 20 a(l,j) = a(k,j) a(k,j) = t 20 continue call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) 30 continue go to 50 40 continue info = k 50 continue 60 continue 70 continue ipvt(n) = n if (a(n,n) .eq. 0.0d0) info = n return end subroutine dgesl(a,lda,n,ipvt,b,job) integer lda,n,ipvt(*),job double precision a(lda,*),b(*) c c dgesl solves the double precision system c a * x = b or trans(a) * x = b c using the factors computed by dgeco or dgefa. c c on entry c c a double precision(lda, n) c the output from dgeco or dgefa. c c lda integer c the leading dimension of the array a . c c n integer c the order of the matrix a . c c ipvt integer(n) c the pivot vector from dgeco or dgefa. c c b double precision(n) c the right hand side vector. c c job integer c = 0 to solve a*x = b , c = nonzero to solve trans(a)*x = b where c trans(a) is the transpose. c c on return c c b the solution vector x . c c error condition c c a division by zero will occur if the input factor contains a c zero on the diagonal. technically this indicates singularity c but it is often caused by improper arguments or improper c setting of lda . it will not occur if the subroutines are c called correctly and if dgeco has set rcond .gt. 0.0 c or dgefa has set info .eq. 0 . c c to compute inverse(a) * c where c is a matrix c with p columns c call dgeco(a,lda,n,ipvt,rcond,z) c if (rcond is too small) go to ... c do 10 j = 1, p c call dgesl(a,lda,n,ipvt,c(1,j),0) c 10 continue c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas daxpy,ddot c c internal variables c double precision ddot,t integer k,kb,l,nm1 c nm1 = n - 1 if (job .ne. 0) go to 50 c c job = 0 , solve a * x = b c first solve l*y = b c if (nm1 .lt. 1) go to 30 do 20 k = 1, nm1 l = ipvt(k) t = b(l) if (l .eq. k) go to 10 b(l) = b(k) b(k) = t 10 continue call daxpy(n-k,t,a(k+1,k),1,b(k+1),1) 20 continue 30 continue c c now solve u*x = y c do 40 kb = 1, n k = n + 1 - kb b(k) = b(k)/a(k,k) t = -b(k) call daxpy(k-1,t,a(1,k),1,b(1),1) 40 continue go to 100 50 continue c c job = nonzero, solve trans(a) * x = b c first solve trans(u)*y = b c do 60 k = 1, n t = ddot(k-1,a(1,k),1,b(1),1) b(k) = (b(k) - t)/a(k,k) 60 continue c c now solve trans(l)*x = y c if (nm1 .lt. 1) go to 90 do 80 kb = 1, nm1 k = n - kb b(k) = b(k) + ddot(n-k,a(k+1,k),1,b(k+1),1) l = ipvt(k) if (l .eq. k) go to 70 t = b(l) b(l) = b(k) b(k) = t 70 continue 80 continue 90 continue 100 continue return end subroutine dgbfa(abd,lda,n,ml,mu,ipvt,info) integer lda,n,ml,mu,ipvt(*),info double precision abd(lda,*) c c dgbfa factors a double precision band matrix by elimination. c c dgbfa is usually called by dgbco, but it can be called c directly with a saving in time if rcond is not needed. c c on entry c c abd double precision(lda, n) c contains the matrix in band storage. the columns c of the matrix are stored in the columns of abd and c the diagonals of the matrix are stored in rows c ml+1 through 2*ml+mu+1 of abd . c see the comments below for details. c c lda integer c the leading dimension of the array abd . c lda must be .ge. 2*ml + mu + 1 . c c n integer c the order of the original matrix. c c ml integer c number of diagonals below the main diagonal. c 0 .le. ml .lt. n . c c mu integer c number of diagonals above the main diagonal. c 0 .le. mu .lt. n . c more efficient if ml .le. mu . c on return c c abd an upper triangular matrix in band storage and c the multipliers which were used to obtain it. c the factorization can be written a = l*u where c l is a product of permutation and unit lower c triangular matrices and u is upper triangular. c c ipvt integer(n) c an integer vector of pivot indices. c c info integer c = 0 normal value. c = k if u(k,k) .eq. 0.0 . this is not an error c condition for this subroutine, but it does c indicate that dgbsl will divide by zero if c called. use rcond in dgbco for a reliable c indication of singularity. c c band storage c c if a is a band matrix, the following program segment c will set up the input. c c ml = (band width below the diagonal) c mu = (band width above the diagonal) c m = ml + mu + 1 c do 20 j = 1, n c i1 = max0(1, j-mu) c i2 = min0(n, j+ml) c do 10 i = i1, i2 c k = i - j + m c abd(k,j) = a(i,j) c 10 continue c 20 continue c c this uses rows ml+1 through 2*ml+mu+1 of abd . c in addition, the first ml rows in abd are used for c elements generated during the triangularization. c the total number of rows needed in abd is 2*ml+mu+1 . c the ml+mu by ml+mu upper left triangle and the c ml by ml lower right triangle are not referenced. c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas daxpy,dscal,idamax c fortran max0,min0 c c internal variables c double precision t integer i,idamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 c c m = ml + mu + 1 info = 0 c c zero initial fill-in columns c j0 = mu + 2 j1 = min0(n,m) - 1 if (j1 .lt. j0) go to 30 do 20 jz = j0, j1 i0 = m + 1 - jz do 10 i = i0, ml abd(i,jz) = 0.0d0 10 continue 20 continue 30 continue jz = j1 ju = 0 c c gaussian elimination with partial pivoting c nm1 = n - 1 if (nm1 .lt. 1) go to 130 do 120 k = 1, nm1 kp1 = k + 1 c c zero next fill-in column c jz = jz + 1 if (jz .gt. n) go to 50 if (ml .lt. 1) go to 50 do 40 i = 1, ml abd(i,jz) = 0.0d0 40 continue 50 continue c c find l = pivot index c lm = min0(ml,n-k) l = idamax(lm+1,abd(m,k),1) + m - 1 ipvt(k) = l + k - m c c zero pivot implies this column already triangularized c if (abd(l,k) .eq. 0.0d0) go to 100 c c interchange if necessary c if (l .eq. m) go to 60 t = abd(l,k) abd(l,k) = abd(m,k) abd(m,k) = t 60 continue c c compute multipliers c t = -1.0d0/abd(m,k) call dscal(lm,t,abd(m+1,k),1) c c row elimination with column indexing c ju = min0(max0(ju,mu+ipvt(k)),n) mm = m if (ju .lt. kp1) go to 90 do 80 j = kp1, ju l = l - 1 mm = mm - 1 t = abd(l,j) if (l .eq. mm) go to 70 abd(l,j) = abd(mm,j) abd(mm,j) = t 70 continue call daxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1) 80 continue 90 continue go to 110 100 continue info = k 110 continue 120 continue 130 continue ipvt(n) = n if (abd(m,n) .eq. 0.0d0) info = n return end subroutine dgbsl(abd,lda,n,ml,mu,ipvt,b,job) integer lda,n,ml,mu,ipvt(*),job double precision abd(lda,*),b(*) c c dgbsl solves the double precision band system c a * x = b or trans(a) * x = b c using the factors computed by dgbco or dgbfa. c c on entry c c abd double precision(lda, n) c the output from dgbco or dgbfa. c c lda integer c the leading dimension of the array abd . c c n integer c the order of the original matrix. c c ml integer c number of diagonals below the main diagonal. c c mu integer c number of diagonals above the main diagonal. c c ipvt integer(n) c the pivot vector from dgbco or dgbfa. c c b double precision(n) c the right hand side vector. c c job integer c = 0 to solve a*x = b , c = nonzero to solve trans(a)*x = b , where c trans(a) is the transpose. c c on return c c b the solution vector x . c c error condition c c a division by zero will occur if the input factor contains a c zero on the diagonal. technically this indicates singularity c but it is often caused by improper arguments or improper c setting of lda . it will not occur if the subroutines are c called correctly and if dgbco has set rcond .gt. 0.0 c or dgbfa has set info .eq. 0 . c c to compute inverse(a) * c where c is a matrix c with p columns c call dgbco(abd,lda,n,ml,mu,ipvt,rcond,z) c if (rcond is too small) go to ... c do 10 j = 1, p c call dgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0) c 10 continue c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas daxpy,ddot c fortran min0 c c internal variables c double precision ddot,t integer k,kb,l,la,lb,lm,m,nm1 c m = mu + ml + 1 nm1 = n - 1 if (job .ne. 0) go to 50 c c job = 0 , solve a * x = b c first solve l*y = b c if (ml .eq. 0) go to 30 if (nm1 .lt. 1) go to 30 do 20 k = 1, nm1 lm = min0(ml,n-k) l = ipvt(k) t = b(l) if (l .eq. k) go to 10 b(l) = b(k) b(k) = t 10 continue call daxpy(lm,t,abd(m+1,k),1,b(k+1),1) 20 continue 30 continue c c now solve u*x = y c do 40 kb = 1, n k = n + 1 - kb b(k) = b(k)/abd(m,k) lm = min0(k,m) - 1 la = m - lm lb = k - lm t = -b(k) call daxpy(lm,t,abd(la,k),1,b(lb),1) 40 continue go to 100 50 continue c c job = nonzero, solve trans(a) * x = b c first solve trans(u)*y = b c do 60 k = 1, n lm = min0(k,m) - 1 la = m - lm lb = k - lm t = ddot(lm,abd(la,k),1,b(lb),1) b(k) = (b(k) - t)/abd(m,k) 60 continue c c now solve trans(l)*x = y c if (ml .eq. 0) go to 90 if (nm1 .lt. 1) go to 90 do 80 kb = 1, nm1 k = n - kb lm = min0(ml,n-k) b(k) = b(k) + ddot(lm,abd(m+1,k),1,b(k+1),1) l = ipvt(k) if (l .eq. k) go to 70 t = b(l) b(l) = b(k) b(k) = t 70 continue 80 continue 90 continue 100 continue return end deSolve/src/externalptr.h0000644000176000001440000000102513274246270015220 0ustar ripleyusers/* Distinguish function pointer from object pointer R >= 3.4 while maintainig compatibility with pre R 3.4 versions */ /* Usage: - include this header - rename R_ExternalPtrAddr to R_ExternalPtrAddr_ - This underscore version and externalptr.h may be removed in future versions of R. Th. Petzoldt, 2016-09-05 */ #include #if defined(R_VERSION) && R_VERSION >= R_Version(3, 4, 0) # define R_ExternalPtrAddrFn_ R_ExternalPtrAddrFn #else # define R_ExternalPtrAddrFn_ R_ExternalPtrAddr #endif deSolve/src/zvode.h0000644000176000001440000000321113136461013013765 0ustar ripleyusers#include #include /* global variables */ typedef void C_zderiv_func_type (int *, double *, Rcomplex *,Rcomplex *, Rcomplex *, int *); C_zderiv_func_type *DLL_cderiv_func; SEXP cY; /* livermore solver globals */ extern SEXP cvode_deriv_func; extern SEXP cvode_jac_func; extern SEXP vode_envir; Rcomplex *zout; void initOutComplex(int isDll, int *nout, int *ntot, int neq, SEXP nOut, SEXP Rpar, SEXP Ipar) { int j, lrpar, lipar; * nout = INTEGER(nOut)[0]; /* number of output variables */ if (isDll) /* function is a dll */ { if (*nout > 0) isOut = 1; *ntot = neq + *nout; /* length of yout */ lrpar = *nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else /* function is not a dll */ { isOut = 0; *ntot = neq; lipar = 1; lrpar = 1; } zout = (Rcomplex *) R_alloc(lrpar, sizeof(Rcomplex)); ipar = (int *) R_alloc(lipar, sizeof(int)); if (isDll ==1) { ipar[0] = *nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; /* other elements of ipar are set in R-function lsodx via argument *ipar* */ for (j = 0; j < LENGTH(Ipar);j++) ipar[j+3] = INTEGER(Ipar)[j]; /* first nout elements of rpar reserved for output variables other elements are set in R-function zvode via argument *rpar* */ // for (j = 0; j < nout; j++) zout[j] = 0+0i; for (j = 0; j < LENGTH(Rpar);j++) zout[*nout+j] = COMPLEX(Rpar)[j]; } } deSolve/src/deSolve_utils.c0000644000176000001440000002716713576521126015504 0ustar ripleyusers/* Define some global variables and functions that operate on some of them */ #include #include #ifndef R_INTERNALS_H_ #include #endif #include #include #include "deSolve.h" #include "externalptr.h" int solver_locked = 0; /* prevent nested calls of odepack solvers */ void lock_solver(void) { if (solver_locked) { /* important: unlock for the next call *after* error */ solver_locked = 0; error("The used combination of solvers cannot be nested.\n"); } solver_locked = 1; } void unlock_solver(void) { solver_locked = 0; timesteps[0] = 0; timesteps[1] = 0; } /* Globals :*/ // SEXP R_deriv_func; // SEXP R_jac_func; // SEXP R_jac_vec; // SEXP R_root_func; // SEXP R_event_func; // SEXP R_envir; // SEXP odesolve_gparms; // SEXP R_res_func; // SEXP R_daejac_func; // SEXP R_psol_func; // SEXP R_mas_func; // SEXP de_gparms; /*====================================================== Parameter initialisation functions note: forcing initialisation function is in forcings.c =======================================================*/ void Initdeparms(int *N, double *parms) { int i, Nparms; Nparms = LENGTH(de_gparms); if ((*N) != Nparms) { warning("Number of parameters passed to solver, %i; number in DLL, %i\n", Nparms, *N); PROBLEM "Confusion over the length of parms" ERROR; } else { for (i = 0; i < *N; i++) parms[i] = REAL(de_gparms)[i]; } } SEXP get_deSolve_gparms(void) { return de_gparms; } /*=========================================================================== C-equivalent of R-function timestep: gets the past and new time step =========================================================================== */ SEXP getTimestep() { SEXP value; PROTECT(value = NEW_NUMERIC(2)); if (timesteps == NULL) { /* integration not yet started... */ for (int i = 0; i < 2; i++) NUMERIC_POINTER(value)[i] = 0.0; } else for (int i = 0; i < 2; i++) NUMERIC_POINTER(value)[i] = timesteps[i]; UNPROTECT(1); return(value); } /*================================================== Termination ===================================================*/ /* an error occurred - save output in YOUT2 */ void returnearly (int Print, int it, int ntot) { int j, k; if (Print) warning("Returning early. Results are accurate, as far as they go\n"); // thpe: protect before the call //PROTECT(YOUT2 = allocMatrix(REALSXP,ntot+1,(it+2))); //incr_N_Protect(); for (k = 0; k < it+2; k++) for (j = 0; j < ntot+1; j++) REAL(YOUT2)[k*(ntot+1) + j] = REAL(YOUT)[k*(ntot+1) + j]; //UNPROTECT(1); // thpe } /* add ISTATE and RSTATE */ void terminate(int istate, int * iwork, int ilen, int ioffset, double * rwork, int rlen, int roffset) { int k; //PROTECT(ISTATE = allocVector(INTSXP, ilen)); //incr_N_Protect(); for (k = 0; k < ilen-1; k++) INTEGER(ISTATE)[k+1] = iwork[k +ioffset]; INTEGER(ISTATE)[0] = istate; //PROTECT(RWORK = allocVector(REALSXP, rlen)); //incr_N_Protect(); for (k = 0; k < rlen; k++) REAL(RWORK)[k] = rwork[k+roffset]; if (istate > 0) { setAttrib(YOUT, install("istate"), ISTATE); setAttrib(YOUT, install("rstate"), RWORK); } else { setAttrib(YOUT2, install("istate"), ISTATE); setAttrib(YOUT2, install("rstate"), RWORK); } /* timestep = 0 - for use in getTimestep */ timesteps[0] = 0; timesteps[1] = 0; //UNPROTECT(2); //thpe } /*================================================== extracting elements from a list ===================================================*/ SEXP getListElement(SEXP list, const char *str) { SEXP elmt = R_NilValue, names = getAttrib(list, R_NamesSymbol); int i; for (i = 0; i < length(list); i++) if (strcmp(CHAR(STRING_ELT(names, i)), str) == 0) { elmt = VECTOR_ELT(list, i); break; } return elmt; } /*================================================== output initialisation function out and ipar are used to pass output variables (number set by nout) followed by other input by R-arguments rpar, ipar ipar[0]: number of output variables, ipar[1]: length of rpar, ipar[2]: length of ipar ===================================================*/ /* Initialise output - output variables calculated in R-code ... */ void initOutR(int isDll, int *nout, int *ntot, int neq, SEXP nOut, SEXP Rpar, SEXP Ipar) { int j, lrpar, lipar; *nout = INTEGER(nOut)[0]; /* number of output variables */ if (isDll) { /* function is a dll */ if (*nout > 0) isOut = 1; *ntot = neq + *nout; /* length of yout */ lrpar = *nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ isOut = 0; *ntot = neq; lipar = 1; lrpar = 1; } out = (double*) R_alloc(lrpar, sizeof(double)); ipar = (int*) R_alloc(lipar, sizeof(int)); if (isDll ==1) { ipar[0] = *nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; /* other elements of ipar are set in R-function lsodx via argument *ipar* */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* first nout elements of rpar reserved for output variables other elements are set in R-function lsodx via argument *rpar* */ for (j = 0; j < *nout; j++) out[j] = 0.; for (j = 0; j < LENGTH(Rpar); j++) out[*nout+j] = REAL(Rpar)[j]; } } /* Initialise output - output variables calculated in C-code ... */ void initOutC(int isDll, int *nout, int *ntot, int neq, SEXP nOut, SEXP Rpar, SEXP Ipar) { int j, lrpar, lipar; /* initialise output when a dae ... */ /* output always done here in C-code (<-> lsode, vode)... */ *nout = INTEGER(nOut)[0]; *ntot = n_eq+*nout; if (isDll == 1) { /* function is a dll */ lrpar = *nout + LENGTH(Rpar); /* length of rpar */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ lipar = 3; lrpar = *nout; } out = (double*) R_alloc(lrpar, sizeof(double)); ipar = (int*) R_alloc(lipar, sizeof(int)); if (isDll == 1) { ipar[0] = *nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; /* other elements of ipar are set in R-function lsodx via argument *ipar* */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* first nout elements of rpar reserved for output variables other elements are set in R-function lsodx via argument *rpar* */ for (j = 0; j < *nout; j++) out[j] = 0.; for (j = 0; j < LENGTH(Rpar); j++) out[*nout+j] = REAL(Rpar)[j]; } } /*================================================== 1-D, 2-D and 3-D sparsity structure ================================================== */ void sparsity1D (SEXP Type, int* iwork, int neq, int liw) { int nspec, nx, ij, i, j, k, l; nspec = INTEGER(Type)[1]; /* number of components*/ nx = INTEGER(Type)[2]; /* dimension x*/ ij = 31 + neq; iwork[30] = 1; k = 1; for( i = 0; i < nspec; i++) { for( j = 0; j < nx; j++) { if (ij > liw-3-nspec) error ("not enough memory allocated in iwork - increase liw %i ",liw); iwork[ij++] = k; if (j < nx-1) iwork[ij++] = k+1 ; if (j > 0) iwork[ij++] = k-1 ; for(l = 0; l < nspec; l++) if (l != i) iwork[ij++] = l*nx+j+1; iwork[30+k] = ij-30-neq; k = k+1; } } iwork[ij] = 0; } /*==================================================*/ void sparsity2D (SEXP Type, int* iwork, int neq, int liw) { int nspec, nx, ny, bndx, bndy, Nt, ij, isp, i, j, k, l, m; nspec = INTEGER(Type)[1]; /* number components*/ nx = INTEGER(Type)[2]; /* dimension x*/ ny = INTEGER(Type)[3]; /* dimension y*/ bndx = INTEGER(Type)[4]; /* cyclic boundary x*/ bndy = INTEGER(Type)[5]; /* cyclic boundary y*/ Nt = nx*ny; ij = 31 + neq; iwork[30] = 1; m = 1; for( i = 0; i < nspec; i++) { isp = i*Nt; for( j = 0; j < nx; j++) { for( k = 0; k < ny; k++) { if (ij > liw-8-nspec) error("not enough memory allocated in iwork - increase liw %i ",liw); iwork[ij++] = m; if (k < ny-1) iwork[ij++] = m+1; if (j < nx-1) iwork[ij++] = m+ny; if (j > 0) iwork[ij++] = m-ny; if (k > 0) iwork[ij++] = m-1; if (bndx == 1) { if (j == 0) iwork[ij++] = isp+(nx-1)*ny+k+1; if (j == nx-1) iwork[ij++] = isp+k+1; } if (bndy == 1) { if (k == 0) iwork[ij++] = isp+(j+1)*ny; if (k == ny-1) iwork[ij++] = isp + j*ny +1; } for(l = 0; l < nspec; l++) if (l != i) iwork[ij++] = l*Nt+j*ny+k+1; iwork[30+m] = ij-30-neq; m = m+1; } } } } void interact (int *ij, int nnz, int *iwork, int is, int ival) { int i, isave; isave = 1; /* check if not yet present for current state */ for (i = is; i < *ij; i++) if (iwork[i] == ival) { isave = 0; break; } /* save */ if (isave == 1) { if (*ij > nnz) error ("not enough memory allocated in iwork - increase liw %i ", nnz); iwork[(*ij)++] = ival; } } /*==================================================*/ /* an element in C-array A(I,J,K), i=0,dim(1)-1 etc... is positioned at j*dim(2)*dim(3) + k*dim(3) + l + 1 in FORTRAN VECTOR! includes check on validity dimens and boundary are reversed ... */ void sparsity3D (SEXP Type, int* iwork, int neq, int liw) { int nspec, nx, ny, nz, bndx, bndy, bndz, Nt, ij, is, isp, i, j, k, l, m, ll; nspec = INTEGER(Type)[1]; nx = INTEGER(Type)[2]; ny = INTEGER(Type)[3]; nz = INTEGER(Type)[4]; bndx = INTEGER(Type)[5]; bndy = INTEGER(Type)[6]; bndz = INTEGER(Type)[7]; Nt = nx*ny*nz; ij = 31+neq; iwork[30] = 1; m = 1; for( i = 0; i < nspec; i++) { isp = i*Nt; for( j = 0; j < nx; j++) { for( k = 0; k < ny; k++) { for( ll = 0; ll < nz; ll++) { is = ij; if (ij > liw-6-nspec) error ("not enough memory allocated in iwork - increase liw %i ", liw); interact (&ij, liw, iwork, is, m); if (ll < nz-1) interact (&ij, liw, iwork, is, m+1); else if (bndz == 1) interact (&ij, liw, iwork, is, isp + j*ny*nz + k*nz + 1); if (k < ny-1) interact (&ij, liw, iwork, is, m+nz); else if (bndy == 1) interact (&ij, liw, iwork, is, isp + j*ny*nz + ll + 1); if (j < nx-1) interact (&ij, liw, iwork, is, m+ny*nz); else if (bndx == 1) interact (&ij, liw, iwork, is, isp + k*nz + ll + 1); if (j > 0) interact (&ij, liw, iwork, is, m-ny*nz); else if (bndx == 1) interact (&ij, liw, iwork, is, isp+(nx-1)*ny*nz+k*nz+ll+1); if (k > 0) interact (&ij, liw, iwork, is, m-nz); else if (bndy == 1) interact (&ij, liw, iwork, is, isp + j*ny*nz+(ny-1)*nz+ll+1); if (ll > 0) interact (&ij, liw, iwork, is, m-1); else if (bndz == 1) interact (&ij, liw, iwork, is, isp + j*ny*nz+k*nz+nz); for(l = 0; l < nspec; l++) if (l != i) interact (&ij, liw, iwork, is, l*Nt+j*ny*nz+k*nz+ll+1); iwork[30+m] = ij-30-neq; m = m+1; } } } } } deSolve/src/call_rkAuto.c0000644000176000001440000002715613274246462015123 0ustar ripleyusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >=2 */ /* General RK Solver for methods with adaptive step size */ /*==========================================================================*/ #include "rk_util.h" #include "externalptr.h" SEXP call_rkAuto(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc, SEXP Parms, SEXP eventfunc, SEXP elist, SEXP Nout, SEXP Rho, SEXP Rtol, SEXP Atol, SEXP Tcrit, SEXP Verbose, SEXP Hmin, SEXP Hmax, SEXP Hini, SEXP Rpar, SEXP Ipar, SEXP Method, SEXP Maxsteps, SEXP Flist) { /** Initialization **/ int nprot = 0; double *tt = NULL, *xs = NULL; double *y, *f, *Fj, *tmp, *FF, *rr; SEXP R_yout; double *y0, *y1, *y2, *dy1, *dy2, *out, *yout; double errold = 0.0, t, dt, tmax; SEXP R_FSAL, Alpha, Beta; int fsal = FALSE; /* assume no FSAL */ /* Use polynomial interpolation if not disabled by the method or when events come in to play (stop-and-go mode). Methods with dense output interpolate by default, all others do not. */ int interpolate = TRUE; int i = 0, j = 0, it = 0, it_tot = 0, it_ext = 0, nt = 0, neq = 0, it_rej = 0; int isForcing, isEvent; /*------------------------------------------------------------------------*/ /* Processing of Arguments */ /*------------------------------------------------------------------------*/ int lAtol = LENGTH(Atol); double *atol = (double*) R_alloc((int) lAtol, sizeof(double)); int lRtol = LENGTH(Rtol); double *rtol = (double*) R_alloc((int) lRtol, sizeof(double)); for (j = 0; j < lRtol; j++) rtol[j] = REAL(Rtol)[j]; for (j = 0; j < lAtol; j++) atol[j] = REAL(Atol)[j]; double tcrit = REAL(Tcrit)[0]; double hmin = REAL(Hmin)[0]; double hmax = REAL(Hmax)[0]; double hini = REAL(Hini)[0]; int maxsteps = INTEGER(Maxsteps)[0]; int nout = INTEGER(Nout)[0]; /* number of global outputs is func is in a DLL */ int verbose = INTEGER(Verbose)[0]; int stage = (int)REAL(getListElement(Method, "stage"))[0]; SEXP R_A, R_B1, R_B2, R_C, R_D, R_densetype; double *A, *bb1, *bb2 = NULL, *cc = NULL, *dd = NULL; PROTECT(R_A = getListElement(Method, "A")); nprot++; A = REAL(R_A); PROTECT(R_B1 = getListElement(Method, "b1")); nprot++; bb1 = REAL(R_B1); PROTECT(R_B2 = getListElement(Method, "b2")); nprot++; if (length(R_B2)) bb2 = REAL(R_B2); PROTECT(R_C = getListElement(Method, "c")); nprot++; if (length(R_C)) cc = REAL(R_C); PROTECT(R_D = getListElement(Method, "d")); nprot++; if (length(R_D)) dd = REAL(R_D); /* dense output Cash-Karp: densetype = 2 */ int densetype = 0; PROTECT(R_densetype = getListElement(Method, "densetype")); nprot++; if (length(R_densetype)) densetype = INTEGER(R_densetype)[0]; double qerr = REAL(getListElement(Method, "Qerr"))[0]; double beta = 0; /* 0.4/qerr; */ PROTECT(Beta = getListElement(Method, "beta")); nprot++; if (length(Beta)) beta = REAL(Beta)[0]; double alpha = 1/qerr - 0.75 * beta; PROTECT(Alpha = getListElement(Method, "alpha")); nprot++; if (length(Alpha)) alpha = REAL(Alpha)[0]; PROTECT(R_FSAL = getListElement(Method, "FSAL")); nprot++; if (length(R_FSAL)) fsal = INTEGER(R_FSAL)[0]; PROTECT(Times = AS_NUMERIC(Times)); nprot++; tt = NUMERIC_POINTER(Times); nt = length(Times); PROTECT(Xstart = AS_NUMERIC(Xstart)); nprot++; xs = NUMERIC_POINTER(Xstart); neq = length(Xstart); /*------------------------------------------------------------------------*/ /* timesteps (for advection computation in ReacTran) */ /*------------------------------------------------------------------------*/ for (i = 0; i < 2; i++) timesteps[i] = 0; /*------------------------------------------------------------------------*/ /* DLL, ipar, rpar (for compatibility with lsoda) */ /*------------------------------------------------------------------------*/ int isDll = FALSE; int lrpar= 0, lipar = 0; int *ipar = NULL; /* code adapted from lsoda to improve compatibility */ if (inherits(Func, "NativeSymbol")) { /* function is a dll */ isDll = TRUE; if (nout > 0) isOut = TRUE; lrpar = nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ isDll = FALSE; isOut = FALSE; lipar = 3; /* in lsoda = 1 */ lrpar = nout; /* in lsoda = 1 */ } out = (double*) R_alloc(lrpar, sizeof(double)); ipar = (int *) R_alloc(lipar, sizeof(int)); /* first 3 elements of ipar are special */ ipar[0] = nout; ipar[1] = lrpar; ipar[2] = lipar; if (isDll == 1) { /* other elements of ipar are set in R-function lsodx via argument "ipar" */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* out: first nout elements of out are reserved for output variables other elements are set via argument "rpar" */ for (j = 0; j < nout; j++) out[j] = 0.0; for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j]; } /*------------------------------------------------------------------------*/ /* Allocation of Workspace */ /*------------------------------------------------------------------------*/ y0 = (double*) R_alloc(neq, sizeof(double)); y1 = (double*) R_alloc(neq, sizeof(double)); y2 = (double*) R_alloc(neq, sizeof(double)); dy1 = (double*) R_alloc(neq, sizeof(double)); dy2 = (double*) R_alloc(neq, sizeof(double)); f = (double*) R_alloc(neq, sizeof(double)); y = (double*) R_alloc(neq, sizeof(double)); Fj = (double*) R_alloc(neq, sizeof(double)); tmp = (double*) R_alloc(neq, sizeof(double)); FF = (double*) R_alloc(neq * stage, sizeof(double)); rr = (double*) R_alloc(neq * 5, sizeof(double)); /* matrix for polynomial interpolation */ SEXP R_nknots; int nknots = 6; /* 6 = 5th order polynomials by default*/ int iknots = 0; /* counter for knots buffer */ double *yknots; PROTECT(R_nknots = getListElement(Method, "nknots")); nprot++; if (length(R_nknots)) nknots = INTEGER(R_nknots)[0] + 1; if (nknots < 2) {nknots = 1; interpolate = FALSE;} if (densetype > 0) interpolate = TRUE; yknots = (double*) R_alloc((neq + 1) * (nknots + 1), sizeof(double)); /* matrix for holding states and global outputs */ PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); nprot++; yout = REAL(R_yout); /* initialize outputs with NA first */ for (i = 0; i < nt * (neq + nout + 1); i++) yout[i] = NA_REAL; /* attribute that stores state information, similar to lsoda */ SEXP R_istate; int *istate; PROTECT(R_istate = allocVector(INTSXP, 22)); nprot++; istate = INTEGER(R_istate); istate[0] = 0; /* assume succesful return */ for (i = 0; i < 22; i++) istate[i] = 0; /*------------------------------------------------------------------------*/ /* Initialization of Parameters (for DLL functions) */ /*------------------------------------------------------------------------*/ PROTECT(Y = allocVector(REALSXP,(neq))); nprot++; if (Initfunc != NA_STRING) { if (inherits(Initfunc, "NativeSymbol")) { init_func_type *initializer; PROTECT(de_gparms = Parms); nprot++; initializer = (init_func_type *) R_ExternalPtrAddrFn_(Initfunc); initializer(Initdeparms); } } /* assign global variables of the event function */ n_eq = neq; R_envir = Rho; isForcing = initForcings(Flist); isEvent = initEvents(elist, eventfunc, 0); if (isEvent) interpolate = FALSE; /*------------------------------------------------------------------------*/ /* Initialization of Integration Loop */ /*------------------------------------------------------------------------*/ yout[0] = tt[0]; /* initial time */ yknots[0] = tt[0]; /* for polynomial interpolation */ for (i = 0; i < neq; i++) { y0[i] = xs[i]; /* initial values */ yout[(i + 1) * nt] = y0[i]; /* output array */ yknots[iknots + nknots * (i + 1)] = xs[i]; /* for polynomials */ } iknots++; t = tt[0]; tmax = fmax(tt[nt - 1], tcrit); dt = fmin(hmax, hini); hmax = fmin(hmax, tmax - t); /* Initialize work arrays (to be on the safe side, remove this later) */ for (i = 0; i < neq; i++) { y1[i] = 0; y2[i] = 0; Fj[i] = 0; for (j= 0; j < stage; j++) { FF[i + j * neq] = 0; } } /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ it = 1; /* step counter; zero element is initial state */ it_ext = 0; /* counter for external time step (dense output) */ it_tot = 0; /* total number of time steps */ it_rej = 0; if (interpolate) { /* integrate over the whole time step and interpolate internally */ rk_auto( fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, densetype, maxsteps, nt, &iknots, &it, &it_ext, &it_tot, &it_rej, istate, ipar, t, tmax, hmin, hmax, alpha, beta, &dt, &errold, tt, y0, y1, y2, dy1, dy2, f, y, Fj, tmp, FF, rr, A, out, bb1, bb2, cc, dd, atol, rtol, yknots, yout, Func, Parms, Rho ); } else { /* integrate separately between external time steps; do not interpolate */ for (int j = 0; j < nt - 1; j++) { t = tt[j]; tmax = fmin(tt[j + 1], tcrit); dt = tmax - t; if (isEvent) { updateevent(&t, y0, istate); } if (verbose) Rprintf("\n %d th time interval = %g ... %g", j, t, tmax); rk_auto( fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, densetype, maxsteps, nt, &iknots, &it, &it_ext, &it_tot, &it_rej, istate, ipar, t, tmax, hmin, hmax, alpha, beta, &dt, &errold, tt, y0, y1, y2, dy1, dy2, f, y, Fj, tmp, FF, rr, A, out, bb1, bb2, cc, dd, atol, rtol, yknots, yout, Func, Parms, Rho ); /* in this mode, internal interpolation is skipped, so we can simply store the results at the end of each call */ yout[j + 1] = tmax; for (i = 0; i < neq; i++) yout[j + 1 + nt * (1 + i)] = y2[i]; } } /*====================================================================*/ /* call derivs again to get global outputs */ /* j = -1 suppresses unnecessary internal copying */ /*====================================================================*/ if (nout > 0) { for (int j = 0; j < nt; j++) { t = yout[j]; for (i = 0; i < neq; i++) tmp[i] = yout[j + nt * (1 + i)]; derivs(Func, t, tmp, Parms, Rho, FF, out, -1, neq, ipar, isDll, isForcing); for (i = 0; i < nout; i++) { yout[j + nt * (1 + neq + i)] = out[i]; } } } /* attach diagnostic information (codes are compatible to lsoda) */ setIstate(R_yout, R_istate, istate, it_tot, stage, fsal, qerr, it_rej); if (densetype == 2) istate[12] = it_tot * stage + 2; /* number of function evaluations */ /* verbose printing in debugging mode*/ if (verbose) Rprintf("\nNumber of time steps it = %d, it_ext = %d, it_tot = %d it_rej %d\n", it, it_ext, it_tot, it_rej); /* release R resources */ timesteps[0] = 0; timesteps[1] = 0; UNPROTECT(nprot); return(R_yout); } deSolve/src/call_iteration.c0000644000176000001440000001577613274246367015665 0ustar ripleyusers/*==========================================================================*/ /* Fixed Step time stepping routine - NO Integration */ /*==========================================================================*/ #include "rk_util.h" #include "externalptr.h" SEXP call_iteration(SEXP Xstart, SEXP Times, SEXP Nsteps, SEXP Func, SEXP Initfunc, SEXP Parms, SEXP Nout, SEXP Rho, SEXP Verbose, SEXP Rpar, SEXP Ipar, SEXP Flist) { /* Initialization */ int nprot = 0; double *tt = NULL, *xs = NULL; double *ytmp, *out; SEXP R_y0, R_yout, R_t = NULL, R_y = NULL; SEXP Val, R_fcall; double *y0, *yout, *yy; double t, dt; int i = 0, j = 0, it = 0, nt = 0, nst = 0, neq = 0; int isForcing; C_deriv_func_type *cderivs = NULL; /*------------------------------------------------------------------------*/ /* Processing of Arguments */ /*------------------------------------------------------------------------*/ int nsteps = INTEGER(Nsteps)[0]; PROTECT(Times = AS_NUMERIC(Times)); nprot++; tt = NUMERIC_POINTER(Times); nt = length(Times); PROTECT(Xstart = AS_NUMERIC(Xstart)); nprot++; xs = NUMERIC_POINTER(Xstart); neq = length(Xstart); ytmp = (double *) R_alloc(neq, sizeof(double)); int nout = INTEGER(Nout)[0]; /* n of global outputs if func is in a DLL */ int verbose = INTEGER(Verbose)[0]; /*------------------------------------------------------------------------*/ /* timesteps (e.g. for advection computation in ReacTran) */ /*------------------------------------------------------------------------*/ for (i = 0; i < 2; i++) timesteps[i] = (tt[1] - tt[0])/nsteps; /*------------------------------------------------------------------------*/ /* DLL, ipar, rpar (for compatibility with lsoda) */ /*------------------------------------------------------------------------*/ int isDll = FALSE; int lrpar= 0, lipar = 0; int *ipar = NULL; if (inherits(Func, "NativeSymbol")) { /* function is a dll */ isDll = TRUE; if (nout > 0) isOut = TRUE; lrpar = nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ cderivs = (C_deriv_func_type *) R_ExternalPtrAddrFn_(Func); } else { /* function is not a dll */ isDll = FALSE; isOut = FALSE; lipar = 3; lrpar = nout; PROTECT(R_y = allocVector(REALSXP, neq)); nprot++; } out = (double *) R_alloc(lrpar, sizeof(double)); ipar = (int *) R_alloc(lipar, sizeof(int)); ipar[0] = nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; if (isDll == 1) { /* other elements of ipar are set in R-function via argument *ipar* */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* rpar is passed via "out"; first nout elements of out are reserved for output variables; other elements are set via argument rpar */ for (j = 0; j < nout; j++) out[j] = 0.0; for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j]; } /*------------------------------------------------------------------------*/ /* Allocation of Workspace */ /*------------------------------------------------------------------------*/ PROTECT(R_y0 = allocVector(REALSXP, neq)); nprot++; y0 = REAL(R_y0); /* matrix for holding the outputs */ PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); nprot++; yout = REAL(R_yout); /* attribute that stores state information, similar to lsoda */ SEXP R_istate; int *istate; PROTECT(R_istate = allocVector(INTSXP, 22)); nprot++; istate = INTEGER(R_istate); istate[0] = 0; /* assume succesful return */ for (i = 0; i < 22; i++) istate[i] = 0; /*------------------------------------------------------------------------*/ /* Initialization of Parameters (for DLL functions) */ /*------------------------------------------------------------------------*/ if (Initfunc != NA_STRING) { if (inherits(Initfunc, "NativeSymbol")) { init_func_type *initializer; PROTECT(de_gparms = Parms); nprot++; initializer = (init_func_type *) R_ExternalPtrAddrFn_(Initfunc); initializer(Initdeparms); } } isForcing = initForcings(Flist); /*------------------------------------------------------------------------*/ /* Initialization of Loop */ /*------------------------------------------------------------------------*/ yout[0] = tt[0]; /* initial time */ for (i = 0; i < neq; i++) { y0[i] = xs[i]; yout[(i + 1) * nt] = y0[i]; } /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ t = tt[0]; for (it = 0; it < nt; it++) { if (it < nt - 1) dt = (tt[it + 1] - t)/nsteps; else dt = 0; /* dt after final time is undefined*/ timesteps[0] = timesteps[1]; timesteps[1] = dt; if (verbose) Rprintf("Time steps = %d / %d time = %e\n", it + 1, nt, t); if (it == (nt - 1)) nsteps = 1; /* to make sure last step is saved */ for (nst = 0; nst < nsteps; nst++) { if (nst == 0) { yout[it] = t; for (i = 0; i < neq; i++) yout[it + nt * (1 + i)] = y0[i]; } if (isDll) { if (isForcing) updatedeforc(&t); cderivs(&neq, &t, y0, ytmp, out, ipar); for (i = 0; i < neq; i++) y0[i] = ytmp[i]; } else { /* the following PROTECTs are considered local and will quickly be removed thereafter */ yy = REAL(R_y); PROTECT(R_t = ScalarReal(t)); /* i1 */ for (i = 0; i < neq; i++) yy[i] = y0[i]; PROTECT(R_fcall = lang4(Func, R_t, R_y, Parms)); /* i2 */ PROTECT(Val = eval(R_fcall, Rho)); /* i3 */ for (i = 0; i < neq; i++) y0[i] = REAL(VECTOR_ELT(Val, 0))[i]; /* extract outputs from second and following list elements */ if (nst == (nsteps - 1)) { int elt = 1, ii = 0, l; for (i = 0; i < nout; i++) { l = LENGTH(VECTOR_ELT(Val, elt)); if (ii == l) { ii = 0; elt++; } out[i] = REAL(VECTOR_ELT(Val, elt))[ii]; ii++; } } UNPROTECT(3); } /* isDLL*/ t = t + dt; if (nst == 0) for (i = 0; i < nout; i++) yout[it + nt * (1 + neq + i)] = out[i]; } /* nsteps*/ } /* end of main loop */ /* attach essential internal information (codes are compatible to lsoda) */ setIstate(R_yout, R_istate, istate, it, 1, 0, 1, 0); /* reset timesteps pointer to saved state, release R resources */ timesteps[0] = 0; timesteps[1] = 0; UNPROTECT(nprot); return(R_yout); } deSolve/src/call_rkImplicit.c0000644000176000001440000002401113274246447015753 0ustar ripleyusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >=2 */ /* RK Solver for implicit methods with fixed step size */ /* (experimental code derived by K.S.) */ /*==========================================================================*/ #include "rk_util.h" #include "externalptr.h" SEXP call_rkImplicit(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc, SEXP Parms, SEXP eventfunc, SEXP elist, SEXP Nout, SEXP Rho, SEXP Tcrit, SEXP Verbose, SEXP Hini, SEXP Rpar, SEXP Ipar, SEXP Method, SEXP Maxsteps, SEXP Flist) { /** Initialization **/ int nprot = 0; double *tt = NULL, *xs = NULL; double *y, *f, *Fj, *tmp, *tmp2, *tmp3, *FF, *rr; SEXP R_yout; double *y0, *y1, *dy1, *out, *yout; double t, dt, tmax; int fsal = FALSE; /* fixed step methods have no FSAL */ int interpolate = TRUE; /* polynomial interpolation is done by default */ int i = 0, j=0, it=0, it_tot=0, it_ext=0, nt = 0, neq=0; int isForcing, isEvent; double *alpha; int *index; /**************************************************************************/ /****** Processing of Arguments ******/ /**************************************************************************/ double tcrit = REAL(Tcrit)[0]; double hini = REAL(Hini)[0]; int maxsteps = INTEGER(Maxsteps)[0]; int nout = INTEGER(Nout)[0]; /* number of global outputs if func is in a DLL */ int verbose = INTEGER(Verbose)[0]; int stage = (int)REAL(getListElement(Method, "stage"))[0]; SEXP R_A, R_B1, R_C; double *A, *bb1, *cc=NULL; PROTECT(R_A = getListElement(Method, "A")); nprot++; A = REAL(R_A); PROTECT(R_B1 = getListElement(Method, "b1")); nprot++; bb1 = REAL(R_B1); PROTECT(R_C = getListElement(Method, "c")); nprot++; if (length(R_C)) cc = REAL(R_C); double qerr = REAL(getListElement(Method, "Qerr"))[0]; PROTECT(Times = AS_NUMERIC(Times)); nprot++; tt = NUMERIC_POINTER(Times); nt = length(Times); PROTECT(Xstart = AS_NUMERIC(Xstart)); nprot++; xs = NUMERIC_POINTER(Xstart); neq = length(Xstart); /*------------------------------------------------------------------------*/ /* timesteps (for advection computation in ReacTran) */ /*------------------------------------------------------------------------*/ for (i = 0; i < 2; i++) timesteps[i] = 0; /**************************************************************************/ /****** DLL, ipar, rpar (to be compatible with lsoda) ******/ /**************************************************************************/ int isDll = FALSE; int lrpar= 0, lipar = 0; int *ipar = NULL; if (inherits(Func, "NativeSymbol")) { /* function is a dll */ isDll = TRUE; if (nout > 0) isOut = TRUE; lrpar = nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ isDll = FALSE; isOut = FALSE; lipar = 3; /* in lsoda = 1 */ lrpar = nout; /* in lsoda = 1 */ } out = (double *) R_alloc(lrpar, sizeof(double)); ipar = (int *) R_alloc(lipar, sizeof(int)); ipar[0] = nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; if (isDll == 1) { /* other elements of ipar are set in R-function lsodx via argument *ipar* */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* out: first nout elements of out are reserved for output variables other elements are set via argument *rpar* */ for (j = 0; j < nout; j++) out[j] = 0.0; for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j]; } /*------------------------------------------------------------------------*/ /* Allocation of Workspace */ /*------------------------------------------------------------------------*/ y0 = (double *) R_alloc(neq, sizeof(double)); y1 = (double *) R_alloc(neq, sizeof(double)); dy1 = (double *) R_alloc(neq, sizeof(double)); f = (double *) R_alloc(neq, sizeof(double)); y = (double *) R_alloc(neq, sizeof(double)); Fj = (double *) R_alloc(neq, sizeof(double)); FF = (double *) R_alloc(neq * stage, sizeof(double)); rr = (double *) R_alloc(neq * 5, sizeof(double)); /* ks */ alpha = (double *) R_alloc(neq * stage * neq * stage, sizeof(double)); index = (int *) R_alloc(neq * stage, sizeof(int)); tmp = (double *) R_alloc(neq * stage, sizeof(double)); tmp2 = (double *) R_alloc(neq * stage, sizeof(double)); tmp3 = (double *) R_alloc(neq * stage, sizeof(double)); /* matrix for polynomial interpolation */ SEXP R_nknots; int nknots = 6; /* 6 = 5th order polynomials by default*/ int iknots = 0; /* counter for knots buffer */ double *yknots; PROTECT(R_nknots = getListElement(Method, "nknots")); nprot++; if (length(R_nknots)) nknots = INTEGER(R_nknots)[0] + 1; if (nknots < 2) {nknots=1; interpolate = FALSE;} yknots = (double *) R_alloc((neq + 1) * (nknots + 1), sizeof(double)); /* matrix for holding states and global outputs */ PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); nprot++; yout = REAL(R_yout); /* initialize outputs with NA first */ for (i = 0; i < nt * (neq + nout + 1); i++) yout[i] = NA_REAL; /* attribute that stores state information, similar to lsoda */ SEXP R_istate; int *istate; PROTECT(R_istate = allocVector(INTSXP, 22)); nprot++; istate = INTEGER(R_istate); istate[0] = 0; /* assume succesful return */ for (i = 0; i < 22; i++) istate[i] = 0; /*------------------------------------------------------------------------*/ /* Initialization of Parameters (for DLL functions) */ /*------------------------------------------------------------------------*/ PROTECT(Y = allocVector(REALSXP,(neq))); nprot++; if (Initfunc != NA_STRING) { if (inherits(Initfunc, "NativeSymbol")) { init_func_type *initializer; PROTECT(de_gparms = Parms); nprot++; initializer = (init_func_type *) R_ExternalPtrAddrFn_(Initfunc); initializer(Initdeparms); } } /* assign global variables of the event function */ n_eq = neq; R_envir = Rho; isForcing = initForcings(Flist); isEvent = initEvents(elist, eventfunc,0); if (isEvent) interpolate = FALSE; /*------------------------------------------------------------------------*/ /* Initialization of Integration Loop */ /*------------------------------------------------------------------------*/ yout[0] = tt[0]; /* initial time */ yknots[0] = tt[0]; /* for polynomial interpolation */ for (i = 0; i < neq; i++) { y0[i] = xs[i]; /* initial values */ yout[(i + 1) * nt] = y0[i]; /* output array */ yknots[iknots + nknots * (i + 1)] = xs[i]; /* for polynomials */ } iknots++; t = tt[0]; tmax = fmax(tt[nt - 1], tcrit); /* Initialization of work arrays (to be on the safe side, remove this later) */ for (i = 0; i < neq; i++) { y1[i] = 0; Fj[i] = 0; for (j= 0; j < stage; j++) { FF[i + j * neq] = 0; } } /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ it = 1; /* step counter; zero element is initial state */ it_ext = 0; /* counter for external time step (dense output) */ it_tot = 0; /* total number of time steps */ if (interpolate) { /* integrate over the whole time step and interpolate internally */ rk_implicit( alpha, index, fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, maxsteps, nt, &iknots, &it, &it_ext, &it_tot, istate, ipar, t, tmax, hini, &dt, tt, y0, y1, dy1, f, y, Fj, tmp, tmp2, tmp3, FF, rr, A, out, bb1, cc, yknots, yout, Func, Parms, Rho ); } else { for (int j = 0; j < nt - 1; j++) { t = tt[j]; tmax = fmin(tt[j + 1], tcrit); dt = tmax - t; if (isEvent) { updateevent(&t, y0, istate); } rk_implicit(alpha, index, fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, maxsteps, nt, &iknots, &it, &it_ext, &it_tot, istate, ipar, t, tmax, hini, &dt, tt, y0, y1, dy1, f, y, Fj, tmp, tmp2, tmp3, FF, rr, A, out, bb1, cc, yknots, yout, Func, Parms, Rho ); /* in this mode, internal interpolation is skipped, so we can simply store the results at the end of each call */ yout[j + 1] = tmax; for (i = 0; i < neq; i++) yout[j + 1 + nt * (1 + i)] = y1[i]; } } /*====================================================================*/ /* call derivs again to get global outputs */ /* j = -1 suppresses unnecessary internal copying */ /*====================================================================*/ if(nout > 0) { for (int j = 0; j < nt; j++) { t = yout[j]; for (i = 0; i < neq; i++) tmp[i] = yout[j + nt * (1 + i)]; derivs(Func, t, tmp, Parms, Rho, FF, out, -1, neq, ipar, isDll, isForcing); for (i = 0; i < nout; i++) { yout[j + nt * (1 + neq + i)] = out[i]; } } } /* attach diagnostic information (codes are compatible to lsoda) */ setIstate(R_yout, R_istate, istate, it_tot, stage, fsal, qerr, 0); /* release R resources */ if (verbose) { Rprintf("Number of time steps it = %d, it_ext = %d, it_tot = %d\n", it, it_ext, it_tot); Rprintf("Maxsteps %d\n", maxsteps); } /* release R resources */ timesteps[0] = 0; timesteps[1] = 0; UNPROTECT(nprot); return(R_yout); } deSolve/vignettes/0000755000176000001440000000000013576731651013731 5ustar ripleyusersdeSolve/vignettes/mymod.c0000644000176000001440000000200113136461014015174 0ustar ripleyusers/* file mymod.c */ #include static double parms[3]; #define k1 parms[0] #define k2 parms[1] #define k3 parms[2] /* initializer */ void initmod(void (* odeparms)(int *, double *)) { int N=3; odeparms(&N, parms); } /* Derivatives and 1 output variable */ void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] <1) error("nout should be at least 1"); ydot[0] = -k1*y[0] + k2*y[1]*y[2]; ydot[2] = k3 * y[1]*y[1]; ydot[1] = -ydot[0]-ydot[2]; yout[0] = y[0]+y[1]+y[2]; } /* The Jacobian matrix */ void jac(int *neq, double *t, double *y, int *ml, int *mu, double *pd, int *nrowpd, double *yout, int *ip) { pd[0] = -k1; pd[1] = k1; pd[2] = 0.0; pd[(*nrowpd)] = k2*y[2]; pd[(*nrowpd) + 1] = -k2*y[2] - 2*k3*y[1]; pd[(*nrowpd) + 2] = 2*k3*y[1]; pd[(*nrowpd)*2] = k2*y[1]; pd[2*(*nrowpd) + 1] = -k2 * y[1]; pd[2*(*nrowpd) + 2] = 0.0; } /* END file mymod.c */ deSolve/vignettes/mymod.f0000644000176000001440000000221213136461014015203 0ustar ripleyusersc file mymodf.f subroutine initmod(odeparms) external odeparms double precision parms(3) common /myparms/parms call odeparms(3, parms) return end subroutine derivs (neq, t, y, ydot, yout, ip) double precision t, y, ydot, k1, k2, k3 integer neq, ip(*) dimension y(3), ydot(3), yout(*) common /myparms/k1,k2,k3 if(ip(1) < 1) call rexit("nout should be at least 1") ydot(1) = -k1*y(1) + k2*y(2)*y(3) ydot(3) = k3*y(2)*y(2) ydot(2) = -ydot(1) - ydot(3) yout(1) = y(1) + y(2) + y(3) return end subroutine jac (neq, t, y, ml, mu, pd, nrowpd, yout, ip) integer neq, ml, mu, nrowpd, ip double precision y(*), pd(nrowpd,*), yout(*), t, k1, k2, k3 common /myparms/k1, k2, k3 pd(1,1) = -k1 pd(2,1) = k1 pd(3,1) = 0.0 pd(1,2) = k2*y(3) pd(2,2) = -k2*y(3) - 2*k3*y(2) pd(3,2) = 2*k3*y(2) pd(1,3) = k2*y(2) pd(2,3) = -k2*y(2) pd(3,3) = 0.0 return end c end of file mymodf.f deSolve/vignettes/comp-event.pdf0000644000176000001440000004606413136461014016474 0ustar ripleyusers%PDF-1.4 % 1 0 obj << /Pages 3 0 R /Type /Catalog >> endobj 2 0 obj << /CreationDate (D:20091121151502) /Creator (R) /ModDate (D:20091121151502) /Producer (R 2.7.2) /Title (R Graphics Output) >> endobj 3 0 obj << /Count 1 /Kids [ 4 0 R ] /MediaBox [ 0 0 503 503 ] /Type /Pages >> endobj 4 0 obj << /Contents 5 0 R /Parent 3 0 R /Resources 6 0 R /Type /Page >> endobj 5 0 obj << /Length 18042 /Filter /FlateDecode >> stream x}K.9wռ;/o{ $$$ 1# 4R"$>^]NBNwAsVUO^w/믾.}W>嫎]_?٫|_׿/_9}+`,ھ j{5k>^C>`]^ [*8}༝]d]q:[#{F~G30ݖྜྷW\xh=Ksi>:y;[?;"=`G%y wo~y>مQT} {;=WݷvsGX럪^ֱ-&\[^QsNX7ot_$ otܝoo[ M]oޢ .}!(o;Fo48, h]xGe%YV.NE3waG#Ň|~af Y|_sTkpw ~¹f԰%9 6&GAX|8VOƒ!ޱ uTÝA}F!;"KR A}{c.UԇPA}VխsfBpT~߄S_Tpat`<˥ ԇYgn>>®^8؆`wW BP]Gխ[A}SpoP "( RAq+oO A}F8.ݏIV}P=$} x\38>|.[[KBP(gKwa`g.\ @M \nBwW5BP}nӴp0 O/܍b+ppl\Aa;2ܕqK}A X/fbg>ʭR7ps7Pp¦}? ̡΃q9k AU_Z_/x2ÅKBBFpD \X|/X`SܺpH!1^b.)껃=eE`ot!oy[.92ugPI呤>:.Ǭ_&̹0g'΋$6.oMMo/A}J ) )5!oBR A}I_hRB!OԷ]"m1& kl9HcNqBȓkOId I}Er!oԷGR';v|HЧ踵k$@|VPY[jj3b}Pdҭ*^tԮ׿pAHᆐC ͨwnX"(8/D=5)LR LBJ}pKᬻR_޹S+.GBb&^4=;^v᥾ъ݅vnCkG'{V)3z pץq)G^3; p-K}hRkSkѺ׬\FŝW7c,I}Kr(1f†_К!]mQC'Sy!ɫF!{ѵ/P_ƨR. ^x?K-Ƙ=?39V-55;Ξ͋]1ܘxh3 ;s\ lU;80سـR<ndj<>`fښ_ɏ}h 4Q kb "2OLx]H L zz^ 9xkm0T4#L-z{]S8 >M 0p^ >֖' ^ AR0\!Ubv[ZA͸vqmd;DKȮ˘e L!rzʳs<||*ދ;}7V٤D27uOǗƿӻ ?T;ԲvT1+=Sд!u$i ]lﷰr˄Q>-!9 x{<C~olh\ V޿_O3S+WQpl֦14d`4Wzk]&!Q|ZR^xh}_!4 aCrq#y$%Q|)O/K~|z|uG"1tzL>S|Zs|~Qɧіtx=ŧF? Ol`i=N{|\ 0pړ?1jFbi&g>pп~ߒOK&6ی7gCNi.|Z-NG~|ziC S!6ÀO-z|Z~H>N ɋC> O$<Ыzߣҁܘu x?xi|z,wo6Hb靏%C'R-i?oI>|ηN+q.|ziߋ{}i!{o˟sN4_^L>ԷS+4*}l7鷒o:|:i/6p|zߠ/aOyToY h /Ǩ"$_xz0 H߉l'2, %ۛi8hOSMͧZShSc鳞=>ԧ'?MV.SgA7#CL7Y˴^]?XoI>#Ǜ-Qȧ_Sӫ/"ӑɧ⃋'OKOGo.^? ~&>2n 7]6IԆx%EibynYS g=\[B1)Nha0xH_>[C,ӖU~S!Z#':->q>J/aL|Z%Ӌ|y?iIr=b)bL{zxi??i=.>uCC|,]ܴ=S[~wJT|hOGO"yVwRoci8Ⱦ2i2{w,$F~b<4cg<7C<=Bzɉ>[lnis| bqOA!y| V<0Z_-E|'/ퟓ7xi>*^LEO~ ylѯyC*φߒgzGOmɷjjb˧5>KS_J/TG̈́ hxf;ԧ庥}O{ߓIb%wSw𲾓O{'>ŧ|W7&?aTךL>/iMilևsɭe0ӕOO>OpR~,@}R/>[A5ڲ'[|swʿ3ۧS_EGL|䊪-OL>}OewT5_?()J@%ߐ?" i/ {OjӞ ":W~>s'!TK¨cL>MTwUB4Zo=+y0hH27=o$=ay"JBál'HBEf/4>~z>~Ň?UCO(uq~{w~%{´G|+ %}GA>i@+oCo-א?3XQެC n%CgU/b+"t{QpcwnAWc}|#v4aߕWD^Mc'n'l5?*>mGQUɧ^&ywUa7sC ?jy} KWb"GM{B̿x?L6c=-"qS=R2pA1EK'T.. f@ 7#'[ް[駈2)xphz+}'Dh7H^r4-T(-wxӒ}E参֋c[ ADkiGm{bl/)[3O|#ԣ 洿PUI}#T銸\5&yfx.G!778~GՑ;ŧ)j?̐{+d|),ɧOGreܴF!{mDk:!{Cڀ1?3>UL>-9G?-_j ܯq}_w< Ob7`OmogP+%?$il/]KI<5?Gy<|Z/*}oOp/;\{|ҶqQøk<|^ci_V쏲:1D`ʧkd[򬿯Qim}vqxe<,x#Tʒ=A.Ɣ5dxw>Rf6Wȗi?m!M㧍[ttb&pSBWCl6݈Dzo~_(<;$aA?xպyov˧=24vA~j I>-3wRMQS`\m/.K*}nvY|]j]ДL&gLL?V_Yv0tmwI${:$!W~ __m_O㫾?'К_Y_O]K׍yvퟺdբ ͟~q p=1%7v~*2OG{p?퇁~z =݆#3݈LE/}"L3 pbz6#A3y`WӸ0~|e?ҭ |ԟa/ #MiFh3FhQ5Iz%oG7nB30RA3LnR`afG~2#9l;e2Cuœf3phʬHoN</|1FZhqt{Z`$giOdb^dFFr[j^W<70h`v'߁JͰO[WGchm ~La}KF|?RzeT6S#liOA=`lG=)1%4(䯏n 9gD/NrtŻ#{%F!Å"3x(~%f|Hlf~ԻaeM{ׯs(>1xؾpMn| ǐM30rj40az,KTTà#}>t6W>8:PF= c[5jBc >]jqW%r>TC$XlӚ?HwsbH9 *9 j6>(R2xwƣ8q!nE1v9g#ݔUJz2t * ZMsnJ[m[gɌ6=ei-q_v?f Oì~ޛҠ͐]A ҠF}c-YSԘ2v#H iu34(iL+u*tW|˓kb=@HS-jڎjp7FL3Puvg,V=WW}\Օ5WWpbӕ5r?r;TH~?4av|w1dP~4ۘn!qFaQx(LdopěٕO@7ڕU/{ SyCKv.FL>2T%_סum+isY`ȧ-U.6KCUZ4(oW^<\ve!kKʧ=X!f0"OӘuOt1|fu2vq+!I mC8LOl!1WCv]wZ0SElzr"1`ȧp+C`|c`o3}I]*pS:7g]O*raL#QU T;т0t8xxE.J< F؀5gx|ݨ41p$Y|*>z7`}I|:f >#CFΧw#T1s<EqO o'nߌn(SS5*>*^:xU}Ui*7r=LeI3`9*7S_L4fc2 !1t>G6{El=a-lޏujsUR[Cw6J|8Jg:J}uT!/\F|Nku[ǜ?iPЏ0nÞSZ]6oחJ!O,R4 ZpY`v0tϯyiSKEN}?*Sټc<0 e l*j6>-a}_RG^^*wꚃO `qY$^[hAi@,9b445Oi XhtO|aj+Er_OzR*A˘uEUכN{N5i >mΖS0 bDZ?J$N~*:M{d ɧ. %_~C2Đ|C˲)yL5((LSnz?ɳxO`YLɧ>d~S˼abW2Eylc;O.CߏiPVYjO3}oB|hy=B1?U4噐?j\[5NS^Aa>b bq$L76#4!c#t[ |ɧN#|XU!~әӖ?j럛=f >͢܈Ue;+Wc"Nj >t|g&6$/o*^=쟨[_Ge^`VOya5Ua9=6)b=Qmfc%דO4(<=ŧ.GAE'>S|0J`Oӿ叚ioK|mTC:[ K^Q''Y_sBOlC.-Z/'vߵvo5\6f %>>5v3 s5f <mFclҌԍ?_4TU?x82>ٟQ#IOQ#ՇũOQl?^_QY_9LZZ@Gi{ˑ?j:igY7Z>{*G7e?^]ϩ5A!ylg;<0 b_7vg?TϟZ)AQJmO2 nkcgKI{,_^全|||?ai=L|?:Kd|?bJ5׃O#g~Ek:ӂb4x~~e(oXri14h T2gyJ|M/ۇ*s}/R&=g~#5b-:8g=?`|:]ևe/ES33}_%d;S+XF|zHhY-lg6^iLao씧GnJØS1.{_2,u.~ (M}tcO0~Z|?;go*Ğ[vб/(OQqqjO9Kg懾W?j[|>ǫ:[[>iZS>oi`o.t0cuDZƔO͗̿hivy}䏚N+g}H)|.{m7Q%z^f:dOIm˜SۗXRpt:Sw/G3^=Z e/~#Դ?qTx{OQ!>zsOwQe XL֌oO OTyȐ[1}H\%|`cʫOa($/[MJ&}$oH"}?_?jiwP=Gg~c}+̧Fe?*5i?&_Q0p=>]|ZyzğO[>zj]|K'y1%G??l_|S.꿌ۏWa}6eOhG>mK +ϳħ.z]v=?ֳ<`*9|:S TZ.5H@/; 'i1 F02ۗrm[_WB3q6?O6z0w{Gv0Q3;14\iKH^GLéyQ_~bioVVCz~z߫qxDhK9`o?o7aw8&V30fGzePM'CJԀ5F0=ao} N;e=g/)PO70Ng1U_otcG7GW@OS?"%}@Os?G͙gH>Y 4| fɧo|*>3SQXxIT - ߕ~+OK|s@>$aF?/H7n#!zWO]=%U=G-2sccNQQ8:x|Mk2ǵw岋cSK|Z~0j9K>i>ϐ+3ocwl-%>[W'eO(֜GMǟj?%yWĶJG|cg}XG=UdM~^GM n_qH_MlWVM>*7yU=O[j)Q+<,&_߭&>]oѹ qS~!}gTxu>~(kOOLMu(>r!pSQKqQmO?ju`r>.qbL¿DK')Sƭ~KCyԜy}*t}>Q3k>'>ij5zd>3~ aY WŋhߢOG SwTiڣCx/`ci}Q ~Gushr| 0*{乻^H[=E2WadOG{0aag\G0T? ''LOW, (dcvr =m'oA3Cǡ!éOL g{P#*S %S %\4Vr(y!z((yTTDǯwJ?5Po#MQ?JYfP?).J/;V!W$~EwKL=t%4~y?X]1M: >YGO>P럨I?PBh'D0LvLzS&Ir¡ A + bS3f1g4\uqwElQŬun|{~I>IJpE|8\b1 :\FV|nTٓBb ɰv.#WNx[nO̵ۙ&IT#_: Bk0觪,Tsk1 ţCps15OmxɪV uoj= 7:;&]͸զ'wȕ̈́`C}^4)Dt0aU Lxrfԅ&;_9SALXԛnkGxN GޙҸot ʚMO:prڂζv-76xRPS ;f<'3.?ΫͬIqR#-xplwt+&L .5QLUjx;_fG@oJ 7]$87[fwlfkOcI@87],?/DZ~0(lc6<ܝ˰jn GA<} ajӅXfDATf~al֮gD6Aȝ0#˭][gKDr I=*,\ XD X`!QM ULkA}a^Ӏr9$('AP_}giHs<I}\g=;-@3gf̾A}͞ ̚?=#k>3 kS;衊ZC[. Wa#O߂>ŁMAP_V?З\ 1l8(%׌~[*t*(qKۋ sq2w̓41Fn 5o+syrd5` Of-wyBPT*j A{ O H ;m;` EGJ;gϑ2hi v;'Al_ J>r1 I9rLgQs:"Lg pZOCtYS)ڨ[1$42|Zmbf{Hy?cEp$&))C|HކԱ w{hnSkPܦ❱Mɧ|*YT1YT$KUg`ʣSjH \ۻ]*@K~I*WEw_tzS 쇒g:=*5sAY+.$Og+OV"5s7b 閊ە*(әlo:jOWaDYC`9(hdfd<T3wq?u2Znu*rN"FbEU4հeL7WReT. *yI=,}mciq a{v3J^ZR}Q:e >hR,viMZE1)6sb p|m~) kG߃&x8vv6T,>_L@˞PӞKErj֢*fh= 2z O{=88>!>-FO&b&> "O~^ӌ r3[|fTL>ɧqO{'{ħydhv04cQ`U%{aeC]eXdVWΧ)gPW%BrO*2UsQ~UDMdiUAr Ew T14&'},|DgO:0H{d.OG|D3~l\F9qV;0qbQ-UIX3ͧ;'v7v)_QuI?r%>#'] ɧL>E"#1t44+GAj0pqC}7/&4H)Þm=H>MHY/xJi|?.g'UZCD1]HK >m^$H>YeZ_$0,>xUEhӬ >vV%SL,T#*kעK*eXx%CKiO^r*^d_* v{?}ɱSZe>o/2ʰCKyF͒{i>5kЫ\]r1fF`:O?/|| @:`i zX5M6U%qיޒiN%.0 ywK~&yv1֖+姽um98 >]#Ö;.yM_ΧMGMBȨ߶QsXT)6.c\/=a{=t,!.>M{bG)fd;gMq0-O}V m/ۇ/_7 f1Tۄ0tRizO3KmԫlI[7 FF{9_eMŦ04"ߗR\F|:)\a >->;*c >-i$vuOK˛Q03_(%C>Swك}CG<|g#|ڗÍfcaiO"Bj{-H͑?jy?ſ'T}V$T[-9jۍq}UE_~G5k(~gs;^Jע[6)tgCX{^OZFA72n L|GWl!L|_5?f0<8_P`V%ǣg<>]qhx,׮kU|ŷ51 >'Qq`c9թx,Miu*˵^Mod>2t=kk֬\o&Z.o y*r-φ@&6Ye+0taZ۲PԬ\e?Z͸~tڔ|@doُfښb >KGo^DxG<.OUkC J˿*?6 |mU:I !fÏv6OGT]mag`a DLеUVCG\Q {~FU+A_\E 2w|\QPC)Nw?-]O~l.lNީ> ~&C =2ڿ2e@,XˋˁPvRev οe̢UֳĿ٪S?endstream endobj 6 0 obj << /ExtGState << >> /Font << /F1 7 0 R /F2 8 0 R /F3 9 0 R >> /ProcSet [ /PDF /Text ] >> endobj 7 0 obj << /BaseFont /ZapfDingbats /Name /F1 /Subtype /Type1 /Type /Font >> endobj 8 0 obj << /BaseFont /Helvetica /Encoding 10 0 R /Name /F2 /Subtype /Type1 /Type /Font >> endobj 9 0 obj << /BaseFont /Helvetica-Bold /Encoding 10 0 R /Name /F3 /Subtype /Type1 /Type /Font >> endobj 10 0 obj << /BaseEncoding /WinAnsiEncoding /Differences [ 45 /minus 96 /quoteleft 144 /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron /space ] /Type /Encoding >> endobj xref 0 11 0000000000 65535 f 0000000015 00000 n 0000000064 00000 n 0000000206 00000 n 0000000291 00000 n 0000000371 00000 n 0000018486 00000 n 0000018590 00000 n 0000018673 00000 n 0000018770 00000 n 0000018872 00000 n trailer << /Info 2 0 R /Root 1 0 R /Size 11 /ID [<49a3146a7b3decb7d7e60691fd6bd377><49a3146a7b3decb7d7e60691fd6bd377>] >> startxref 19134 %%EOF deSolve/vignettes/.install_extras0000644000176000001440000000001013136461014016736 0ustar ripleyusersmymod.* deSolve/vignettes/compiledCode.Rnw0000644000176000001440000017231713136461014017004 0ustar ripleyusers\documentclass[article,nojss]{jss} \DeclareGraphicsExtensions{.pdf,.eps} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Add-on packages and fonts \usepackage{amsmath} \usepackage{xspace} \usepackage{verbatim} \usepackage[english]{babel} %\usepackage{mathptmx} %\usepackage{helvet} \usepackage[T1]{fontenc} \usepackage[latin1]{inputenc} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% User specified LaTeX commands. \newcommand{\Rmodels}{\textbf{\textsf{R models}}\xspace} \newcommand{\DLLmodels}{\textbf{\textsf{DLL models}}\xspace} \title{\proglang{R} Package \pkg{deSolve}, Writing Code in Compiled Languages} \Plaintitle{R Package deSolve, Writing Code in Compiled Languages} \Keywords{differential equation solvers, compiled code, performance, \proglang{FORTRAN}, \proglang{C}} \Plainkeywords{differential equation solvers, compiled code, performance, FORTRAN, C} \author{ Karline Soetaert\\ Royal Netherlands Institute\\ of Sea Research (NIOZ)\\ Yerseke\\ The Netherlands \And Thomas Petzoldt\\ Technische Universit\"at \\ Dresden\\ Germany \And R. Woodrow Setzer\\ National Center for\\ Computational Toxicology\\ US Environmental Protection Agency } \Plainauthor{Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer} \Abstract{This document describes how to use the \pkg{deSolve} package \citep{deSolve_jss} to solve models that are written in \proglang{FORTRAN} or \proglang{C}.} %% The address of (at least) one author should be given %% in the following format: \Address{ Karline Soetaert\\ Royal Netherlands Institute of Sea Research (NIOZ)\\ 4401 NT Yerseke, Netherlands \\ E-mail: \email{karline.soetaert@nioz.nl}\\ URL: \url{http://www.nioz.nl}\\ \\ Thomas Petzoldt\\ Institut f\"ur Hydrobiologie\\ Technische Universit\"at Dresden\\ 01062 Dresden, Germany\\ E-mail: \email{thomas.petzoldt@tu-dresden.de}\\ URL: \url{http://tu-dresden.de/Members/thomas.petzoldt/}\\ \\ R. Woodrow Setzer\\ National Center for Computational Toxicology\\ US Environmental Protection Agency\\ URL: \url{http://www.epa.gov/comptox} } %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% R/Sweave specific LaTeX commands. %% need no \usepackage{Sweave} %\VignetteIndexEntry{R Package deSolve: Writing Code in Compiled Languages} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Begin of the document \begin{document} \SweaveOpts{engine=R,eps=FALSE} <>= library("deSolve") options(prompt = "R> ") options(width=70) @ \maketitle \section{Introduction} \pkg{deSolve} \citep{deSolve_jss,deSolve}, the successor of \proglang{R} package \pkg{odesolve} \citep{Setzer01} is a package to solve ordinary differential equations (ODE), differential algebraic equations (DAE) and partial differential equations (PDE). One of the prominent features of \pkg{deSolve} is that it allows specifying the differential equations either as: \begin{itemize} \item pure \proglang{R} code \citep{Rcore}, \item functions defined in lower-level languages such as \proglang{FORTRAN}, \proglang{C}, or \proglang{C++}, which are compiled into a dynamically linked library (DLL) and loaded into \proglang{R}. \end{itemize} In what follows, these implementations will be referred to as \Rmodels and \DLLmodels respectively. Whereas \Rmodels are easy to implement, they allow simple interactive development, produce highly readible code and access to \proglang{R}s high-level procedures, \DLLmodels have the benefit of increased simulation speed. Depending on the problem, there may be a gain of up to several orders of magnitude computing time when using compiled code. Here are some rules of thumb when it is worthwhile or not to switch to \DLLmodels: \begin{itemize} \item As long as one makes use only of \proglang{R}s high-level commands, the time gain will be modest. This was demonstrated in \citet{deSolve_jss}, where a formulation of two interacting populations dispersing on a 1-dimensional or a 2-dimensional grid led to a time gain of a factor two only when using \DLLmodels. \item Generally, the more statements in the model, the higher will be the gain of using compiled code. Thus, in the same paper \citep{deSolve_jss}, a very simple, 0-D, Lotka-Volterrra type of model describing only 2 state variables was solved 50 times faster when using compiled code. \item As even \Rmodels are quite performant, the time gain induced by compiled code will often not be discernible when the model is only solved once (who can grasp the difference between a run taking 0.001 or 0.05 seconds to finish). However, if the model is to be applied multiple times, e.g. because the model is to be fitted to data, or its sensitivity is to be tested, then it may be worthwhile to implement the model in a compiled language. \end{itemize} Starting from \pkg{deSolve} version 1.4, it is now also possible to use \emph{forcing functions} in compiled code. These forcing functions are automatically updated by the integrators. See last chapter. \section{A simple ODE example} Assume the following simple ODE (which is from the \code{LSODA} source code): \begin{align*} \frac{{dy_1}}{{dt}} &= - k_1 \cdot y_1 + k_2 \cdot y_2 \cdot y_3 \\ \frac{{dy_2}}{{dt}} &= k_1 \cdot y_1 - k_2 \cdot y_2 \cdot y_3 - k_3 \cdot y_2 \cdot y_2 \\ \frac{{dy_3}}{{dt}} &= k_3 \cdot y_2 \cdot y_2 \\ \end{align*} where $y_1$, $y_2$ and $y_3$ are state variables, and $k_1$, $k_2$ and $k_3$ are parameters. We first implement and run this model in pure \proglang{R}, then show how to do this in \proglang{C} and in \proglang{FORTRAN}. \subsection{ODE model implementation in R} An ODE model implemented in \textbf{pure \proglang{R}} should be defined as: \begin{verbatim} yprime = func(t, y, parms, ...) \end{verbatim} where \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system, and \code{parms} is a vector or list containing the parameter values. The optional dots argument (\code{\dots}) can be used to pass any other arguments to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to time, and whose next elements contain output variables that are required at each point in time. The \proglang{R} implementation of the simple ODE is given below: <>= model <- function(t, Y, parameters) { with (as.list(parameters),{ dy1 = -k1*Y[1] + k2*Y[2]*Y[3] dy3 = k3*Y[2]*Y[2] dy2 = -dy1 - dy3 list(c(dy1, dy2, dy3)) }) } @ The Jacobian ($\frac{{\partial y'}}{{\partial y}}$) associated to the above example is: <>= jac <- function (t, Y, parameters) { with (as.list(parameters),{ PD[1,1] <- -k1 PD[1,2] <- k2*Y[3] PD[1,3] <- k2*Y[2] PD[2,1] <- k1 PD[2,3] <- -PD[1,3] PD[3,2] <- k3*Y[2] PD[2,2] <- -PD[1,2] - PD[3,2] return(PD) }) } @ This model can then be run as follows: <>= parms <- c(k1 = 0.04, k2 = 1e4, k3=3e7) Y <- c(1.0, 0.0, 0.0) times <- c(0, 0.4*10^(0:11)) PD <- matrix(nrow = 3, ncol = 3, data = 0) out <- ode(Y, times, model, parms = parms, jacfunc = jac) @ \subsection{ODE model implementation in C} \label{sec:Cexamp} In order to create compiled models (.DLL = dynamic link libraries on Windows or .so = shared objects on other systems) you must have a recent version of the GNU compiler suite installed, which is quite standard for Linux. Windows users find all the required tools on \url{http://www.murdoch-sutherland.com/Rtools/}. Getting DLLs produced by other compilers to communicate with R is much more complicated and therefore not recommended. More details can be found on \url{http://cran.r-project.org/doc/manuals/R-admin.html}. The call to the derivative and Jacobian function is more complex for compiled code compared to \proglang{R}-code, because it has to comply with the interface needed by the integrator source codes. Below is an implementation of this model in \proglang{C}: \verbatiminput{mymod.c} The implementation in \proglang{C} consists of three parts: \begin{enumerate} \item After defining the parameters in global \proglang{C}-variables, through the use of \code{\#define} statements, a function called \code{initmod} initialises the parameter values, passed from the \proglang{R}-code. This function has as its sole argument a pointer to \proglang{C}-function \code{odeparms} that fills a double array with double precision values, to copy the parameter values into the global variable. \item Function \code{derivs} then calculates the values of the derivatives. The derivative function is defined as: \begin{verbatim} void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) \end{verbatim} where \code{*neq} is the number of equations, \code{*t} is the value of the independent variable, \code{*y} points to a double precision array of length \code{*neq} that contains the current value of the state variables, and \code{*ydot} points to an array that will contain the calculated derivatives. \code{*yout} points to a double precision vector whose first \code{nout} values are other output variables (different from the state variables \code{y}), and the next values are double precision values as passed by parameter \code{rpar} when calling the integrator. The key to the elements of \code{*yout} is set in \code{*ip} \code{*ip} points to an integer vector whose length is at least 3; the first element (\code{ip[0]}) contains the number of output values (which should be equal or larger than \code{nout}), its second element contains the length of \code{*yout}, and the third element contains the length of \code{*ip}; next are integer values, as passed by parameter \code{ipar} when calling the integrator.\footnote{Readers familiar with the source code of the \pkg{ODEPACK} solvers may be surprised to find the double precision vector \code{yout} and the integer vector \code{ip} at the end. Indeed none of the \pkg{ODEPACK} functions allow this, although it is standard in the \code{vode} and \code{daspk} codes. To make all integrators compatible, we have altered the \pkg{ODEPACK} \proglang{FORTRAN} codes to consistently pass these vectors.} Note that, in function \code{derivs}, we start by checking whether enough memory is allocated for the output variables (\code{if (ip[0] < 1)}), else an error is passed to \proglang{R} and the integration is stopped. \item In \proglang{C}, the call to the function that generates the Jacobian is as: \begin{verbatim} void jac(int *neq, double *t, double *y, int *ml, int *mu, double *pd, int *nrowpd, double *yout, int *ip) \end{verbatim} where \code{*ml} and \code{*mu} are the number of non-zero bands below and above the diagonal of the Jacobian respectively. These integers are only relevant if the option of a banded Jacobian is selected. \code{*nrow} contains the number of rows of the Jacobian. Only for full Jacobian matrices, is this equal to \code{*neq}. In case the Jacobian is banded, the size of \code{*nrowpd} depends on the integrator. If the method is one of \code{lsode, lsoda, vode}, then \code{*nrowpd} will be equal to \code{*mu + 2 * *ml + 1}, where the last \code{*ml} rows should be filled with $0$s. For \code{radau}, \code{*nrowpd} will be equal to \code{*mu + *ml + 1} See example ``odeband'' in the directory \url{doc/examples/dynload}, and chapter \ref{band}. \end{enumerate} \subsection{ODE model implementation in FORTRAN} \label{sec:forexamp} Models may also be defined in \proglang{FORTRAN}. \verbatiminput{mymod.f} In \proglang{FORTRAN}, parameters may be stored in a common block (here called \code{myparms}). During the initialisation, this common block is defined to consist of a 3-valued vector (unnamed), but in the subroutines \code{derivs} and \code{jac}, the parameters are given a name (\code{k1}, ...). \subsection{Running ODE models implemented in compiled code} To run the models described above, the code in \code{mymod.f} and \code{mymod.c} must first be compiled\footnote{This requires a correctly installed GNU compiler, see above.}. This can simply be done in \proglang{R} itself, using the \code{system} command: <>= system("R CMD SHLIB mymod.f") @ for the \proglang{FORTRAN} code or <>= system("R CMD SHLIB mymod.c") @ for the \proglang{C} code. This will create file \code{mymod.dll} on windows, or \code{mymod.so} on other platforms. We load the DLL, in windows as: \begin{verbatim} dyn.load("mymod.dll") \end{verbatim} and in unix: \begin{verbatim} dyn.load("mymod.so") \end{verbatim} or, using a general statement: \begin{verbatim} dyn.load(paste("mymod", .Platform$dynlib.ext, sep = "")) \end{verbatim} The model can now be run as follows: \begin{verbatim} parms <- c(k1 = 0.04, k2 = 1e4, k3=3e7) Y <- c(y1 = 1.0, y2 = 0.0, y3 = 0.0) times <- c(0, 0.4*10^(0:11) ) out <- ode(Y, times, func = "derivs", parms = parms, jacfunc = "jac", dllname = "mymod", initfunc = "initmod", nout = 1, outnames = "Sum") \end{verbatim} The integration routine (here \code{ode}) recognizes that the model is specified as a DLL due to the fact that arguments \code{func} and \code{jacfunc} are not regular \proglang{R}-functions but character strings. Thus, the integrator will check whether the function is loaded in the DLL with name \code{mymod}. Note that \code{mymod}, as specified by \code{dllname} gives the name of the shared library \emph{without extension}. This DLL should contain all the compiled function or subroutine definitions referred to in \code{func}, \code{jacfunc} and \code{initfunc}. Also, if \code{func} is specified in compiled code, then \code{jacfunc} and \code{initfunc} (if present) should also be specified in a compiled language. It is not allowed to mix \proglang{R}-functions and compiled functions. Note also that, when invoking the integrator, we have to specify the number of ordinary output variables, \code{nout}. This is because the integration routine has to allocate memory to pass these output variables back to \proglang{R}. There is no way to check for the number of output variables in a DLL automatically. If in the calling of the integration routine the number of output variables is too low, then \proglang{R} may freeze and need to be terminated! Therefore it is advised that one checks in the code whether \code{nout} has been specified correctly. In the \proglang{FORTRAN} example above, the statement \code{if (ip(1) < 1) call rexit("nout should be at least 1")} does this. Note that it is not an error (just a waste of memory) to set \code{nout} to a too large value. Finally, in order to label the output matrix, the names of the ordinary output variables have to be passed explicitly (\code{outnames}). This is not necessary for the state variables, as their names are known through their initial condition (\code{y}). \section{Alternative way of passing parameters and data in compiled code} \label{sec:parms} All of the solvers in \pkg{deSolve} take an argument \code{parms} which may be an arbitrary \proglang{R} object. In models defined in \proglang{R} code, this argument is passed unprocessed to the various functions that make up the model. It is possible, as well, to pass such R-objects to models defined in native code. The problem is that data passed to, say, \code{ode} in the argument \code{parms} is not visible by default to the routines that define the model. This is handled by a user-written initialization function, for example \code{initmod} in the \proglang{C} and \proglang{FORTRAN} examples from sections \ref{sec:Cexamp} and \ref{sec:forexamp}. However, these set only the \emph{values} of the parameters. R-objects have many attributes that may also be of interest. To have access to these, we need to do more work, and this mode of passing parameters and data is much more complex than what we saw in previous chapters. In \proglang{C}, the initialization routine is declared: \begin{verbatim} void initmod(void (* odeparms)(int *, double *)); \end{verbatim} That is, \code{initmod} has a single argument, a pointer to a function that has as arguments a pointer to an \texttt{int} and a pointer to a \texttt{double}. In \proglang{FORTRAN}, the initialization routine has a single argument, a subroutine declared to be external. The name of the initialization function is passed as an argument to the \pkg{deSolve} solver functions. In \proglang{C}, two approaches are available for making the values passed in \code{parms} visible to the model routines, while only the simpler approach is available in \proglang{FORTRAN}. The simpler requires that \code{parms} be a numeric vector. In \proglang{C}, the function passed from \pkg{deSolve} to the initialization function (called \code{odeparms} in the example) copies the values from the parameter vector to a static array declared globally in the file where the model is defined. In \proglang{FORTRAN}, the values are copied into a \code{COMMON} block. It is possible to pass more complicated structures to \proglang{C} functions. Here is an example, an initializer called \code{deltamethrin} from a model describing the pharmacokinetics of that pesticide: \begin{verbatim} #include #include #include #include "deltamethrin.h" /* initializer */ void deltamethrin(void(* odeparms)(int *, double *)) { int Nparms; DL_FUNC get_deSolve_gparms; SEXP gparms; get_deSolve_gparms = R_GetCCallable("deSolve","get_deSolve_gparms"); gparms = get_deSolve_gparms(); Nparms = LENGTH(gparms); if (Nparms != N_PARMS) { PROBLEM "Confusion over the length of parms" ERROR; } else { _RDy_deltamethrin_parms = REAL(gparms); } } \end{verbatim} In \texttt{deltamethrin.h}, the variable \code{\_RDy\_deltamethrin\_parms} and macro N\_PARMS are declared: \begin{verbatim} #define N_PARMS 63 static double *_RDy_deltamethrin_parms; \end{verbatim} The critical element of this method is the function \code{R\_GetCCallable} which returns a function (called \code{get\_deSolve\_gparms} in this implementation) that returns the parms argument as a \code{SEXP} data type. In this example, \code{parms} was just a real vector, but in principle, this method can handle arbitrarily complex objects. For more detail on handling \proglang{R} objects in native code, see \proglang{R} Development Core Team (2008). \section{deSolve integrators that support DLL models} In the most recent version of \pkg{deSolve} all integration routines can solve \DLLmodels. They are: \begin{itemize} \item all solvers of the \code{lsode} familiy: \code{lsoda}, \code{lsode}, \code{lsodar}, \code {lsodes}, \item \code{vode}, \code{zvode}, \item \code{daspk}, \item \code{radau}, \item the Runge-Kutta integration routines (including the Euler method). \end{itemize} For some of these solvers the interface is slightly different (e.g. \code{zvode, daspk}), while in others (\code{lsodar}, \code{lsodes}) different functions can be defined. How this is implemented in a compiled language is discussed next. \subsection{Complex numbers, function zvode} \code{zvode} solves ODEs that are composed of complex variables. The program below uses \code{zvode} to solve the following system of 2 ODEs: \begin{align*} \frac{{dz}}{{dt}} &= i \cdot z\\ \frac{{dw}}{{dt}} &= -i \cdot w \cdot w \cdot z\\ \end{align*} where \begin{align*} w(0) = 1/2.1 +0i\\ z(0) = 1i \end{align*} on the interval t = [0, 2 $\pi$] The example is implemented in \proglang{FORTRAN}% \footnote{this can be found in file "zvodedll.f", in the dynload subdirectory of the package}, \code{FEX} implements the function \code{func}: \begin{verbatim} SUBROUTINE FEX (NEQ, T, Y, YDOT, RPAR, IPAR) INTEGER NEQ, IPAR(*) DOUBLE COMPLEX Y(NEQ), YDOT(NEQ), RPAR(*), CMP DOUBLE PRECISION T character(len=100) msg c the imaginary unit i CMP = DCMPLX(0.0D0,1.0D0) YDOT(1) = CMP*Y(1) YDOT(2) = -CMP*Y(2)*Y(2)*Y(1) RETURN END \end{verbatim} \code{JEX} implements the function \code{jacfunc} \begin{verbatim} SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD, RPAR, IPAR) INTEGER NEQ, ML, MU, NRPD, IPAR(*) DOUBLE COMPLEX Y(NEQ), PD(NRPD,NEQ), RPAR(*), CMP DOUBLE PRECISION T c the imaginary unit i CMP = DCMPLX(0.0D0,1.0D0) PD(2,3) = -2.0D0*CMP*Y(1)*Y(2) PD(2,1) = -CMP*Y(2)*Y(2) PD(1,1) = CMP RETURN END \end{verbatim} Assuming this code has been compiled and is in a DLL called "zvodedll.dll", this model is solved in R as follows: \begin{verbatim} dyn.load("zvodedll.dll") outF <- zvode(func = "fex", jacfunc = "jex", y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10, dllname = "zvodedll", initfunc = NULL) \end{verbatim} Note that in \proglang{R} names of \proglang{FORTRAN} DLL functions (e.g. for \code{func} and \code{jacfunc}) have to be given in lowercase letters, even if they are defined upper case in \proglang{FORTRAN}. Also, there is no initialiser function here (\code{initfunc = NULL}). \subsection{DAE models, integrator daspk} \code{daspk} is one of the integrators in the package that solve DAE models. In order to be used with DASPK, DAEs are specified in implicit form: \[0 = F(t, y, y', p)\] i.e. the DAE function (passed via argument \code{res}) specifies the ``residuals'' rather than the derivatives (as for ODEs). Consequently the DAE function specification in a compiled language is also different. For code written in \proglang{C}, the calling sequence for \code{res} must be: \begin{verbatim} void myres(double *t, double *y, double *ydot, double *cj, double *delta, int *ires, double *yout, int *ip) \end{verbatim} where \code{*t} is the value of the independent variable, \code{*y} points to a double precision vector that contains the current value of the state variables, \code{*ydot} points to an array that will contain the derivatives, \code{*delta} points to a vector that will contain the calculated residuals. \code{*cj} points to a scalar, which is normally proportional to the inverse of the stepsize, while \code{*ires} points to an integer (not used). \code{*yout} points to any other output variables (different from the state variables y), followed by the double precision values as passed via argument \code{rpar}; finally \code{*ip} is an integer vector containing at least 3 elements, its first value (\code{*ip[0]}) equals the number of output variables, calculated in the function (and which should be equal to \code{nout}), its second element equals the total length of \code{*yout}, its third element equals the total length of \code{*ip}, and finally come the integer values as passed via argument \code{ipar}. For code written in \proglang{FORTRAN}, the calling sequence for \code{res} must be as in the following example: \begin{verbatim} subroutine myresf(t, y, ydot, cj, delta, ires, out, ip) integer :: ires, ip(*) integer, parameter :: neq = 3 double precision :: t, y(neq), ydot(neq), delta(neq), out(*) double precision :: K, ka, r, prod, ra, rb common /myparms/K,ka,r,prod if(ip(1) < 1) call rexit("nout should be at least 1") ra = ka* y(3) rb = ka/K *y(1) * y(2) !! residuals of rates of changes delta(3) = -ydot(3) - ra + rb + prod delta(1) = -ydot(1) + ra - rb delta(2) = -ydot(2) + ra - rb - r*y(2) out(1) = y(1) + y(2) + y(3) return end \end{verbatim} Similarly as for the ODE model discussed above, the parameters are kept in a common block which is initialised by an initialiser subroutine: \begin{verbatim} subroutine initpar(daspkparms) external daspkparms integer, parameter :: N = 4 double precision parms(N) common /myparms/parms call daspkparms(N, parms) return end \end{verbatim} See the ODE example for how to initialise parameter values in \proglang{C}. Similarly, the function that specifies the Jacobian in a DAE differs from the Jacobian when the model is an ODE. The DAE Jacobian is set with argument \code{jacres} rather than \code{jacfunc} when an ODE. For code written in \proglang{FORTRAN}, the \code{jacres} must be as: \begin{verbatim} subroutine resjacfor (t, y, dy, pd, cj, out, ipar) integer, parameter :: neq = 3 integer :: ipar(*) double precision :: K, ka, r, prod double precision :: pd(neq,neq),y(neq),dy(neq),out(*) common /myparms/K,ka,r,prod !res1 = -dD - ka*D + ka/K *A*B + prod PD(1,1) = ka/K *y(2) PD(1,2) = ka/K *y(1) PD(1,3) = -ka -cj !res2 = -dA + ka*D - ka/K *A*B PD(2,1) = -ka/K *y(2) -cj PD(2,2) = -ka/K *y(2) PD(2,3) = ka !res3 = -dB + ka*D - ka/K *A*B - r*B PD(3,1) = -ka/K *y(2) PD(3,2) = -ka/K *y(2) -r -cj PD(3,3) = ka return end \end{verbatim} \subsection{DAE models, integrator radau} Function \code{radau} solves DAEs in linearly implicit form, i.e. in the form $M y' = f(t, y, p)$. The derivative function $f$ is specified in the same way as for an ODE, i.e. \begin{verbatim} void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) \end{verbatim} and \begin{verbatim} subroutine derivs (neq, t, y, ydot, out, IP) \end{verbatim} for \proglang{C} and \proglang{FORTRAN} code respectively. To show how it should be used, we implement the caraxis problem as in \citep{testset}. The implementation of this index 3 DAE, comprising 8 differential, and 2 algebraic equations in R is the last example of the \code{radau} help page. We first repeat the R implementation: <<>>= caraxisfun <- function(t, y, parms) { with(as.list(c(y, parms)), { yb <- r * sin(w * t) xb <- sqrt(L * L - yb * yb) Ll <- sqrt(xl^2 + yl^2) Lr <- sqrt((xr - xb)^2 + (yr - yb)^2) dxl <- ul; dyl <- vl; dxr <- ur; dyr <- vr dul <- (L0-Ll) * xl/Ll + 2 * lam2 * (xl-xr) + lam1*xb dvl <- (L0-Ll) * yl/Ll + 2 * lam2 * (yl-yr) + lam1*yb - k * g dur <- (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr) dvr <- (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k * g c1 <- xb * xl + yb * yl c2 <- (xl - xr)^2 + (yl - yr)^2 - L * L list(c(dxl, dyl, dxr, dyr, dul, dvl, dur, dvr, c1, c2)) }) } eps <- 0.01; M <- 10; k <- M * eps^2/2; L <- 1; L0 <- 0.5; r <- 0.1; w <- 10; g <- 1 parameter <- c(eps = eps, M = M, k = k, L = L, L0 = L0, r = r, w = w, g = g) yini <- c(xl = 0, yl = L0, xr = L, yr = L0, ul = -L0/L, vl = 0, ur = -L0/L, vr = 0, lam1 = 0, lam2 = 0) # the mass matrix Mass <- diag(nrow = 10, 1) Mass[5,5] <- Mass[6,6] <- Mass[7,7] <- Mass[8,8] <- M * eps * eps/2 Mass[9,9] <- Mass[10,10] <- 0 Mass # index of the variables: 4 of index 1, 4 of index 2, 2 of index 3 index <- c(4, 4, 2) times <- seq(0, 3, by = 0.01) out <- radau(y = yini, mass = Mass, times = times, func = caraxisfun, parms = parameter, nind = index) @ <>= plot(out, which = 1:4, type = "l", lwd = 2) @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the caraxis model - see text for R-code} \label{fig:caraxis} \end{figure} The implementation in \proglang{FORTRAN} consists of an initialiser function and a derivative function. \begin{verbatim} c---------------------------------------------------------------- c Initialiser for parameter common block c---------------------------------------------------------------- subroutine initcaraxis(daeparms) external daeparms integer, parameter :: N = 8 double precision parms(N) common /myparms/parms call daeparms(N, parms) return end c---------------------------------------------------------------- c rate of change c---------------------------------------------------------------- subroutine caraxis(neq, t, y, ydot, out, ip) implicit none integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*) double precision eps, M, k, L, L0, r, w, g common /myparms/ eps, M, k, L, L0, r, w, g double precision xl, yl, xr, yr, ul, vl, ur, vr, lam1, lam2 double precision yb, xb, Ll, Lr, dxl, dyl, dxr, dyr double precision dul, dvl, dur, dvr, c1, c2 c expand state variables xl = y(1) yl = y(2) xr = y(3) yr = y(4) ul = y(5) vl = y(6) ur = y(7) vr = y(8) lam1 = y(9) lam2 = y(10) yb = r * sin(w * t) xb = sqrt(L * L - yb * yb) Ll = sqrt(xl**2 + yl**2) Lr = sqrt((xr - xb)**2 + (yr - yb)**2) dxl = ul dyl = vl dxr = ur dyr = vr dul = (L0-Ll) * xl/Ll + 2 * lam2 * (xl-xr) + lam1*xb dvl = (L0-Ll) * yl/Ll + 2 * lam2 * (yl-yr) + lam1*yb - k*g dur = (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr) dvr = (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k*g c1 = xb * xl + yb * yl c2 = (xl - xr)**2 + (yl - yr)**2 - L * L c function values in ydot ydot(1) = dxl ydot(2) = dyl ydot(3) = dxr ydot(4) = dyr ydot(5) = dul ydot(6) = dvl ydot(7) = dur ydot(8) = dvr ydot(9) = c1 ydot(10) = c2 return end \end{verbatim} Assuming that the code is in file ``radaudae.f'', this model is compiled, loaded and solved in R as: \begin{verbatim} system("R CMD SHLIB radaudae.f") dyn.load(paste("radaudae", .Platform$dynlib.ext, sep = "")) outDLL <- radau(y = yini, mass = Mass, times = times, func = "caraxis", initfunc = "initcaraxis", parms = parameter, dllname = "radaudae", nind = index) dyn.unload(paste("radaudae", .Platform$dynlib.ext, sep = "")) \end{verbatim} \subsection{The root function from integrators lsodar and lsode} \code{lsodar} is an extended version of integrator \code{lsoda} that includes a root finding function. This function is spedified via argument \code{rootfunc}. In \code{deSolve} version 1.7, \code{lsode} has also been extended with root finding capabilities. Here is how to program such a function in a lower-level language. For code written in \proglang{C}, the calling sequence for \code{rootfunc} must be: \begin{verbatim} void myroot(int *neq, double *t, double *y, int *ng, double *gout, double *out, int *ip ) \end{verbatim} where \code{*neq} and \code{*ng} are the number of state variables and root functions respectively, \code{*t} is the value of the independent variable, \code{y} points to a double precision array that contains the current value of the state variables, and \code{gout} points to an array that will contain the values of the constraint function whose root is sought. \code{*out} and \code{*ip} are a double precision and integer vector respectively, as described in the ODE example above. For code written in \proglang{FORTRAN}, the calling sequence for \code{rootfunc} must be as in following example: \begin{verbatim} subroutine myroot(neq, t, y, ng, gout, out, ip) integer :: neq, ng, ip(*) double precision :: t, y(neq), gout(ng), out(*) gout(1) = y(1) - 1.e-4 gout(2) = y(3) - 1e-2 return end \end{verbatim} \subsection{jacvec, the Jacobian vector for integrator lsodes} Finally, in integration function \code{lsodes}, not the Jacobian \emph{matrix} is specified, but a \emph{vector}, one for each column of the Jacobian. This function is specified via argument \code{jacvec}. In \proglang{FORTRAN}, the calling sequence for \code{jacvec} is: \begin{verbatim} SUBROUTINE JAC (NEQ, T, Y, J, IAN, JAN, PDJ, OUT, IP) DOUBLE PRECISION T, Y(*), IAN(*), JAN(*), PDJ(*), OUT(*) INTEGER NEQ, J, IP(*) \end{verbatim} \subsection{Banded jacobians in compiled code}\label{band} In the call of the jacobian function, the number of bands below and above the diagonal (\code{ml, mu}) and the number of rows of the Jacobian matrix, \code{nrowPD} is specified, e.g. for \proglang{FORTRAN} code: \begin{verbatim} SUBROUTINE JAC (neq, T, Y, ml, mu, PD, nrowPD, RPAR, IPAR) \end{verbatim} The jacobian matrix to be returned should have dimension \code{nrowPD, neq}. In case the Jacobian is banded, the size of \code{nrowPD} depends on the integrator. If the method is one of \code{lsode, lsoda, vode}, or related, then \code{nrowPD} will be equal to \code{mu + 2 * ml + 1}, where the last ml rows should be filled with $0$s. For \code{radau}, \code{nrowpd} will be equal to \code{mu + ml + 1} Thus, it is important to write the FORTRAN or C-code in such a way that it can be used with both types of integrators - else it is likely that R will freeze if the wrong integrator is used. We implement in FORTRAN, the example of the \code{lsode} help file. The R-code reads: <<>>= ## the model, 5 state variables f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } ## the Jacobian, written in banded form bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } ## initial conditions and output times yini <- 1:5 times <- 1:20 ## stiff method, user-generated banded Jacobian out <- lsode(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) @ In FORTRAN, the code might look like this: \begin{verbatim} c Rate of change subroutine derivsband (neq, t, y, ydot,out,IP) integer neq, IP(*) DOUBLE PRECISION T, Y(5), YDOT(5), out(*) ydot(1) = 0.1*y(1) -0.2*y(2) ydot(2) = -0.3*y(1) +0.1*y(2) -0.2*y(3) ydot(3) = -0.3*y(2) +0.1*y(3) -0.2*y(4) ydot(4) = -0.3*y(3) +0.1*y(4) -0.2*y(5) ydot(5) = -0.3*y(4) +0.1*y(5) RETURN END c The banded jacobian subroutine jacband (neq, t, y, ml, mu, pd, nrowpd, RP, IP) INTEGER neq, ml, mu, nrowpd, ip(*) DOUBLE PRECISION T, Y(5), PD(nrowpd,5), rp(*) PD(:,:) = 0.D0 PD(1,1) = 0.D0 PD(1,2) = -.02D0 PD(1,3) = -.02D0 PD(1,4) = -.02D0 PD(1,5) = -.02D0 PD(2,:) = 0.1D0 PD(3,1) = -0.3D0 PD(3,2) = -0.3D0 PD(3,3) = -0.3D0 PD(3,4) = -0.3D0 PD(3,5) = 0.D0 RETURN END \end{verbatim} Assuming that this code is in file \code{"odeband.f"}, we compile from within R and load the shared library (assuming the working directory holds the source file) with: \begin{verbatim} system("R CMD SHLIB odeband.f") dyn.load(paste("odeband", .Platform$dynlib.ext, sep = "")) \end{verbatim} To solve this problem, we write in R \begin{verbatim} out2 <- lsode(yini, times, "derivsband", parms = 0, jactype = "bandusr", jacfunc = "jacband", bandup = 1, banddown = 1, dllname = "odeband") out2 <- radau(yini, times, "derivsband", parms = 0, jactype = "bandusr", jacfunc = "jacband", bandup = 1, banddown = 1, dllname = "odeband") \end{verbatim} This will work both for the \code{lsode} family as for \code{radau}. In the first case, when entering subroutine \code{jacband}, \code{nrowpd} will have the value $5$, in the second case, it will be equal to $4$. \section{Testing functions written in compiled code} Two utilities have been included to test the function implementation in compiled code: \begin{itemize} \item \code{DLLfunc} to test the implementation of the derivative function as used in ODEs. This function returns the derivative $\frac{dy}{dt}$ and the output variables. \item \code{DLLres} to test the implementation of the residual function as used in DAEs. This function returns the residual function $\frac{dy}{dt}-f(y,t)$ and the output variables. \end{itemize} These functions serve no other purpose than to test whether the compiled code returns what it should. \subsection{DLLfunc} We test whether the ccl4 model, which is part of \code{deSolve} package, returns the proper rates of changes. (Note: see \code{example(ccl4model)} for a more comprehensive implementation) <<>>= ## Parameter values and initial conditions Parms <- c(0.182, 4.0, 4.0, 0.08, 0.04, 0.74, 0.05, 0.15, 0.32, 16.17, 281.48, 13.3, 16.17, 5.487, 153.8, 0.04321671, 0.4027255, 1000, 0.02, 1.0, 3.8) yini <- c( AI=21, AAM=0, AT=0, AF=0, AL=0, CLT=0, AM=0 ) ## the rate of change DLLfunc(y = yini, dllname = "deSolve", func = "derivsccl4", initfunc = "initccl4", parms = Parms, times = 1, nout = 3, outnames = c("DOSE", "MASS", "CP") ) @ \subsection{DLLres} The deSolve package contains a FORTRAN implementation of the chemical model described above (section 4.1), where the production rate is included as a forcing function (see next section). Here we use \code{DLLres} to test it: <<>>= pars <- c(K = 1, ka = 1e6, r = 1) ## Initial conc; D is in equilibrium with A,B y <- c(A = 2, B = 3, D = 2*3/pars["K"]) ## Initial rate of change dy <- c(dA = 0, dB = 0, dD = 0) ## production increases with time prod <- matrix(nc=2,data=c(seq(0,100,by=10),seq(0.1,0.5,len=11))) DLLres(y=y,dy=dy,times=5,res="chemres", dllname="deSolve", initfunc="initparms", initforc="initforcs", parms=pars, forcings=prod, nout=2, outnames=c("CONC","Prod")) @ \section{Using forcing functions} Forcing functions in DLLs are implemented in a similar way as parameters. This means: \begin{itemize} \item They are initialised by means of an initialiser function. Its name should be passed to the solver via argument \code{initforc}. Similar as the parameter initialiser function, the function denoted by \code{initforc} has as its sole argument a pointer to the vector that contains the forcing funcion values in the compiled code. In case of \proglang{C} code, this will be a global vector; in case of \proglang{FORTRAN}, this will be a vector in a common block. The solver puts a pointer to this vector and updates the forcing functions in this memory area at each time step. Hence, within the compiled code, forcing functions can be assessed as if they are parameters (although, in contrast to the latter, their values will generally change). No need to update the values for the current time step; this has been done before entering the \code{derivs} function. \item The forcing function data series are passed to the integrator, via argument \code{forcings}; if there is only one forcing function data set, then a 2-columned matrix (time, value) will do; else the data should be passed as a list, containing (time, value) matrices with the individual forcing function data sets. Note that the data sets in this list should be \emph{in the same ordering} as the declaration of the forcings in the compiled code. \end{itemize} A number of options allow to finetune certain settings. They are in a list called \code{fcontrol} which can be supplied as argument when calling the solvers. The options are similar to the arguments from R function \code{approx}, howevers the default settings are often different. The following options can be specified: \begin{itemize} \item \code{method} specifies the interpolation method to be used. Choices are "linear" or "constant", the default is "linear", which means linear interpolation (same as \code{approx}) \item \code{rule}, an integer describing how interpolation is to take place \emph{outside} the interval [min(times), max(times)]. If \code{rule} is \code{1} then an error will be triggered and the calculation will stop if extrapolation is necessary. If it is \code{2}, the default, the value at the closest data extreme is used, a warning will be printed if \code{verbose} is TRUE. Note that the default differs from the \code{approx} default. \item \code{f}, for method=\code{"constant"} is a number between \code{0} and \code{1} inclusive, indicating a compromise between left- and right-continuous step functions. If \code{y0} and \code{y1} are the values to the left and right of the point then the value is \code{y0*(1-f)+y1*f} so that \code{f=0} is right-continuous and \code{f=1} is left-continuous. The default is to have \code{f=0}. For some data sets it may be more realistic to set \code{f=0.5}. \item \code{ties}, the handling of tied \code{times} values. Either a function with a single vector argument returning a single number result or the string "ordered". Note that the default is "ordered", hence the existence of ties will NOT be investigated; in practice this means that, if ties exist, the first value will be used; if the dataset is not ordered, then nonsense will be produced. Alternative values for \code{ties} are \code{mean}, \code{min} etc... which will average, or take the minimal value if multiple values exist at one time level. \end{itemize} The default settings of \code{fcontrol} are: \code{fcontrol=list(method="linear", rule = 2, f = 0, ties = "ordered")} Note that only ONE specification is allowed, even if there is more than one forcing function data set. (may/should change in the future). \subsection{A simple FORTRAN example} We implement the example from chapter 3 of the book \citep{Soetaert08} in FORTRAN. This model describes the oxygen consumption of a (marine) sediment in response to deposition of organic matter (the forcing function). One state variable, the organic matter content in the sediment is modeled; it changes as a function of the deposition \code{Flux} (forcing) and organic matter decay (first-order decay rate \code{k}). \[ \frac{dC}{dt}=Flux_t-k \cdot C \] with initial condition $C(t=0)=C_0$; the latter is estimated as the mean of the flux divided by the decay rate. The FORTRAN code looks like this: \begin{verbatim} c Initialiser for parameter common block subroutine scocpar(odeparms) external odeparms integer N double precision parms(2) common /myparms/parms N = 1 call odeparms(N, parms) return end c Initialiser for forcing common block subroutine scocforc(odeforcs) external odeforcs integer N double precision forcs(1) common /myforcs/forcs N = 1 call odeforcs(N, forcs) return end c Rate of change and output variables subroutine scocder (neq, t, y, ydot,out,IP) integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*), k, depo common /myparms/k common /myforcs/depo if(IP(1) < 2) call rexit("nout should be at least 2") ydot(1) = -k*y(1) + depo out(1)= k*y(1) out(2)= depo return end \end{verbatim} Here the subroutine \code{scocpar} is business as usual; it initialises the parameter common block (there is only one parameter). Subroutine \code{odeforcs} does the same for the forcing function, which is also positioned in a common block, called \code{myforcs}. This common block is made available in the derivative subroutine (here called \code{scocder}), where the forcing function is named \code{depo}. At each time step, the integrator updates the value of this forcing function to the correct time point. In this way, the forcing functions can be used as if they are (time-varying) parameters. All that's left to do is to pass the forcing function data set and the name of the forcing function initialiser routine. This is how to do it in R. First the data are inputted: <<>>= Flux <- matrix(ncol=2,byrow=TRUE,data=c( 1, 0.654, 11, 0.167, 21, 0.060, 41, 0.070, 73,0.277, 83,0.186, 93,0.140,103, 0.255, 113, 0.231,123, 0.309,133,1.127,143,1.923, 153,1.091,163,1.001, 173, 1.691,183, 1.404,194,1.226,204,0.767, 214, 0.893,224,0.737, 234,0.772,244, 0.726,254,0.624,264,0.439, 274,0.168,284 ,0.280, 294,0.202,304, 0.193,315,0.286,325,0.599, 335, 1.889,345, 0.996,355,0.681,365,1.135)) head(Flux) @ and the parameter given a value (there is only one) <<>>= parms <- 0.01 @ The initial condition \code{Yini} is estimated as the annual mean of the Flux and divided by the decay rate (parameter). <<>>= meanDepo <- mean(approx(Flux[,1],Flux[,2], xout=seq(1,365,by=1))$y) Yini <- c(y=meanDepo/parms) @ After defining the output times, the model is run, using integration routine \code{ode}. The \emph{name} of the derivate function \code{"scocder"}, of the dll \code{"deSolve"}\footnote{this example is made part of the deSolve package, hence the name of the dll is "deSolve"} and of the initialiser function \code{"scocpar"} are passed, as in previous examples. In addition, the forcing function data set is also passed (\code{forcings=Flux}) as is the name of the forcing initialisation function (\code{initforc="scocforc"}). <<>>= times <- 1:365 out <- ode(y=Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc="scocforc", forcings=Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation","Depo")) head(out) @ Now, the way the forcing functions are interpolated are changed: Rather than linear interpolation, constant (block, step) interpolation is used. <<>>= fcontrol <- list(method="constant") out2 <- ode(y=Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc="scocforc", forcings=Flux, fcontrol=fcontrol, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation","Depo")) @ Finally, the results are plotted: <>= par (mfrow=c(1,2)) plot(out, which = "Depo", col="red", xlab="days", ylab="mmol C/m2/ d", main="method='linear'") lines(out[,"time"], out[,"Mineralisation"], lwd=2, col="blue") legend("topleft",lwd=1:2,col=c("red","blue"), c("Flux","Mineralisation")) plot(out, which = "Depo", col="red", xlab="days", ylab="mmol C/m2/ d", main="method='constant'") lines(out2[,"time"], out2[,"Mineralisation"], lwd=2, col="blue") @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the SCOC model, implemented in compiled code, and including a forcing function - see text for R-code} \label{fig:scoc} \end{figure} \subsection{An example in C} Consider the following R-code which implements a resource-producer-consumer Lotka-Volterra type of model in R (it is a modified version of the example of function \code{ode}): <<>>= SPCmod <- function(t, x, parms, input) { with(as.list(c(parms, x)), { import <- input(t) dS <- import - b*S*P + g*C # substrate dP <- c*S*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dS, dP, dC) list(res, signal = import) }) } ## The parameters parms <- c(b = 0.1, c = 0.1, d = 0.1, e = 0.1, f = 0.1, g = 0.0) ## vector of timesteps times <- seq(0, 100, by=0.1) ## external signal with several rectangle impulses signal <- as.data.frame(list(times = times, import = rep(0, length(times)))) signal$import <- ifelse((trunc(signal$times) %% 2 == 0), 0, 1) sigimp <- approxfun(signal$times, signal$import, rule = 2) ## Start values for steady state xstart <- c(S = 1, P = 1, C = 1) ## Solve model print (system.time( out <- ode(y = xstart,times = times, func = SPCmod, parms, input = sigimp) )) @ All output is printed at once: <>= plot(out) @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the Lotka-Volterra resource (S)-producer (P) - consumer (C) model with time-variable input (signal) - see text for R-code} \label{fig:lv} \end{figure} The C-code, in file \url{Forcing\_lv.c}, can be found in the packages \url{/doc/examples/dynload} subdirectory\footnote{this can be opened by typing \code{browseURL(paste(system.file(package = "deSolve"), "/doc/examples/dynload", sep = ""))}}. It can be compiled, from within R by \begin{verbatim} system("R CMD SHLIB Forcing_lv.c") \end{verbatim} After defining the parameter and forcing vectors, and giving them comprehensible names, the parameter and forcing initialiser functions are defined (\code{parmsc} and \code{forcc} respectively). Next is the derivative function, \code{derivsc}. \begin{verbatim} #include static double parms[6]; static double forc[1]; /* A trick to keep up with the parameters and forcings */ #define b parms[0] #define c parms[1] #define d parms[2] #define e parms[3] #define f parms[4] #define g parms[5] #define import forc[0] /* initializers: */ void odec(void (* odeparms)(int *, double *)) { int N=6; odeparms(&N, parms); } void forcc(void (* odeforcs)(int *, double *)) { int N=1; odeforcs(&N, forc); } /* derivative function */ void derivsc(int *neq, double *t, double *y, double *ydot, double *yout, int*ip) { if (ip[0] <2) error("nout should be at least 2"); ydot[0] = import - b*y[0]*y[1] + g*y[2]; ydot[1] = c*y[0]*y[1] - d*y[2]*y[1]; ydot[2] = e*y[1]*y[2] - f*y[2]; yout[0] = y[0] + y[1] + y[2]; yout[1] = import; } \end{verbatim} After defining the forcing function time series, which is to be interpolated by the integration routine, and loading the DLL, the model is run: \begin{verbatim} Sigimp <- approx(signal$times, signal$import, xout=ftime,rule = 2)$y forcings <- cbind(ftime,Sigimp) dyn.load("Forcing_lv.dll") out <- ode(y=xstart, times, func = "derivsc", parms = parms, dllname = "Forcing_lv",initforc = "forcc", forcings=forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum","signal"), method = rkMethod("rk34f")) dyn.unload("Forcing_lv.dll") \end{verbatim} This code executes about 30 times faster than the \proglang{R}-code. With a longer simulation time, the difference becomes more pronounced, e.g. with times till 800 days, the DLL code executes 200 times faster% \footnote{this is due to the sequential update of the forcing functions by the solvers, compared to the bisectioning approach used by approxfun}. \section{Implementing events in compiled code} An \code{event} occurs when the value of a state variable is suddenly changed, e.g. a certain amount is added, or part is removed. The integration routines cannot deal easily with such state variable changes. Typically these events occur only at specific times. In \code{deSolve}, events can be imposed by means of an input file that specifies at which time a certain state variable is altered, or via an event function. Both types of events combine with compiled code. Take the previous example, the Lotka-Volterra SPC model. Suppose that every 10 days, half of the consumer is removed. We first implement these events as a \code{data.frame} <<>>= eventdata <- data.frame(var=rep("C",10),time=seq(10,100,10),value=rep(0.5,10), method=rep("multiply",10)) eventdata @ This model is solved, and plotted as: \begin{verbatim} dyn.load("Forcing_lv.dll") out2 <- ode(y = y, times, func = "derivsc", parms = parms, dllname = "Forcing_lv", initforc="forcc", forcings = forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum", "signal"), events=list(data=eventdata)) dyn.unload("Forcing_lv.dll") plot(out2, which = c("S","P","C"), type = "l") \end{verbatim} The event can also be implemented in \proglang{C} as: \begin{verbatim} void event(int *n, double *t, double *y) { y[2] = y[2]*0.5; } \end{verbatim} Here n is the length of the state variable vector \code{y}. and is then solved as: \begin{verbatim} dyn.load("Forcing_lv.dll") out3 <- ode(y = y, times, func = "derivsc", parms = parms, dllname = "Forcing_lv", initforc="forcc", forcings = forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum", "signal"), events = list(func="event",time=seq(10,90,10))) dyn.unload("Forcing_lv.dll") \end{verbatim} \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} \includegraphics{comp-event} \end{center} \caption{Solution of the Lotka-Volterra resource (S)~-- producer (P)~-- consumer (C) model with time-variable input (signal) and with half of the consumer removed every 10 days - see text for R-code} \label{fig:lv2} \end{figure} \section{Delay differential equations} It is now also very simple to implement delay differential equations in compiled code and solve them with \code{dede}. In order to do so, you need to get access to the R-functions \code{lagvalue} and \code{lagderiv} that will give you the past value of the state variable or its derivative respectively. \subsection{Delays implemented in Fortran} If you use \proglang{Fortran}, then the easiest way is to link your code with a file called \code{dedeUtils.c} that you will find in the packages subdirectory \code{inst/doc/dynload-dede}. This file contains Fortran-callable interfaces to the delay-differential utility functions from package \pkg{deSolve}, and that are written in \proglang{C}. Its content is: \begin{verbatim} void F77_SUB(lagvalue)(double *T, int *nr, int *N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagvalue"); fun(*T, nr, *N, ytau); return; } void F77_SUB(lagderiv)(double *T, int *nr, int *N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagderiv"); fun(*T, nr, *N, ytau); return; } \end{verbatim} Here \code{T} is the time at which the value needs to be retrieved, \code{nr} is an integer that defines the number of the state variable or its derivative whose delay we want, \code{N} is the total number of state variabes and \code{ytau} will have the result. We start with an example, a Lotka-Volterra system with delay, that we will implement in \proglang{Fortran} (you will find this example in the package directory \code{inst/doc/dynload-dede}, in file \code{dede_lvF.f} The R-code would be: <<>>= derivs <- function(t, y, parms) { with(as.list(c(y, parms)), { if (t < tau) ytau <- c(1, 1) else ytau <- lagvalue(t - tau, c(1, 2)) dN <- f * N - g * N * P dP <- e * g * ytau[1] * ytau[2] - m * P list(c(dN, dP), tau=ytau[1], tau=ytau[2]) }) } yinit <- c(N = 1, P = 1) times <- seq(0, 500) parms <- c(f = 0.1, g = 0.2, e = 0.1, m = 0.1, tau = .2) yout <- dede(y = yinit, times = times, func = derivs, parms = parms) head(yout) @ In Fortran the code looks like this: \begin{verbatim} ! file dede_lfF.f ! Initializer for parameter common block subroutine initmod(odeparms) external odeparms double precision parms(5) common /myparms/parms call odeparms(5, parms) return end ! Derivatives and one output variable subroutine derivs(neq, t, y, ydot, yout, ip) integer neq, ip(*) double precision t, y(neq), ydot(neq), yout(*) double precision N, P, ytau(2), tlag integer nr(2) double precision f, g, e, m, tau common /myparms/f, g, e, m, tau if (ip(1) < 2) call rexit("nout should be at least 2") N = y(1) P = y(2) nr(1) = 0 nr(2) = 1 ytau(1) = 1.0 ytau(2) = 1.0 tlag = t - tau if (tlag .GT. 0.0) call lagvalue(tlag, nr, 2, ytau) ydot(1) = f * N - g * N * P ydot(2) = e * g * ytau(1) * ytau(2) - m * P yout(1) = ytau(1) yout(2) = ytau(2) return end \end{verbatim} During compilation, we need to also compile the file \code{dedeUtils.c}. Assuming that the above \proglang{Fortran} code is in file \code{dede_lvF.f}, which is found in the working directory that also contains file \code{dedeUtils.c}, the problem is compiled and run as: \begin{verbatim} system("R CMD SHLIB dede_lvF.f dedeUtils.c") dyn.load(paste("dede_lvF", .Platform$dynlib.ext, sep="")) yout3 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dede_lvF", initfunc = "initmod", nout = 2) \end{verbatim} \subsection{Delays implemented in C} We now give the same example in \proglang{C}-code (you will find this in directory \code{inst/doc/dynload-dede/dede_lv.c}). \begin{verbatim} #include #include #include #include static double parms[5]; #define f parms[0] #define g parms[1] #define e parms[2] #define m parms[3] #define tau parms[4] /* Interface to dede utility functions in package deSolve */ void lagvalue(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagvalue"); return fun(T, nr, N, ytau); } void lagderiv(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagderiv"); return fun(T, nr, N, ytau); } /* Initializer */ void initmod(void (* odeparms)(int *, double *)) { int N = 5; odeparms(&N, parms); } /* Derivatives */ void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] < 2) error("nout should be at least 1"); double N = y[0]; double P = y[1]; int Nout = 2; // number of returned lags ( <= n_eq !!) int nr[2] = {0, 1}; // which lags are needed? // numbering starts from zero ! double ytau[2] = {1.0, 1.0}; // array; initialize with default values ! double T = *t - tau; if (*t > tau) { lagvalue(T, nr, Nout, ytau); } ydot[0] = f * N - g * N * P; ydot[1] = e * g * ytau[0] * ytau[1] - m * P; yout[0] = ytau[0]; yout[1] = ytau[1]; } \end{verbatim} Assuming this code is in a file called \code{dede_lv.c}, which is in the working directory, this file is then compiled and run as: \begin{verbatim} system("R CMD SHLIB dede_lv.c") dyn.load(paste("dede_lv", .Platform$dynlib.ext, sep="")) yout2 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dede_lv", initfunc = "initmod", nout = 2) dyn.unload(paste("dede_lv", .Platform$dynlib.ext, sep="")) \end{verbatim} \section{Difference equations in compiled code} There is one special-purpose solver, triggered with \code{method = "iteration"} which can be used in cases where the new values of the state variables are estimated by the user, and need not be found by integration. This is for instance useful when the model consists of difference equations, or for 1-D models when transport is implemented by an implicit or a semi-implicit method. An example of a discrete time model, represented by a difference equation is given in the help file of solver \code{ode}. It consists of the host-parasitoid model described as from \citet[p283]{Soetaert08}. We first give the R-code, and how it is solved: \begin{verbatim} Parasite <- function (t, y, ks) { P <- y[1] H <- y[2] f <- A * P / (ks +H) Pnew <- H* (1-exp(-f)) Hnew <- H * exp(rH*(1.-H) - f) list (c(Pnew, Hnew)) } rH <- 2.82 # rate of increase A <- 100 # attack rate ks <- 15. # half-saturation density out <- ode (func = Parasite, y = c(P = 0.5, H = 0.5), times = 0:50, parms = ks, method = "iteration") \end{verbatim} Note that the function returns the updated value of the state variables rather than the rate of change (derivative). The method ``iteration'' does not perform any integration. The implementation in \proglang{FORTRAN} consists of an initialisation function to pass the parameter values (\code{initparms}) and the "update" function that returns the new values of the state variables (\code{parasite}): \begin{verbatim} subroutine initparms(odeparms) external odeparms double precision parms(3) common /myparms/parms call odeparms(3, parms) return end subroutine parasite (neq, t, y, ynew, out, iout) integer neq, iout(*) double precision t, y(neq), ynew(neq), out(*), rH, A, ks common /myparms/ rH, A, ks double precision P, H, f P = y(1) H = y(2) f = A * P / (ks + H) ynew(1) = H * (1.d0 - exp(-f)) ynew(2) = H * exp (rH * (1.d0 - H) - f) return end \end{verbatim} The model is compiled, loaded and executed in R as: \begin{verbatim} system("R CMD SHLIB difference.f") dyn.load(paste("difference", .Platform$dynlib.ext, sep = "")) require(deSolve) rH <- 2.82 # rate of increase A <- 100 # attack rate ks <- 15. # half-saturation density parms <- c(rH = rH, A = A, ks = ks) out <- ode (func = "parasite", y = c(P = 0.5, H = 0.5), times = 0:50, initfunc = "initparms", dllname = "difference", parms = parms, method = "iteration") \end{verbatim} \section{Final remark} Detailed information about communication between \proglang{C}, \proglang{FORTRAN} and \proglang{R} can be found in \citet{Rexts2009}. Notwithstanding the speed gain when using compiled code, one should not carelessly decide to always resort to this type of modelling. Because the code needs to be formally compiled and linked to \proglang{R} much of the elegance when using pure \proglang{R} models is lost. Moreover, mistakes are easily made and paid harder in compiled code: often a programming error will terminate \proglang{R}. In addition, these errors may not be simple to trace. \clearpage %% this adds References to the PDF-Index without adding an obsolete section \phantomsection \addcontentsline{toc}{section}{References} \bibliography{integration} \end{document} deSolve/vignettes/integration.bib0000644000176000001440000002033513136461014016716 0ustar ripleyusers% Encoding: UTF-8 @ARTICLE{Bogacki1989, author = {Bogacki, P and Shampine, L F}, title = {A 3(2) Pair of Runge-Kutta Formulas}, journal = {Applied Mathematics Letters}, year = {1989}, volume = {2}, pages = {1--9} } @BOOK{Brenan96, title = {Numerical Solution of Initial-Value Problems in Differential-Algebraic Equations}, publisher = {SIAM Classics in Applied Mathematics}, year = {1996}, author = {Brenan, K E and Campbell, S L and Petzold, L R} } @ARTICLE{Brown89, author = {Brown, P N and Byrne, G D and Hindmarsh, A C}, title = {\pkg{VODE}, A Variable-Coefficient ODE Solver}, journal = {SIAM Journal on Scientific and Statistical Computing}, year = {1989}, volume = {10}, pages = {1038--1051} } @BOOK{Butcher1987, title = {The Numerical Analysis of Ordinary Differential Equations, Runge-Kutta and General Linear Methods}, publisher = {John Wiley \& Sons}, year = {1987}, author = {Butcher, J C}, volume = {2}, pages = {1--9}, address = {Chichester and New York.} } @MANUAL{bvpSolve, title = {\pkg{bvpSolve}: Solvers for Boundary Value Problems of Ordinary Differential Equations}, author = {Karline Soetaert and Jeff R. Cash and Francesca Mazzia}, year = {2010}, note = {\proglang{R} package version 1.2}, url = {http://CRAN.R-project.org/package=bvpSolve} } @ARTICLE{Cash1990, author = {Cash, J R and Karp, A H}, title = {A Variable Order Runge-Kutta Method for Initial Value Problems With Rapidly Varying Right-Hand Sides}, journal = {ACM Transactions on Mathematical Software}, year = {1990}, volume = {16}, pages = {201--222} } @MANUAL{compiledCode, title = {\proglang{R} package \pkg{deSolve}: Writing Code in Compiled Languages}, author = {Karline Soetaert and Thomas Petzoldt and R. Woodrow Setzer}, year = {2008}, note = {\pkg{deSolve} vignette - \proglang{R} package version 1.8} } @MANUAL{deSolve, title = {deSolve: General solvers for initial value problems of ordinary differential equations (ODE), partial differential equations (PDE), differential algebraic equations (DAE) and delay differential equations (DDE)}, author = {Karline Soetaert and Thomas Petzoldt and R. Woodrow Setzer}, year = {2010}, note = {R package version 1.8} } @ARTICLE{deSolve_jss, author = {Soetaert, K and Petzoldt, T and Setzer, RW}, title = {Solving Differential Equations in \proglang{R}: Package \pkg{deSolve}}, journal = {Journal of Statistical Software}, year = {2010}, volume = {33}, pages = {1--25}, number = {9}, coden = {JSSOBK}, issn = {1548-7660}, url = {http://www.jstatsoft.org/v33/i09} } @ARTICLE{Dormand1980, author = {Dormand, J R and Prince, P J}, title = {A family of embedded Runge-Kutta formulae}, journal = {Journal of Computational and Applied Mathematics}, year = {1980}, volume = {6}, pages = {19--26}, issue = {1} } @ARTICLE{Dormand1981, author = {Dormand, J R and Prince, P J}, title = {High Order Embedded Runge-Kutta Formulae}, journal = {Journal of Computational and Applied Mathematics}, year = {1981}, volume = {7}, pages = {67--75}, issue = {1} } @ARTICLE{Fehlberg1967, author = {Fehlberg, E}, title = {Klassische Runge-Kutta-Formeln fuenfter and siebenter Ordnung mit Schrittweiten-Kontrolle}, journal = {Computing (Arch. Elektron. Rechnen)}, year = {1967}, volume = {4}, pages = {93--106} } @BOOK{Hairer1, title = {Solving Ordinary Differential Equations I: Nonstiff Problems. Second Revised Edition}, publisher = {Springer-Verlag}, year = {2009}, author = {Hairer, E and Norsett, S. P. and Wanner, G}, address = {Heidelberg} } @BOOK{Hairer2, title = {Solving Ordinary Differential Equations II: Stiff and Differential-Algebraic Problems. Second Revised Edition}, publisher = {Springer-Verlag}, year = {2010}, author = {Hairer, E and Wanner, G}, address = {Heidelberg} } @INCOLLECTION{Hindmarsh83, author = {Hindmarsh, A. C.}, title = {\pkg{ODEPACK}, a Systematized Collection of {ODE} Solvers}, booktitle = {Scientific Computing, Vol. 1 of IMACS Transactions on Scientific Computation}, publisher = {IMACS / North-Holland}, year = {1983}, editor = {Stepleman, R.}, pages = {55-64}, address = {Amsterdam} } @ARTICLE{Petzold1983, author = {Linda R. Petzold}, title = {Automatic Selection of Methods for Solving Stiff and Nonstiff Systems of Ordinary Differential Equations}, journal = {SIAM Journal on Scientific and Statistical Computing}, year = {1983}, volume = {4}, pages = {136--148} } @Conference{Petzoldt-Rennes, author = {Petzoldt, Thomas}, title = {Dynamic simulation models - is R powerful enough?}, booktitle = {UseR!2009, July 8-10, Rennes, France}, year = {2009} } @Conference{Petzoldt-UCLA, author = {Petzoldt, Thomas}, title = {Swimming in clear lakes: How model coupling with R helps to improve water quality}, booktitle = {user!2014}, year = {2014} } @Conference{Petzoldt-Warwick, author = {Petzoldt, T. and Soetaert, K.}, title = {Using R for Systems Understanding - A Dynamic Approach}, booktitle = {UseR!2011, August 16-18, University of Warwick, Coventry, UK}, year = {2011} } @BOOK{Press92, title = {Numerical Recipes in FORTRAN. The Art of Scientific Computing}, publisher = {Cambridge University Press}, year = {1992}, author = {Press, W H and Teukolsky, S A and Vetterling, W T and Flannery, B P}, edition = {2nd} } @MANUAL{Rcore, title = {\proglang{R}: A Language and Environment for Statistical Computing}, author = {{\proglang{R} Development Core Team}}, organization = {\proglang{R} Foundation for Statistical Computing}, address = {Vienna, Austria}, year = {2008}, note = {{ISBN} 3-900051-07-0}, url = {http://www.R-project.org} } @Manual{ReacTran, title = {ReacTran: Reactive transport modelling in 1D, 2D and 3D}, author = {Karline Soetaert and Filip Meysman}, year = {2010}, note = {R package version 1.3}, }@MANUAL{Rexts2009, title = {Writing \proglang{R} Extensions}, author = {{\proglang{R} Development Core Team}}, organization = {R Foundation for Statistical Computing}, address = {Vienna, Austria}, year = {2009}, note = {{ISBN} 3-900051-11-9}, url = {http://www.R-project.org} } @MANUAL{Setzer01, title = {The \pkg{odesolve} Package: Solvers for Ordinary Differential Equations}, author = {R. Woodrow Setzer}, year = {2001}, note = {R package version 0.1-1} } @BOOK{Soetaert08, title = {A Practical Guide to Ecological Modelling. Using \proglang{R} as a Simulation Platform}, publisher = {Springer}, year = {2009}, author = {Soetaert, K and Herman, P M J}, pages = {372}, note = {ISBN 978-1-4020-8623-6} } @Conference{Soetaert-ICNAAM, author = {Soetaert, K., Meysman, F. and Petzoldt, T.}, title = {Solving Differential Equations in R}, booktitle = {ICNAAM 2010: International Conference of Numerical Analysis and Applied Mathematics, September 19-25, Rhodos, Greece}, year = {2010}, doi = {doi:10.1063/1.3498463} } @Conference{Soetaert-Rennes, author = {Soetaert, Karline}, title = {Mathematical modelling of the environment - are there enough data?}, booktitle = {UseR!2009, July 8-10, Rennes, France}, year = {2009} } @Manual{ST2000, author = {Shampine, L.F and Thompson, S.}, year = {2000}, title = {Solving Delay Differential Equations with dde23}, url = {http://www.runet.edu/~thompson/webddes/tutorial.pdf} } @MANUAL{testset, title = {Test Set for Initial Value Problem Solvers, release 2.4}, author = {Francesca Mazzia and Cecilia Magherini}, note = {Report 4/2008}, address = {Department of Mathematics, University of Bari, Italy}, year = {2008}, url = {http://pitagora.dm.uniba.it/~testset} } @Conference{Tutorial-UCLA, author = {Soetaert, Karline and Petzoldt, Thomas}, title = {Simulating differential equation models in R}, booktitle = {Pre-conference tutorial at the useR!2014 conference, UCLA, Los Angeles, June 30 - July 3 2014}, year = {2014}, url = {http://user2014.stat.ucla.edu/} } @Conference{, author = {Soetaert, Karline}, title = {Solving differential equations in R (plenary talk)}, booktitle = {useR!2014 conference, UCLA, Los Angeles, June 30 - July 3 2014}, year = {2014} } deSolve/vignettes/deSolve.Rnw0000644000176000001440000020043213136461014016004 0ustar ripleyusers\documentclass[article,nojss]{jss} \DeclareGraphicsExtensions{.pdf, .eps, .png, .jpeg} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Add-on packages and fonts \usepackage{graphicx} \usepackage{amsmath} \newcommand{\noun}[1]{\textsc{#1}} %% Bold symbol macro for standard LaTeX users \providecommand{\boldsymbol}[1]{\mbox{\boldmath $#1$}} %% Because html converters don't know tabularnewline \providecommand{\tabularnewline}{\\} \usepackage{array} % table commands \setlength{\extrarowheight}{0.1cm} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% User specified LaTeX commands. \newcommand{\R}{\proglang{R }} \newcommand{\ds}{\textbf{\textsf{deSolve }}} \newcommand{\bs}{\textbf{\textsf{bvpSolve }}} \newcommand{\rt}{\textbf{\textsf{ReacTran }}} \newcommand{\rb}[1]{\raisebox{1.5ex}{#1}} \title{Package \pkg{deSolve}: Solving Initial Value Differential Equations in \proglang{R}} \Plaintitle{Package deSolve: Solving Initial Value Differential Equations in R} \Keywords{differential equations, ordinary differential equations, differential algebraic equations, partial differential equations, initial value problems, \proglang{R}} \Plainkeywords{differential equations, ordinary differential equations, differential algebraic equations, partial differential equations, initial value problems, R} \author{ Karline Soetaert\\ Royal Netherlands Institute\\ of Sea Research (NIOZ)\\ Yerseke, The Netherlands \And Thomas Petzoldt\\ Technische Universit\"at \\ Dresden\\ Germany \And R. Woodrow Setzer\\ National Center for\\ Computational Toxicology\\ US Environmental Protection Agency } \Plainauthor{Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer} \Abstract{ \R package \ds \citep{deSolve_jss,deSolve} the successor of \proglang{R} package \pkg{odesolve} is a package to solve initial value problems (IVP) of: \begin{itemize} \item ordinary differential equations (ODE), \item differential algebraic equations (DAE), \item partial differential equations (PDE) and \item delay differential equations (DeDE). \end{itemize} The implementation includes stiff and nonstiff integration routines based on the \pkg{ODEPACK} \proglang{FORTRAN} codes \citep{Hindmarsh83}. It also includes fixed and adaptive time-step explicit Runge-Kutta solvers and the Euler method \citep{Press92}, and the implicit Runge-Kutta method RADAU \citep{Hairer2}. In this vignette we outline how to implement differential equations as \R-functions. Another vignette (``compiledCode'') \citep{compiledCode}, deals with differential equations implemented in lower-level languages such as \proglang{FORTRAN}, \proglang{C}, or \proglang{C++}, which are compiled into a dynamically linked library (DLL) and loaded into \proglang{R} \citep{Rcore}. Note that another package, \bs provides methods to solve boundary value problems \citep{bvpSolve}. } %% The address of (at least) one author should be given %% in the following format: \Address{ Karline Soetaert\\ Centre for Estuarine and Marine Ecology (CEME)\\ Royal Netherlands Institute of Sea Research (NIOZ)\\ 4401 NT Yerseke, Netherlands \\ E-mail: \email{karline.soetaert@nioz.nl}\\ URL: \url{http://www.nioz.nl}\\ \\ Thomas Petzoldt\\ Institut f\"ur Hydrobiologie\\ Technische Universit\"at Dresden\\ 01062 Dresden, Germany\\ E-mail: \email{thomas.petzoldt@tu-dresden.de}\\ URL: \url{http://tu-dresden.de/Members/thomas.petzoldt/}\\ \\ R. Woodrow Setzer\\ National Center for Computational Toxicology\\ US Environmental Protection Agency\\ URL: \url{http://www.epa.gov/comptox} } %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% R/Sweave specific LaTeX commands. %% need no \usepackage{Sweave} %\VignetteIndexEntry{R Package deSolve: Solving Initial Value Differential Equations in R} %\VignetteKeywords{differential equations, ordinary differential equations, differential algebraic equations, partial differential equations, initial value problems, R} %\VignettePackage{deSolve} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Begin of the document \begin{document} \SweaveOpts{engine=R,eps=FALSE} \SweaveOpts{keep.source=TRUE} <>= library("deSolve") options(prompt = "> ") options(width=70) @ \maketitle \section{A simple ODE: chaos in the atmosphere} The Lorenz equations (Lorenz, 1963) were the first chaotic dynamic system to be described. They consist of three differential equations that were assumed to represent idealized behavior of the earth's atmosphere. We use this model to demonstrate how to implement and solve differential equations in \proglang{R}. The Lorenz model describes the dynamics of three state variables, $X$, $Y$ and $Z$. The model equations are: \begin{align*} \frac{dX}{dt} &= a \cdot X + Y \cdot Z \\ \frac{dY}{dt} &= b \cdot (Y - Z) \\ \frac{dZ}{dt} &= - X \cdot Y + c \cdot Y - Z \end{align*} with the initial conditions: \[ X(0) = Y(0) = Z(0) = 1 \] Where $a$, $b$ and $c$ are three parameters, with values of -8/3, -10 and 28 respectively. Implementation of an IVP ODE in \R can be separated in two parts: the model specification and the model application. Model specification consists of: \begin{itemize} \item Defining model parameters and their values, \item Defining model state variables and their initial conditions, \item Implementing the model equations that calculate the rate of change (e.g. $dX/dt$) of the state variables. \end{itemize} The model application consists of: \begin{itemize} \item Specification of the time at which model output is wanted, \item Integration of the model equations (uses R-functions from \pkg{deSolve}), \item Plotting of model results. \end{itemize} Below, we discuss the \proglang{R}-code for the Lorenz model. \subsection{Model specification} \subsubsection{Model parameters} There are three model parameters: $a$, $b$, and $c$ that are defined first. Parameters are stored as a vector with assigned names and values: <<>>= parameters <- c(a = -8/3, b = -10, c = 28) @ \subsubsection{State variables} The three state variables are also created as a vector, and their initial values given: <<>>= state <- c(X = 1, Y = 1, Z = 1) @ \subsubsection{Model equations} The model equations are specified in a function (\code{Lorenz}) that calculates the rate of change of the state variables. Input to the function is the model time (\code{t}, not used here, but required by the calling routine), and the values of the state variables (\code{state}) and the parameters, in that order. This function will be called by the \R routine that solves the differential equations (here we use \code{ode}, see below). The code is most readable if we can address the parameters and state variables by their names. As both parameters and state variables are `vectors', they are converted into a list. The statement \code{with(as.list(c(state, parameters)), {...})} then makes available the names of this list. The main part of the model calculates the rate of change of the state variables. At the end of the function, these rates of change are returned, packed as a list. Note that it is necessary \textbf{to return the rate of change in the same ordering as the specification of the state variables. This is very important.} In this case, as state variables are specified $X$ first, then $Y$ and $Z$, the rates of changes are returned as $dX, dY, dZ$. <<>>= Lorenz<-function(t, state, parameters) { with(as.list(c(state, parameters)),{ # rate of change dX <- a*X + Y*Z dY <- b * (Y-Z) dZ <- -X*Y + c*Y - Z # return the rate of change list(c(dX, dY, dZ)) }) # end with(as.list ... } @ \subsection{Model application} \subsubsection{Time specification} We run the model for 100 days, and give output at 0.01 daily intervals. R's function \code{seq()} creates the time sequence: <<>>= times <- seq(0, 100, by = 0.01) @ \subsubsection{Model integration} The model is solved using \ds function \code{ode}, which is the default integration routine. Function \code{ode} takes as input, a.o. the state variable vector (\code{y}), the times at which output is required (\code{times}), the model function that returns the rate of change (\code{func}) and the parameter vector (\code{parms}). Function \code{ode} returns an object of class \code{deSolve} with a matrix that contains the values of the state variables (columns) at the requested output times. <<>>= library(deSolve) out <- ode(y = state, times = times, func = Lorenz, parms = parameters) head(out) @ \subsubsection{Plotting results} Finally, the model output is plotted. We use the plot method designed for objects of class \code{deSolve}, which will neatly arrange the figures in two rows and two columns; before plotting, the size of the outer upper margin (the third margin) is increased (\code{oma}), such as to allow writing a figure heading (\code{mtext}). First all model variables are plotted versus \code{time}, and finally \code{Z} versus \code{X}: <>= par(oma = c(0, 0, 3, 0)) plot(out, xlab = "time", ylab = "-") plot(out[, "X"], out[, "Z"], pch = ".") mtext(outer = TRUE, side = 3, "Lorenz model", cex = 1.5) @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the ordinary differential equation - see text for R-code} \label{fig:dae} \end{figure} \clearpage \section{Solvers for initial value problems of ordinary differential equations} Package \ds contains several IVP ordinary differential equation solvers, that belong to the most important classes of solvers. Most functions are based on original (\proglang{FORTRAN}) implementations, e.g. the Backward Differentiation Formulae and Adams methods from \pkg{ODEPACK} \citep{Hindmarsh83}, or from \citep{Brown89,Petzold1983}, the implicit Runge-Kutta method RADAU \citep{Hairer2}. The package contains also a de novo implementation of several Runge-Kutta methods \citep{Butcher1987, Press92, Hairer1}. All integration methods\footnote{except \code{zvode}, the solver used for systems containing complex numbers.} can be triggered from function \code{ode}, by setting \code{ode}'s argument \code{method}), or can be run as stand-alone functions. Moreover, for each integration routine, several options are available to optimise performance. For instance, the next statements will use integration method \code{radau} to solve the model, and set the tolerances to a higher value than the default. Both statements are the same: <<>>= outb <- radau(state, times, Lorenz, parameters, atol = 1e-4, rtol = 1e-4) outc <- ode(state, times, Lorenz, parameters, method = "radau", atol = 1e-4, rtol = 1e-4) @ The default integration method, based on the \proglang{FORTRAN} code LSODA is one that switches automatically between stiff and non-stiff systems \citep{Petzold1983}. This is a very robust method, but not necessarily the most efficient solver for one particular problem. See \citep{deSolve_jss} for more information about when to use which solver in \pkg{deSolve}. For most cases, the default solver, \code{ode} and using the default settings will do. Table \ref{tb:rs} also gives a short overview of the available methods. To show how to trigger the various methods, we solve the model with several integration routines, each time printing the time it took (in seconds) to find the solution: <<>>= print(system.time(out1 <- rk4 (state, times, Lorenz, parameters))) print(system.time(out2 <- lsode (state, times, Lorenz, parameters))) print(system.time(out <- lsoda (state, times, Lorenz, parameters))) print(system.time(out <- lsodes(state, times, Lorenz, parameters))) print(system.time(out <- daspk (state, times, Lorenz, parameters))) print(system.time(out <- vode (state, times, Lorenz, parameters))) @ \subsection{Runge-Kutta methods and Euler} The explicit Runge-Kutta methods are de novo implementations in \proglang{C}, based on the Butcher tables \citep{Butcher1987}. They comprise simple Runge-Kutta formulae (Euler's method \code{euler}, Heun's method \code{rk2}, the classical 4th order Runge-Kutta, \code{rk4}) and several Runge-Kutta pairs of order 3(2) to order 8(7). The embedded, explicit methods are according to \citet{Fehlberg1967} (\code{rk..f}, \code{ode45}), \citet{Dormand1980,Dormand1981} (\code{rk..dp.}), \citet{Bogacki1989} (\code{rk23bs}, \code{ode23}) and \citet{Cash1990} (\code{rk45ck}), where \code{ode23} and \code{ode45} are aliases for the popular methods \code{rk23bs} resp. \code{rk45dp7}. With the following statement all implemented methods are shown: <<>>= rkMethod() @ This list also contains implicit Runge-Kutta's (\code{irk..}), but they are not yet optimally coded. The only well-implemented implicit Runge-Kutta is the \code{radau} method \citep{Hairer2} that will be discussed in the section dealing with differential algebraic equations. The properties of a Runge-Kutta method can be displayed as follows: <<>>= rkMethod("rk23") @ Here \code{varstep} informs whether the method uses a variable time-step; \code{FSAL} whether the first same as last strategy is used, while \code{stage} and \code{Qerr} give the number of function evaluations needed for one step, and the order of the local truncation error. \code{A, b1, b2, c} are the coefficients of the Butcher table. Two formulae (\code{rk45dp7, rk45ck}) support dense output. It is also possible to modify the parameters of a method (be very careful with this) or define and use a new Runge-Kutta method: <<>>= func <- function(t, x, parms) { with(as.list(c(parms, x)),{ dP <- a * P - b * C * P dC <- b * P * C - c * C res <- c(dP, dC) list(res) }) } rKnew <- rkMethod(ID = "midpoint", varstep = FALSE, A = c(0, 1/2), b1 = c(0, 1), c = c(0, 1/2), stage = 2, Qerr = 1 ) out <- ode(y = c(P = 2, C = 1), times = 0:100, func, parms = c(a = 0.1, b = 0.1, c = 0.1), method = rKnew) head(out) @ \subsubsection{Fixed time-step methods} There are two explicit methods that do not adapt the time step: the \code{euler} method and the \code{rk4} method. They are implemented in two ways: \begin{itemize} \item as a \code{rkMethod} of the \textbf{general} \code{rk} solver. In this case the time step used can be specified independently from the \code{times} argument, by setting argument \code{hini}. Function \code{ode} uses this general code. \item as \textbf{special} solver codes \code{euler} and \code{rk4}. These implementations are simplified and with less options to avoid overhead. The timestep used is determined by the time increment in the \code{times} argument. \end{itemize} For example, the next two statements both trigger the Euler method, the first using the ``special'' code with a time step = 1, as imposed by the \code{times} argument, the second using the generalized method with a time step set by \code{hini}. Unsurprisingly, the first solution method completely fails (the time step $= 1$ is much too large for this problem). \begin{verbatim} out <- euler(y = state, times = 0:40, func = Lorenz, parms = parameters) outb <- ode(y = state, times = 0:40, func = Lorenz, parms = parameters, method = "euler", hini = 0.01) \end{verbatim} \subsection{Model diagnostics and summaries} Function \code{diagnostics} prints several diagnostics of the simulation to the screen. For the Runge-Kutta and \code{lsode} routine called above they are: <<>>= diagnostics(out1) diagnostics(out2) @ There is also a \code{summary} method for \code{deSolve} objects. This is especially handy for multi-dimensional problems (see below) <<>>= summary(out1) @ \clearpage \section{Partial differential equations} As package \ds includes integrators that deal efficiently with arbitrarily sparse and banded Jacobians, it is especially well suited to solve initial value problems resulting from 1, 2 or 3-dimensional partial differential equations (PDE), using the method-of-lines approach. The PDEs are first written as ODEs, using finite differences. This can be efficiently done with functions from R-package \rt \citep{ReacTran}. However, here we will create the finite differences in R-code. Several special-purpose solvers are included in \pkg{deSolve}: \begin{itemize} \item \code{ode.band} integrates 1-dimensional problems comprizing one species, \item \code{ode.1D} integrates 1-dimensional problems comprizing one or many species, \item \code{ode.2D} integrates 2-dimensional problems, \item \code{ode.3D} integrates 3-dimensional problems. \end{itemize} As an example, consider the Aphid model described in \citet{Soetaert08}. It is a model where aphids (a pest insect) slowly diffuse and grow on a row of plants. The model equations are: \[ \frac{{\partial N}}{{\partial t}} = - \frac{{\partial Flux}}{{\partial {\kern 1pt} x}} + g \cdot N \] and where the diffusive flux is given by: \[ Flux = - D\frac{{\partial N}}{{\partial {\kern 1pt} x}} \] with boundary conditions \[ N_{x=0}=N_{x=60}=0 \] and initial condition \begin{center} $N_x=0$ for $x \neq 30$ $N_x=1$ for $x = 30$ \end{center} In the method of lines approach, the spatial domain is subdivided in a number of boxes and the equation is discretized as: \[ \frac{{dN_i }}{{dt}} = - \frac{{Flux_{i,i + 1} - Flux_{i - 1,i} }}{{\Delta x_i }} + g \cdot N_i \] with the flux on the interface equal to: \[ Flux_{i - 1,i} = - D_{i - 1,i} \cdot \frac{{N_i - N_{i - 1} }}{{\Delta x_{i - 1,i} }} \] Note that the values of state variables (here densities) are defined in the centre of boxes (i), whereas the fluxes are defined on the box interfaces. We refer to \citet{Soetaert08} for more information about this model and its numerical approximation. Here is its implementation in \proglang{R}. First the model equations are defined: <<>>= Aphid <- function(t, APHIDS, parameters) { deltax <- c (0.5, rep(1, numboxes - 1), 0.5) Flux <- -D * diff(c(0, APHIDS, 0)) / deltax dAPHIDS <- -diff(Flux) / delx + APHIDS * r # the return value list(dAPHIDS ) } # end @ Then the model parameters and spatial grid are defined <<>>= D <- 0.3 # m2/day diffusion rate r <- 0.01 # /day net growth rate delx <- 1 # m thickness of boxes numboxes <- 60 # distance of boxes on plant, m, 1 m intervals Distance <- seq(from = 0.5, by = delx, length.out = numboxes) @ Aphids are initially only present in two central boxes: <<>>= # Initial conditions: # ind/m2 APHIDS <- rep(0, times = numboxes) APHIDS[30:31] <- 1 state <- c(APHIDS = APHIDS) # initialise state variables @ The model is run for 200 days, producing output every day; the time elapsed in seconds to solve this 60 state-variable model is estimated (\code{system.time}): <<>>= times <-seq(0, 200, by = 1) print(system.time( out <- ode.1D(state, times, Aphid, parms = 0, nspec = 1, names = "Aphid") )) @ Matrix \code{out} consist of times (1st column) followed by the densities (next columns). <<>>= head(out[,1:5]) @ The \code{summary} method gives the mean, min, max, ... of the entire 1-D variable: <<>>= summary(out) @ Finally, the output is plotted. It is simplest to do this with \pkg{deSolve}'s \proglang{S3}-method \code{image} %% Do this offline %%<>= \begin{verbatim} image(out, method = "filled.contour", grid = Distance, xlab = "time, days", ylab = "Distance on plant, m", main = "Aphid density on a row of plants") \end{verbatim} %%@ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} %%<>= %%<> %%@ \includegraphics{aphid.png} \end{center} \caption{Solution of the 1-dimensional aphid model - see text for \R-code} \label{fig:aphid} \end{figure} As this is a 1-D model, it is best solved with \ds function \code{ode.1D}. A multi-species IVP example can be found in \citet{Soetaert08}. For 2-D and 3-D problems, we refer to the help-files of functions \code{ode.2D} and \code{ode.3D}. The output of one-dimensional models can also be plotted using S3-method \code{plot.1D} and \code{matplot.1D}. In both cases, we can simply take a \code{subset} of the output, and add observations. <<>>= data <- cbind(dist = c(0,10, 20, 30, 40, 50, 60), Aphid = c(0,0.1,0.25,0.5,0.25,0.1,0)) @ <>= par (mfrow = c(1,2)) matplot.1D(out, grid = Distance, type = "l", mfrow = NULL, subset = time %in% seq(0, 200, by = 10), obs = data, obspar = list(pch = 18, cex = 2, col="red")) plot.1D(out, grid = Distance, type = "l", mfrow = NULL, subset = time == 100, obs = data, obspar = list(pch = 18, cex = 2, col="red")) @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the Aphid model - plotted with matplot.1D, plot.1D - see text for R-code} \label{fig:matplot1d} \end{figure} \clearpage \section{Differential algebraic equations} Package \ds contains two functions that solve initial value problems of differential algebraic equations. They are: \begin{itemize} \item \code{radau} which implements the implicit Runge-Kutta RADAU5 \citep{Hairer2}, \item \code{daspk}, based on the backward differentiation code DASPK \citep{Brenan96}. \end{itemize} Function \code{radau} needs the input in the form $M y' = f(t,y,y')$ where $M$ is the mass matrix. Function \code{daspk} also supports this input, but can also solve problems written in the form $F(t, y, y') = 0$. \code{radau} solves problems up to index 3; \code{daspk} solves problems of index $\leq$ 1. \subsection{DAEs of index maximal 1} Function \code{daspk} from package \ds solves (relatively simple) DAEs of index\footnote{note that many -- apparently simple -- DAEs are higher-index DAEs} maximal 1. The DAE has to be specified by the \emph{residual function} instead of the rates of change (as in ODE). Consider the following simple DAE: \begin{eqnarray*} \frac{dy_1}{dt}&=&-y_1+y_2\\ y_1 \cdot y_2 &=& t \end{eqnarray*} where the first equation is a differential, the second an algebraic equation. To solve it, it is first rewritten as residual functions: \begin{eqnarray*} 0&=&\frac{dy_1}{dt}+y_1-y_2\\ 0&=&y_1 \cdot y_2 - t \end{eqnarray*} In \R we write: <<>>= daefun <- function(t, y, dy, parameters) { res1 <- dy[1] + y[1] - y[2] res2 <- y[2] * y[1] - t list(c(res1, res2)) } library(deSolve) yini <- c(1, 0) dyini <- c(1, 0) times <- seq(0, 10, 0.1) ## solver system.time(out <- daspk(y = yini, dy = dyini, times = times, res = daefun, parms = 0)) @ <>= matplot(out[,1], out[,2:3], type = "l", lwd = 2, main = "dae", xlab = "time", ylab = "y") @ \setkeys{Gin}{width=0.4\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the differential algebraic equation model - see text for R-code} \label{fig:dae2} \end{figure} \subsection{DAEs of index up to three} Function \code{radau} from package \ds can solve DAEs of index up to three provided that they can be written in the form $M dy/dt = f(t,y)$. Consider the well-known pendulum equation: \begin{eqnarray*} x' &=& u\\ y' &=& v\\ u' &=& -\lambda x\\ v' &=& -\lambda y - 9.8\\ 0 &=& x^2 + y^2 - 1 \end{eqnarray*} where the dependent variables are $x, y, u, v$ and $\lambda$. Implemented in \R to be used with function \code{radau} this becomes: <<>>= pendulum <- function (t, Y, parms) { with (as.list(Y), list(c(u, v, -lam * x, -lam * y - 9.8, x^2 + y^2 -1 )) ) } @ A consistent set of initial conditions are: <<>>= yini <- c(x = 1, y = 0, u = 0, v = 1, lam = 1) @ and the mass matrix $M$: <<>>= M <- diag(nrow = 5) M[5, 5] <- 0 M @ Function \code{radau} requires that the index of each equation is specified; there are 2 equations of index 1, two of index 2, one of index 3: <<>>= index <- c(2, 2, 1) times <- seq(from = 0, to = 10, by = 0.01) out <- radau (y = yini, func = pendulum, parms = NULL, times = times, mass = M, nind = index) @ <>= plot(out, type = "l", lwd = 2) plot(out[, c("x", "y")], type = "l", lwd = 2) @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the pendulum problem, an index 3 differential algebraic equation using \code{radau} - see text for \proglang{R}-code} \label{fig:pendulum} \end{figure} \clearpage \section{Integrating systems containing complex numbers, function zvode} Function \code{zvode} solves ODEs that are composed of complex variables. We use \code{zvode} to solve the following system of 2 ODEs: \begin{align*} \frac{dz}{dt} &= i \cdot z\\ \frac{dw}{dt} &= -i \cdot w \cdot w \cdot z\\ \intertext{where} w(0) &= 1/2.1 \\ z(0) &= 1 \end{align*} on the interval $t = [0, 2 \pi]$ <<>>= ZODE2 <- function(Time, State, Pars) { with(as.list(State), { df <- 1i * f dg <- -1i * g * g * f return(list(c(df, dg))) }) } yini <- c(f = 1+0i, g = 1/2.1+0i) times <- seq(0, 2 * pi, length = 100) out <- zvode(func = ZODE2, y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10) @ The analytical solution is: \begin{align*} f(t) &= \exp (1i \cdot t) \intertext{and} g(t) &= 1/(f(t) + 1.1) \end{align*} The numerical solution, as produced by \code{zvode} matches the analytical solution: <<>>= analytical <- cbind(f = exp(1i*times), g = 1/(exp(1i*times)+1.1)) tail(cbind(out[,2], analytical[,1])) @ \clearpage \section{Making good use of the integration options} The solvers from \pkg{ODEPACK} can be fine-tuned if it is known whether the problem is stiff or non-stiff, or if the structure of the Jacobian is sparse. We repeat the example from \code{lsode} to show how we can make good use of these options. The model describes the time evolution of 5 state variables: <<>>= f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } @ and the initial conditions and output times are: <<>>= yini <- 1:5 times <- 1:20 @ The default solution, using \code{lsode} assumes that the model is stiff, and the integrator generates the Jacobian, which is assummed to be \emph{full}: <<>>= out <- lsode(yini, times, f1, parms = 0, jactype = "fullint") @ It is possible for the user to provide the Jacobian. Especially for large problems this can result in substantial time savings. In a first case, the Jacobian is written as a full matrix: <<>>= fulljac <- function (t, y, parms) { jac <- matrix(nrow = 5, ncol = 5, byrow = TRUE, data = c(0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1)) return(jac) } @ and the model solved as: <<>>= out2 <- lsode(yini, times, f1, parms = 0, jactype = "fullusr", jacfunc = fulljac) @ The Jacobian matrix is banded, with one nonzero band above (up) and one below(down) the diagonal. First we let \code{lsode} estimate the banded Jacobian internally (\code{jactype = "bandint"}): <<>>= out3 <- lsode(yini, times, f1, parms = 0, jactype = "bandint", bandup = 1, banddown = 1) @ It is also possible to provide the nonzero bands of the Jacobian in a function: <<>>= bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } @ in which case the model is solved as: <<>>= out4 <- lsode(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) @ Finally, if the model is specified as ``non-stiff'' (by setting \code{mf=10}), there is no need to specify the Jacobian: <<>>= out5 <- lsode(yini, times, f1, parms = 0, mf = 10) @ \clearpage \section{Events and roots} As from version 1.6, \code{events} are supported. Events occur when the values of state variables are instantaneously changed. They can be specified as a \code{data.frame}, or in a function. Events can also be triggered by a root function. Several integrators (\code{lsoda}, \code{lsodar}, \code{lsode}, \code{lsodes} and \code{radau}) can estimate the root of one or more functions. For the first 4 integration methods, the root finding algorithm is based on the algorithm in solver LSODAR, and implemented in FORTRAN. For \code{radau}, the root solving algorithm is written in C-code, and it works slightly different. Thus, some problems involving roots may be more efficient to solve with either \code{lsoda, lsode}, or \code{lsodes}, while other problems are more efficiently solved with \code{radau}. If a root is found, then the integration will be terminated, unless an event function is defined. A help file with information on roots and events can be opened by typing \code{?events} or \code{?roots}. \subsection{Event specified in a data.frame} In this example, two state variables with constant decay are modeled: <<>>= eventmod <- function(t, var, parms) { list(dvar = -0.1*var) } yini <- c(v1 = 1, v2 = 2) times <- seq(0, 10, by = 0.1) @ At time 1 and 9 a value is added to variable \code{v1}, at time 1 state variable \code{v2} is multiplied with 2, while at time 5 the value of \code{v2} is replaced with 3. These events are specified in a \code{data.frame}, eventdat: <<>>= eventdat <- data.frame(var = c("v1", "v2", "v2", "v1"), time = c(1, 1, 5, 9), value = c(1, 2, 3, 4), method = c("add", "mult", "rep", "add")) eventdat @ The model is solved with \code{ode}: <<>>= out <- ode(func = eventmod, y = yini, times = times, parms = NULL, events = list(data = eventdat)) @ <>= plot(out, type = "l", lwd = 2) @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A simple model that contains events} \label{fig:event1} \end{figure} \subsection{Event triggered by a root function} This model describes the position (\code{y1}) and velocity (\code{y2}) of a bouncing ball: <<>>= ballode<- function(t, y, parms) { dy1 <- y[2] dy2 <- -9.8 list(c(dy1, dy2)) } @ An event is triggered when the ball hits the ground (height = 0) Then velocity (\code{y2}) is reversed and reduced by 10 percent. The root function, \code{y[1] = 0}, triggers the event: <<>>= root <- function(t, y, parms) y[1] @ The event function imposes the bouncing of the ball <<>>= event <- function(t, y, parms) { y[1]<- 0 y[2]<- -0.9 * y[2] return(y) } @ After specifying the initial values and times, the model is solved, here using \code{lsode}. <<>>= yini <- c(height = 0, v = 20) times <- seq(from = 0, to = 20, by = 0.01) out <- lsode(times = times, y = yini, func = ballode, parms = NULL, events = list(func = event, root = TRUE), rootfun = root) @ <>= plot(out, which = "height", type = "l",lwd = 2, main = "bouncing ball", ylab = "height") @ \setkeys{Gin}{width=0.4\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A model, with event triggered by a root function} \label{fig:event2} \end{figure} \subsection{Events and time steps} The use of events requires that all event times are contained in the output time steps, otherwise such events would be skipped. This sounds easy but sometimes problems can occur due to the limited accuracy of floating point arithmetics of the computer. To make things work as excpected, two requirements have to be fulfilled: \begin{enumerate} \item all event times have to be contained \textbf{exactly} in times, i.e. with the maximum possible accuracy of floating point arithmetics. \item two time steps should not be too close together, otherwise numerical problems would occur during the integration. \end{enumerate} Starting from version 1.10 of \pkg{deSolve} this is now checked (and if necessary also fixed) automatically by the solver functions. A warning is issued to inform the user about possible problems, especially that the output time steps were now adjusted and therefore different from the ones originally specified by the user. This means that all values of \code{eventtimes} are now contained but only the subset of times that have no exact or ``rather close'' neighbors in \code{eventtimes}. Instead of relying on this automatism, matching times and eventtimes can also be managed by the user, either by appropriate rounding or by using function \code{cleanEventTimes} shown below. Let's assume we have a vector of time steps \code{times} and another vector of event times \code{eventtimes}: <<>>= times <- seq(0, 1, 0.1) eventtimes <- c(0.7, 0.9) @ If we now check whether the \code{eventtimes} are in \code{times}: <<>>= eventtimes %in% times @ we get the surprising answer that this is only partly the case, because \code{seq} made small numerical errors. The easiest method to get rid of this is rounding: <<>>= times2 <- round(times, 1) times - times2 @ The last line shows us that the error was always smaller than, say $10^{-15}$, what is typical for ordinary double precision arithmetics. The accuracy of the machine can be determined with \code{.Machine\$double.eps}. To check if all \code{eventtimes} are now contained in the new times vector \code{times2}, we use: <<>>= eventtimes %in% times2 @ or <<>>= all(eventtimes %in% times2) @ and see that everything is o.k. now. In few cases, rounding may not work properly, for example if a pharmacokinetic model is simulated with a daily time step, but drug injection occurs at precisely fixed times within the day. Then one has to add all additional event times to the ordinary time stepping: <<>>= times <- 1:10 eventtimes <- c(1.3, 3.4, 4, 7.9, 8.5) newtimes <- sort(unique(c(times, eventtimes))) @ If, however, an event and a time step are almost (but not exactly) the same, then it is more safe to use: <<>>= times <- 1:10 eventtimes <- c(1.3, 3.4, 4, 7.9999999999999999, 8.5) newtimes <- sort(c(eventtimes, cleanEventTimes(times, eventtimes))) @ because \code{cleanEventTimes} removes not only the doubled 4 (like \code{unique}, but also the ``almost doubled'' 8, while keeping the exact event time. The tolerance of \code{cleanEventTimes} can be adjusted using an optional argument \code{eps}. As said, this is normally done automatically by the differential equation solvers and in most cases appropriate rounding will be sufficient to get rid of the warnings. \clearpage \section{Delay differential equations} As from \pkg{deSolve} version 1.7, time lags are supported, and a new general solver for delay differential equations, \code{dede} has been added. We implement the lemming model, example 6 from \citep{ST2000}. Function \code{lagvalue} calculates the value of the state variable at \code{t - 0.74}. As long a these lag values are not known, the value 19 is assigned to the state variable. Note that the simulation starts at \code{time = - 0.74}. <<>>= library(deSolve) #----------------------------- # the derivative function #----------------------------- derivs <- function(t, y, parms) { if (t < 0) lag <- 19 else lag <- lagvalue(t - 0.74) dy <- r * y * (1 - lag/m) list(dy, dy = dy) } #----------------------------- # parameters #----------------------------- r <- 3.5; m <- 19 #----------------------------- # initial values and times #----------------------------- yinit <- c(y = 19.001) times <- seq(-0.74, 40, by = 0.01) #----------------------------- # solve the model #----------------------------- yout <- dede(y = yinit, times = times, func = derivs, parms = NULL, atol = 1e-10) @ <>= plot(yout, which = 1, type = "l", lwd = 2, main = "Lemming model", mfrow = c(1,2)) plot(yout[,2], yout[,3], xlab = "y", ylab = "dy", type = "l", lwd = 2) @ \setkeys{Gin}{width=\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A delay differential equation model} \label{fig:dde} \end{figure} \clearpage \section{Discrete time models, difference equations} There is one special-purpose solver, triggered with \code{method = "iteration"} which can be used in cases where the new values of the state variables are directly estimated by the user, and need not be found by numerical integration. This is for instance useful when the model consists of difference equations, or for 1-D models when transport is implemented by an implicit or a semi-implicit method. We give here an example of a discrete time model, represented by a difference equation: the Teasel model as from \citet[p287]{Soetaert08}. The dynamics of this plant is described by 6 stages and the transition from one stage to another is in a transition matrix: We define the stages and the transition matrix first: <<>>= Stages <- c("DS 1yr", "DS 2yr", "R small", "R medium", "R large", "F") NumStages <- length(Stages) # Population matrix A <- matrix(nrow = NumStages, ncol = NumStages, byrow = TRUE, data = c( 0, 0, 0, 0, 0, 322.38, 0.966, 0, 0, 0, 0, 0 , 0.013, 0.01, 0.125, 0, 0, 3.448 , 0.007, 0, 0.125, 0.238, 0, 30.170, 0.008, 0, 0.038, 0.245, 0.167, 0.862 , 0, 0, 0, 0.023, 0.75, 0 ) ) @ The difference function is defined as usual, but does not return the ``rate of change'' but rather the new relative stage densities are returned. Thus, each time step, the updated values are divided by the summed densities: <<>>= Teasel <- function (t, y, p) { yNew <- A %*% y list (yNew / sum(yNew)) } @ The model is solved using method ``iteration'': <<>>= out <- ode(func = Teasel, y = c(1, rep(0, 5) ), times = 0:50, parms = 0, method = "iteration") @ and plotted using R-function \code{matplot}: <>= matplot(out[,1], out[,-1], main = "Teasel stage distribution", type = "l") legend("topright", legend = Stages, lty = 1:6, col = 1:6) @ \setkeys{Gin}{width=0.6\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A difference model solved with method = ``iteration''} \label{fig:difference} \end{figure} \section{Plotting deSolve Objects} There are \proglang{S3} \code{plot} and \code{image} methods for plotting 0-D (plot), and 1-D and 2-D model output (image) as generated with \code{ode}, \code{ode.1D}, \code{ode.2D}. How to use it and examples can be found by typing \code{?plot.deSolve}. \subsection{Plotting Multiple Scenario's} The \code{plot} method for \code{deSolve} objects can also be used to compare different scenarios, e.g from the same model but with different sets of parameters or initial values, with one single call to \code{plot}. As an example we implement the simple combustion model, which can be found on \url{http://www.scholarpedia.org/article/Stiff_systems}: \[ y' = y^2 \cdot (1-y) \] The model is run with 4 different values of the initial conditions: $y = 0.01, 0.02, 0.03, 0.04$ and written to \code{deSolve} objects \code{out}, \code{out2}, \code{out3}, \code{out4}. <<>>= library(deSolve) combustion <- function (t, y, parms) list(y^2 * (1-y) ) @ <<>>= yini <- 0.01 times <- 0 : 200 @ <<>>= out <- ode(times = times, y = yini, parms = 0, func = combustion) out2 <- ode(times = times, y = yini*2, parms = 0, func = combustion) out3 <- ode(times = times, y = yini*3, parms = 0, func = combustion) out4 <- ode(times = times, y = yini*4, parms = 0, func = combustion) @ The different scenarios are plotted at once, and a suitable legend is written. <>= plot(out, out2, out3, out4, main = "combustion") legend("bottomright", lty = 1:4, col = 1:4, legend = 1:4, title = "yini*i") @ \setkeys{Gin}{width=\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Plotting 4 outputs in one figure} \label{fig:plotdeSolve} \end{figure} \subsection{Plotting Output with Observations} With the help of the optional argument \code{obs} it is possible to specify observed data that should be added to a \code{deSolve} plot. We exemplify this using the \code{ccl4model} in package \code{deSolve}. (see \code{?ccl4model} for what this is about). This model example has been implemented in compiled code. An observed data set is also available, called \code{ccl4data}. It contains toxicant concentrations in a chamber where rats were dosed with CCl4. <<>>= head(ccl4data) @ We select the data from animal ``A'': <<>>= obs <- subset (ccl4data, animal == "A", c(time, ChamberConc)) names(obs) <- c("time", "CP") head(obs) @ After assigning values to the parameters and providing initial conditions, the \code{ccl4model} can be run. We run the model three times, each time with a different value for the first parameter. Output is written to matrices \code{out} \code{out2}, and \code{out3}. <<>>= parms <- c(0.182, 4.0, 4.0, 0.08, 0.04, 0.74, 0.05, 0.15, 0.32, 16.17, 281.48, 13.3, 16.17, 5.487, 153.8, 0.04321671, 0.40272550, 951.46, 0.02, 1.0, 3.80000000) yini <- c(AI = 21, AAM = 0, AT = 0, AF = 0, AL = 0, CLT = 0, AM = 0) out <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = parms) par2 <- parms par2[1] <- 0.1 out2 <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = par2) par3 <- parms par3[1] <- 0.05 out3 <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = par3) @ We plot all these scenarios and the observed data at once: <>= plot(out, out2, out3, which = c("AI", "MASS", "CP"), col = c("black", "red", "green"), lwd = 2, obs = obs, obspar = list(pch = 18, col = "blue", cex = 1.2)) legend("topright", lty = c(1,2,3,NA), pch = c(NA, NA, NA, 18), col = c("black", "red", "green", "blue"), lwd = 2, legend = c("par1", "par2", "par3", "obs")) @ \setkeys{Gin}{width=\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Plotting output and observations in one figure} \label{fig:plotobs} \end{figure} If we do not select specific variables, then only the ones for which there are observed data are plotted. Assume we have measured the total mass at the end of day 6. We put this in a second data set: <<>>= obs2 <- data.frame(time = 6, MASS = 12) obs2 @ then we plot the data together with the three model runs as follows: <>= plot(out, out2, out3, lwd = 2, obs = list(obs, obs2), obspar = list(pch = c(16, 18), col = c("blue", "black"), cex = c(1.2 , 2)) ) @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Plotting variables in common with observations} \label{fig:plotobs2} \end{figure} \subsection{Plotting Summary Histograms} The \code{hist} function plots the histogram for each variable; all plot parameters can be set individually (here for \code{col}). To generate the next plot, we overrule the default \code{mfrow} setting which would plot the figures in 3 rows and 3 columns (and hence plot one figure in isolation) <>= hist(out, col = grey(seq(0, 1, by = 0.1)), mfrow = c(3, 4)) @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Plotting histograms of all output variables} \label{fig:plothist} \end{figure} \subsection{Plotting multi-dimensional output} The \code{image} function plots time versus x images for models solved with \code{ode.1D}, or generates x-y plots for models solved with \code{ode.2D}. \subsubsection{1-D model output} We exemplify its use by means of a Lotka-Volterra model, implemented in 1-D. The model describes a predator and its prey diffusing on a flat surface and in concentric circles. This is a 1-D model, solved in the cylindrical coordinate system. Note that it is simpler to implement this model in R-package \code{ReacTran} \citep{ReacTran}. <>= options(prompt = " ") options(continue = " ") @ We start by defining the derivative function <<>>= lvmod <- function (time, state, parms, N, rr, ri, dr, dri) { with (as.list(parms), { PREY <- state[1:N] PRED <- state[(N+1):(2*N)] ## Fluxes due to diffusion ## at internal and external boundaries: zero gradient FluxPrey <- -Da * diff(c(PREY[1], PREY, PREY[N]))/dri FluxPred <- -Da * diff(c(PRED[1], PRED, PRED[N]))/dri ## Biology: Lotka-Volterra model Ingestion <- rIng * PREY * PRED GrowthPrey <- rGrow * PREY * (1-PREY/cap) MortPredator <- rMort * PRED ## Rate of change = Flux gradient + Biology dPREY <- -diff(ri * FluxPrey)/rr/dr + GrowthPrey - Ingestion dPRED <- -diff(ri * FluxPred)/rr/dr + Ingestion * assEff - MortPredator return (list(c(dPREY, dPRED))) }) } @ <>= options(prompt = " ") options(continue = " ") @ Then we define the parameters, which we put in a list <<>>= R <- 20 # total radius of surface, m N <- 100 # 100 concentric circles dr <- R/N # thickness of each layer r <- seq(dr/2,by = dr,len = N) # distance of center to mid-layer ri <- seq(0,by = dr,len = N+1) # distance to layer interface dri <- dr # dispersion distances parms <- c(Da = 0.05, # m2/d, dispersion coefficient rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of pred assEff = 0.5, # -, assimilation efficiency cap = 10) # density, carrying capacity @ After defining initial conditions, the model is solved with routine \code{ode.1D} <<>>= state <- rep(0, 2 * N) state[1] <- state[N + 1] <- 10 times <- seq(0, 200, by = 1) # output wanted at these time intervals print(system.time( out <- ode.1D(y = state, times = times, func = lvmod, parms = parms, nspec = 2, names = c("PREY", "PRED"), N = N, rr = r, ri = ri, dr = dr, dri = dri) )) @ The \code{summary} method provides summaries for both 1-dimensional state variables: <<>>= summary(out) @ while the S3-method \code{subset} can be used to extract only specific values of the variables: <<>>= p10 <- subset(out, select = "PREY", subset = time == 10) head(p10, n = 5) @ We first plot both 1-dimensional state variables at once; we specify that the figures are arranged in two rows, and 2 columns; when we call \code{image}, we overrule the default mfrow setting (\code{mfrow = NULL}). Next we plot "PREY" again, once with the default xlim and ylim, and next zooming in. Note that xlim and ylim are a list here. When we call \code{image} for the second time, we overrule the default \code{mfrow} setting by specifying (\code{mfrow = NULL}). %% This is done offline. %%<>= \begin{verbatim} image(out, grid = r, mfrow = c(2, 2), method = "persp", border = NA, ticktype = "detailed", legend = TRUE) image(out, grid = r, which = c("PREY", "PREY"), mfrow = NULL, xlim = list(NULL, c(0, 10)), ylim = list(NULL, c(0, 5)), add.contour = c(FALSE, TRUE)) \end{verbatim} %%@ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} %%<>= %%<> %%@ \includegraphics{image1D.png} \end{center} \caption{image plots} \label{fig:plotimg} \end{figure} \subsubsection{2-D model output} When using \code{image} with a 2-D model, then the 2-D values at all output times will be plotted. Sometimes we want only output at a specific time value. We then use \proglang{S3}-method \code{subset} to extract 2-D variables at suitable time-values and use \proglang{R}'s \code{image}, \code{filled.contour} or \code{contour} method to depict them. Consider the very simple 2-D model (100*100), containing just 1-st order consumption, at a rate \code{r_x2y2}, where \code{r_x2y2} depends on the position along the grid. First the derivative function is defined: <<>>= Simple2D <- function(t, Y, par) { y <- matrix(nrow = nx, ncol = ny, data = Y) # vector to 2-D matrix dY <- - r_x2y2 * y # consumption return(list(dY)) } @ Then the grid is created, and the consumption rate made a function of grid position (\code{outer}). <<>>= dy <- dx <- 1 # grid size nx <- ny <- 100 x <- seq (dx/2, by = dx, len = nx) y <- seq (dy/2, by = dy, len = ny) # in each grid cell: consumption depending on position r_x2y2 <- outer(x, y, FUN=function(x,y) ((x-50)^2 + (y-50)^2)*1e-4) @ After defining the initial values, the model is solved using solver \code{ode.2D}. We use Runge-Kutta method \code{ode45}. <<>>= C <- matrix(nrow = nx, ncol = ny, 1) ODE3 <- ode.2D(y = C, times = 1:100, func = Simple2D, parms = NULL, dimens = c(nx, ny), names = "C", method = "ode45") @ We print a summary, and extract the 2-D variable at \code{time = 50} <<>>= summary(ODE3) t50 <- matrix(nrow = nx, ncol = ny, data = subset(ODE3, select = "C", subset = (time == 50))) @ We use function \code{contour} to plot both the consumption rate and the values of the state variables at \code{time = 50}. <>= par(mfrow = c(1, 2)) contour(x, y, r_x2y2, main = "consumption") contour(x, y, t50, main = "Y(t = 50)") @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Contour plot of 2-D variables} \label{fig:twoD} \end{figure} \clearpage \section{Troubleshooting} \subsection{Avoiding numerical errors} The solvers from \pkg{ODEPACK} should be first choice for any problem and the defaults of the control parameters are reasonable for many practical problems. However, there are cases where they may give dubious results. Consider the following Lotka-Volterra type of model: <<>>= PCmod <- function(t, x, parms) { with(as.list(c(parms, x)), { dP <- c*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dP, dC) list(res) }) } @ and with the following (biologically not very realistic)% \footnote{they are not realistic because producers grow unlimited with a high rate and consumers with 100 \% efficiency} parameter values: <<>>= parms <- c(c = 10, d = 0.1, e = 0.1, f = 0.1) @ After specification of initial conditions and output times, the model is solved -- using \code{lsoda}: <<>>= xstart <- c(P = 0.5, C = 1) times <- seq(0, 200, 0.1) out <- ode(y = xstart, times = times, func = PCmod, parms = parms) tail(out) @ We see that the simulation was stopped before reaching the final simulation time and both producers and consumer values may have negative values. What has happened? Being an implicit method, \code{lsoda} generates very small negative values for producers, from day 40 on; these negative values, small at first grow in magnitude until they become infinite or even NaNs (not a number). This is because the model equations are not intended to be used with negative numbers, as negative concentrations are not realistic. A quick-and-dirty solution is to reduce the maximum time step to a considerably small value (e.g. \code{hmax = 0.02} which, of course, reduces computational efficiency. However, a much better solution is to think about the reason of the failure, i.e in our case the \textbf{absolute} accuracy because the states can reach very small absolute values. Therefore, it helps here to reduce \code{atol} to a very small number or even to zero: <<>>= out <- ode(y = xstart,times = times, func = PCmod, parms = parms, atol = 0) matplot(out[,1], out[,2:3], type = "l", xlab = "time", ylab = "Producer, Consumer") @ It is, of course, not possible to set both, \code{atol} and \code{rtol} simultaneously to zero. As we see from this example, it is always a good idea to test simulation results for plausibility. This can be done by theoretical considerations or by comparing the outcome of different ODE solvers and parametrizations. \subsection{Checking model specification} If a model outcome is obviously unrealistic or one of the \ds functions complains about numerical problems it is even more likely that the ``numerical problem'' is in fact a result of an unrealistic model or a programming error. In such cases, playing with solver parameters will not help. Here are some common mistakes we observed in our models and the codes of our students: \begin{itemize} \item The function with the model definition must return a list with the derivatives of all state variables in correct order (and optionally some global values). Check if the number and order of your states is identical in the initial states \code{y} passed to the solver, in the assignments within your model equations and in the returned values. Check also whether the return value is the last statement of your model definition. \item The order of function arguments in the model definition is \code{t, y, parms, ...}. This order is strictly fixed, so that the \ds solvers can pass their data, but naming is flexible and can be adapted to your needs, e.g. \code{time, init, params}. Note also that all three arguments must be given, even if \code{t} is not used in your model. \item Mixing of variable names: if you use the \code{with()}-construction explained above, you must ensure to avoid naming conflicts between parameters (\code{parms}) and state variables (\code{y}). \end{itemize} The solvers included in package \ds are thorougly tested, however they come with \textbf{no warranty} and the user is solely responsible for their correct application. If you encounter unexpected behavior, first check your model and read the documentation. If this doesn't help, feel free to ask a question to an appropriate mailing list, e.g. \url{r-help@r-project.org} or, more specific, \url{r-sig-dynamic-models@r-project.org}. \subsection{Making sense of deSolve's error messages} As many of \pkg{deSolve}'s functions are wrappers around existing \proglang{FORTRAN} codes, the warning and error messages are derived from these codes. Whereas these codes are highly robust, well tested, and efficient, they are not always as user-friendly as we would like. Especially some of the warnings/error messages may appear to be difficult to understand. Consider the first example on the \code{ode} function: <<>>= LVmod <- function(Time, State, Pars) { with(as.list(c(State, Pars)), { Ingestion <- rIng * Prey * Predator GrowthPrey <- rGrow * Prey * (1 - Prey/K) MortPredator <- rMort * Predator dPrey <- GrowthPrey - Ingestion dPredator <- Ingestion * assEff - MortPredator return(list(c(dPrey, dPredator))) }) } pars <- c(rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of predator assEff = 0.5, # -, assimilation efficiency K = 10) # mmol/m3, carrying capacity yini <- c(Prey = 1, Predator = 2) times <- seq(0, 200, by = 1) out <- ode(func = LVmod, y = yini, parms = pars, times = times) @ This model is easily solved by the default integration method, \code{lsoda}. Now we change one of the parameters to an unrealistic value: \code{rIng} is set to $100$. This means that the predator ingests 100 times its own body-weight per day if there are plenty of prey. Needless to say that this is very unhealthy, if not lethal. Also, \code{lsoda} cannot solve the model anymore. Thus, if we try: <>= pars["rIng"] <- 100 out2 <- ode(func = LVmod, y = yini, parms = pars, times = times) @ A lot of seemingly incomprehensible messages will be written to the screen. We repeat the latter part of them: \begin{verbatim} DLSODA- Warning..Internal T (=R1) and H (=R2) are such that in the machine, T + H = T on the next step (H = step size). Solver will continue anyway. In above message, R1 = 53.4272, R2 = 2.44876e-15 DLSODA- Above warning has been issued I1 times. It will not be issued again for this problem. In above message, I1 = 10 DLSODA- At current T (=R1), MXSTEP (=I1) steps taken on this call before reaching TOUT In above message, I1 = 5000 In above message, R1 = 53.4272 Warning messages: 1: In lsoda(y, times, func, parms, ...) : an excessive amount of work (> maxsteps ) was done, but integration was not successful - increase maxsteps 2: In lsoda(y, times, func, parms, ...) : Returning early. Results are accurate, as far as they go \end{verbatim} The first sentence tells us that at T = 53.4272, the solver used a step size H = 2.44876e-15. This step size is so small that it cannot tell the difference between T and T + H. Nevertheless, the solver tried again. The second sentence tells that, as this warning has been occurring 10 times, it will not be outputted again. As expected, this error did not go away, so soon the maximal number of steps (5000) has been exceeded. This is indeed what the next message is about: The third sentence tells that at T = 53.4272, maxstep = 5000 steps have been done. The one before last message tells why the solver returned prematurely, and suggests a solution. Simply increasing maxsteps will not work and it makes more sense to first see if the output tells what happens: <>= plot(out2, type = "l", lwd = 2, main = "corrupt Lotka-Volterra model") @ You may, of course, consider to use another solver: <>= pars["rIng"] <- 100 out3 <- ode(func = LVmod, y = yini, parms = pars, times = times, method = "ode45", atol = 1e-14, rtol = 1e-14) @ but don't forget to think about this too and, for example, increase simulation time to 1000 and try different values of \code{atol} and \code{rtol}. We leave this open as an exercise to the reader. \setkeys{Gin}{width=\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A model that cannot be solved correctly} \label{fig:err} \end{figure} \clearpage %\section{Function overview} \begin{table*}[b] \caption{Summary of the functions that solve differential equations}\label{tb:rs} \centering \begin{tabular}{p{.15\textwidth}p{.75\textwidth}}\hline \rule[-3mm]{0mm}{8mm} Function &Description\\ \hline \hline \code{ode} & integrates systems of ordinary differential equations, assumes a full, banded or arbitrary sparse Jacobian \\ \hline \code{ode.1D} & integrates systems of ODEs resulting from 1-dimensional reaction-transport problems \\ \hline \code{ode.2D} & integrates systems of ODEs resulting from 2-dimensional reaction-transport problems \\ \hline \code{ode.3D} & integrates systems of ODEs resulting from 3-dimensional reaction-transport problems \\ \hline \code{ode.band} & integrates systems of ODEs resulting from unicomponent 1-dimensional reaction-transport problems \\ \hline \code{dede} & integrates systems of delay differential equations \\ \hline \code{daspk} & solves systems of differential algebraic equations, assumes a full or banded Jacobian \\ \hline \code{radau} & solves systems of ordinary or differential algebraic equations, assumes a full or banded Jacobian; includes a root solving procedure \\ \hline \code{lsoda} & integrates ODEs, automatically chooses method for stiff or non-stiff problems, assumes a full or banded Jacobian \\ \hline \code{lsodar} & same as \code{lsoda}, but includes a root-solving procedure \\ \hline \code{lsode} or \code{vode} & integrates ODEs, user must specify if stiff or non-stiff assumes a full or banded Jacobian; Note that, as from version 1.7, \code{lsode} includes a root finding procedure, similar to \code{lsodar}. \\ \hline \code{lsodes} & integrates ODEs, using stiff method and assuming an arbitrary sparse Jacobian. Note that, as from version 1.7, \code{lsodes} includes a root finding procedure, similar to \code{lsodar} \\ \hline \code{rk} & integrates ODEs, using Runge-Kutta methods (includes Runge-Kutta 4 and Euler as special cases) \\ \hline \code{rk4} & integrates ODEs, using the classical Runge-Kutta 4th order method (special code with less options than \code{rk}) \\ \hline \code{euler} & integrates ODEs, using Euler's method (special code with less options than \code{rk}) \\ \hline \code{zvode} & integrates ODEs composed of complex numbers, full, banded, stiff or nonstiff \\ \hline \hline \end{tabular} \end{table*} \begin{table*}[b] \caption{Meaning of the integer return parameters in the different integration routines. If \code{out} is the output matrix, then this vector can be retrieved by function \code{attributes(out)\$istate}; its contents is displayed by function \code{diagnostics(out)}. Note that the number of function evaluations, is without the extra evaluations needed to generate the output for the ordinary variables. } \centering \begin{tabular}{p{.05\textwidth}p{.95\textwidth}}\hline \rule[-3mm]{0mm}{8mm} Nr &Description\\ \hline \hline 1 & the return flag; the conditions under which the last call to the solver returned. For \code{lsoda, lsodar, lsode, lsodes, vode, rk, rk4, euler} these are: 2: the solver was successful, -1: excess work done, -2: excess accuracy requested, -3: illegal input detected, -4: repeated error test failures, -5: repeated convergence failures, -6: error weight became zero \\ \hline 2 & the number of steps taken for the problem so far\\ \hline 3 & the number of function evaluations for the problem so far\\ \hline 4 & the number of Jacobian evaluations so far\\ \hline 5 & the method order last used (successfully)\\ \hline 6 & the order of the method to be attempted on the next step\\ \hline 7 & If return flag = -4,-5: the largest component in the error vector\\ \hline 8 & the length of the real work array actually required. (\proglang{FORTRAN} code)\\ \hline 9 & the length of the integer work array actually required. (\proglang{FORTRAN} code)\\ \hline 10 & the number of matrix LU decompositions so far\\ \hline 11 & the number of nonlinear (Newton) iterations so far\\ \hline 12 & the number of convergence failures of the solver so far\\ \hline 13 & the number of error test failures of the integrator so far\\ \hline 14 & the number of Jacobian evaluations and LU decompositions so far\\ \hline 15 & the method indicator for the last succesful step, 1 = adams (nonstiff), 2 = bdf (stiff)\\ \hline 17 & the number of nonzero elements in the sparse Jacobian\\ \hline 18 & the current method indicator to be attempted on the next step, 1 = adams (nonstiff), 2 = bdf (stiff)\\ \hline 19 & the number of convergence failures of the linear iteration so far\\ \hline \hline \end{tabular} \end{table*} \begin{table*}[b] \caption{Meaning of the double precision return parameters in the different integration routines. If \code{out} is the output matrix, then this vector can be retrieved by function \code{attributes(out)\$rstate}; its contents is displayed by function \code{diagnostics(out)}} \centering \begin{tabular}{p{.05\textwidth}p{.95\textwidth}}\hline \rule[-3mm]{0mm}{8mm} Nr &Description\\ \hline \hline 1 & the step size in t last used (successfully)\\ \hline 2 & the step size to be attempted on the next step\\ \hline 3 & the current value of the independent variable which the solver has actually reached\\ \hline 4 & a tolerance scale factor, greater than 1.0, computed when a request for too much accuracy was detected\\ \hline 5 & the value of t at the time of the last method switch, if any (only \code{lsoda, lsodar}) \\ \hline \hline \end{tabular} \end{table*} %% this adds References to the PDF-Index without adding an obsolete section \phantomsection \addcontentsline{toc}{section}{References} \bibliography{integration} \end{document} deSolve/vignettes/image1D.png0000644000176000001440000010735213136461014015677 0ustar ripleyusersPNG  IHDRs?PLTEψ 0ͤ֙GI!EԞVPVDFhΩi(ms L7)п5SI j2eP/Ӧ2n0\u$Y)G$3y 0G)]h̀yԚ dF7K4f 'N x(hy!XX8t$L͸4 x!j-82I2 ݑj!f7h,g(XGW: (.w|NwrKlLʌ0׵"qPYƱj'7uX< ^Py40ؖ0(OKg?U7dؚ4۲׹OX[8*!xX\gtpر|g6#6Y:P k0/Jz0X/E[Nhi.2)!,?*VV/10NG. 06).uӟsqp+'x-ݱkt9ѹX#xDj<Lp\-YjiaJwiɟޣS IDATx|TS5HJMJ1LF&0ɐB84n "﷥u{c^MkEkCfq%`nsB?L&syw3'gf|>$t>Xh6̙~z h2 TӕMAdEL#[cY&_Ja!>r<Th }ih2@ˁE$ ڇPF,7Db*뫪ʡק:%I*K*u߼oT h,Xb@ӫ$Sթ؝dh2 п:& -Lb@PAzӝoſ+$&O|ҡ\J/Q|P!4>T:,r:[^i }*lZZz׿^C P7ܳ{&{ƫ}>1=;i?]R~PUsUzP}UU[A/JUg cWhvlb|ccK2t܃kEB}nu:9+=kkΪ歰$` ND%Xi :1q\)l.9v Os I}@Rֱfջg@>uh '<Kѹ7(ti& @ұ*hr:6 Md"*GO^~z'$tcI`#MƟ.}gͅY+h$Tt(estչ)QЩw!47g}_@#+~uݙ3̀RIn'p"mD :^|6  3x?6wJ"m6woB@PAxMzLܹSuYYce?$&|)g RYccgFp_z :2XB>1VWoлݙo:Uˤ? Lɗ|2ٝ0[ |{l{TYYWG` 6`zrtʌ W6vϘm4)huuII 毺 +s%@#iey,ҡl^.!@AgmAm7$A : [hB-?Rg[.> _^~u wXo+MO%{dP_=3 {cO&27ql :}rt膫Fܵa9wJP=Q 9 $t zs~IԪ^OW?yzzrd[+[;nINLa¡cto@G6]U#  ÕulItp :24&OW nilw5 DGs^3O{"OX F585Zz D~֡ (g O]AЕr 5@LN WOB}s@\81KvV^Y>pt 4CH>ATj1[$Aɉ^s (sYFiZhŖR(h#<h',=?.F`;ApPJ'%oFwOeO Сq+arbv!t_`XЬ;x%{=Ã8ԳuϵkRИ<b.AQTRRRh[ {ZoB|̶O]? :OMʟ.qe3ψ Q8fdd䞃7TS-k~;`L7rGO:7ӐO[Mʟ9G7 ~ mD'`.Yۖ {PyT~ vi~@l2nZ4䳧b5 &W_.`atqzD5XAKnه ϙrއDjh蕇 >|i-;#BFF_\şz l nՃ N VB@Z+ aQjZZD][@c^Z-z'.n0s?<Awԯh=3VO8נ=;e =XF~v-|]@L϶^fմqs-8΅@G~΂ sݿ?#yީ?Vj8 Ax'G'vJg@AetztT6OKRf }u(>Q} ౳*x{?=Aѹ% )% K#t*2an}bweA-ө݅9x0g СCrV;#ÀI0I[磑*~E }IXAA]jN#!@~7y~ :Ӵzptt}FӧѶdUGfT9>;mө :v BB<\kٙm h[[ۻS=x =oN> >aV]?PCu@"] :<|C'=p~/(+IЭh?YmuC}]}yTﳛ>j)0h,T$4Nz^$UjB؁4j h^69]i:;⽷Cn[jE-FxBiih:@E^>iC{>8L в<϶ҩ: p89:b'.d >LGL1䱆ޟ)T ?‘= EjG|@5\@a!yTOڌ1Kt iE Jf1Z(ڝ|:@4BA WVVt&NԿY`vQ|{q61g]] *m 6, yLXOWw:yZd* uh'<񨳳b :gB|56<ռ;ы42H g%s~S2KAKM@k2x<}y$tedd;#X*Wt]c>^񿫓hgBc>q4oGZmjh?lZaOx #w =wgMM4DGO"@#:@F[ӋzƢ)e- s\{*֚lc)HmA h/z+l5X C|m-?) @#G@dShY䂱SFiCD'::BpIvn}ʃE46O< ]:4SQaBJMP?˨7r\uIʤN(\2Wqe?;u$Df'tluD|ĮJW$ł%&~t, {xePp<0h/A (% ntO $ȥK,ə-\?hQ4UK`'wEq PqL++cCPԄZbI+Nu劎tR7!>? 25Z'd<^jX?hZwL@lYwX_ p{y~h (L=M"IJMԾ|퉂&Ol~rH]T|3f79hlZe<*g 4Njtu .t k {KҼRh>DI'䓉&.sh]T|dãl@/{u̩|F\L NX|*x^18Ѥբ++5~l_b5' z𚖤O]k4:9ԍ;?#fWRdѮdvQ&Z<2B :>l(hOZ{ԉfD Zڗ*J όA>Cw&:]!'5;)={AcϳXA;a|gmm- iˆ'uPS/FРNbjA:**3wxtpħx%.ttt2ꂙ#\񧛀sί휉H(6A\E L4 (֯w"4w5#>-!>?f&rZZ>xzbF?c*@4%} OFm:B 1\[R9VNvUWOl9x -1gK:Z?g0Y}-44/ل?ktw2eRK)?Z$x;9h}9'ػT8=`8G٠|7)VG@>jЀUYZ`TŅ j=:I?.x[MtrPb-Hmm'k+LzD ~/n3-{4E$dlJ!܎ԟ4$.ͿƯWd ɦqeZKܒ)7d$hLE"?]`&HRKm>;޼2PwP}dAj(18 I $ef'mqiwjQw&u^i{c5 IDATkFe?cww>T$I1B5kg֚Bk771QjGRmݵIȟ'mqR2Op7gQ]G[{v`=?y8[;L5H ^< ;ܥk~@55AOJ:35V |#;[g%E6VP̨dsvM^<00АҿxxصߓgU OƄlώG(pzԸODG5fYVI u Aܧ)]X'? :[yo9k󀆖!)& `9›S3S{Rt Pl?Dwt̓ چ{7axifdW@Yy+}6})&6>33*1wZ@V/hl8w< ^hM@u(j#欠GVAu|R"oO9 2%P!S: {v*((ܟPA|Rq*yL1NJvi %x>vgY~v^i^v^ⳬ&_d(($VP(x#dR@Vޛ}oAY6|Ggo3KH,LJkx\~_[䠥m `. L`zPD?tymٸ/Yӄ` @xƹty*([1Imp^^/uJ@A@*׶/e|GRj3wJ@Vf>/^ti.47CqQ8ukHEGS{)5<fKl4K첼|ZL'(P]JoؒgeҶZ8{]S>< :gpR)NrOCYչ C5QqNAM@oiKK/@ܨ7 |t;tPH/5Ch(!MD˟不 ZF&ж_&0+F~i(7/ hF t3B |Iӭ9G]WT)h1z>wsgOAhgKz'D (,o J跀 ]j{>7PXg,O}6켦KmyL5N/l|ІB{)%wK {/-Bx'4#wbPg $l1VƵd./!eеe`9=q{bFV!Rjj{qӓ{G:P[iɞ?]xh>TP~QkƛRSR['!'Л/<. a}D@1 fǀ])?#5њ( KAS?L#͓PB p$>l(|W{&l@Kw.e@#_<"rQs|xDi%H3ߕ vD@.=Yc:sA9.t[t[A6roqQCV-@utA!O}_PiBq%ؽb(%X?V`07a@ŧy.=hGx"&\uRG<>OG.[)1;>4^$ b@#PXl/#GqOtb }#hK\&y)Gb,@zRcȒU'!Q$F =Q"R]((wħYwHzj{B`  & h/PۏQO;[*E¢ގ2Od"{m50{В+';t9 O&B{JbnxtO L@CgOŖ?]2ѢA 5M|0gNn{AMwpWR$_xzٽrџnƴh2??Ur0o^Q9Xz n!nO7|L玽 (CWbu$>_01xkjaOLğ.J厽(DϹOL҄1 n~4ϵ'#ŸyLh6U4p1MޡFCqey۾yԷ2wEOjd,MhCC 2SPvG_Bڎ!OsMv_ǀ!)w6)47Xz"Kcf$sP"gZ#1>??n/Q,s EԨ}/~[lpR9vNc1>;ɜl3nxȔ PA 8?=4Isq㒜4,- q 89-m֬@77#ʱO. @a0Ù&P TFXX.Z$I ez'pS/&O/ K?rh8g i|pKD`Hd|CC+Ȥ\.  i2H?=duY|-dEG"&I/B&Sh@<,AKءaOBG˟4-}] P]'=  hZ%a82iBGΟiRi pX@?tNl;t ÖqΡlS?]4OHl7< LOh,۱Xޱ/P&ySvv4KƟ L{p~8MbS|4#e^Z[x;MTAck?/&<c4&SKYHUơsT8ԗ+}7ilooC?}qbn9 &vn@?lP|#>ۥ%Gџ~jl*.}Q4SN !)->t`r-0 SoX>^ e9Ppz4ܻ+M?{޻gПRً63qkl26)nftL׌˾R4{e>ڡ&mП4C&7wmZ4e'lR6 )^3$ɽR4{eɏHڐ$MCJ[ʔaS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLja#4sCvr / mĦ?e؇8FpLnM?^b'bq*c+a˟rELPmzSiqs&㉿{9}lzS݈e|I&lzSaln9a#emzSa2m\Zo˟G :.COY#&m$M/ʲ1w!COYC2)@Im PeRTԦU&)@Im PeRTԦU&)@Im PeRTԦU&)@Im PeRTԦU&)@Im PeR[R'(S%H\LU&f_43dSIlI͛7w E"#-U6nBZ2ݱcQ.3 \w{<n{z曟#]]G]Ў#]`%^s2נߣ*QrkQUgG~G :%NW(xE$,tΚzj3kVſӳs2m`@FkѠu ӃJ7ҍ:ZgQ݈|f].:%NW[tUơZ8_6i=  pf4}"Z׃k@h 909ހ^)VhNldlE|&#eɐi:t\&ί$F<&^LE =5Yfˏn8UeZX_Wo0@A1QJs,Hu;B.d{ qsJ9~=OMTs^;-&$̲:u}o·"U>?0 6#WA:-\J{]KZF ;e!>O$e"CC]cWGWZoYӗòybGsP* 2YXjd{1ګ`RAG-98>&3_9AB{ʽ$!&TP5c5~wg!Wo[^hW\0t`8 JhEjogx^T׃f,anh4¥qt4u˨agN=ˡ10BWY_.4Y^Y) zRBZBUFVgՒRUR WJ1|k=rNvGỒx2o 3NlsCAc99䮇BO}k Mo^qյt+RA( 5TsP" uB ^AE z^MћXf m*(QkX}kUFRЬ{.؀2!h MC^ *A{!蓂:A>c. >|m,f^t칂 <Y-ﾻjd:tf׾ ,@ћQs*y5ӹxξ=f~Hqs YNA4}|PPj3S'C 54kt3jj&zL(U㈁Ȩo[{e#6OM9s'$?:nO$AAjG>êB~ k(!AgmF< td/cw;(/c|"/&`tZ~.S_?'uϵ|wEY_qA-ᣘ(D gQa*j,aG $>bs(/Dԟ:Ǿބ,&~*(*_ͨ[At`m{SbVu*(m$ݣzG _`c\^u6(;urQS R#L;oڼ Q AH1#K=$O0MAxNœMcgAB#Gn{OUu->GxhU>x^PP!vS GaZ\ԇ?vOl&:"hx91YWo;x1>ݍ6(c |-J.uF͢,E2k;F)rN25o.b2>@潂"5Zo6ML^X|&HDcAL:h9"ɡ!g-huCOL&<?i"ײY^l}RPz#\ ]?m oW4jQ'J.b'JZbފߗ$qxR7j,Bo;L"Po(p[Nݺݓ+ %RiuliisP5ߤOhuc;(Tj2?/OefD =IVA9Fm˭~ۖ_c AQ!U/Ȭ&tjUix=Qe$O4F)^i"|I|I-ttuLA t_ ZFyD9*!jLwExЄb< /&Q 9(=0O^)(U($-tΛnXJxt9f7yF:UfD/o}PP freT 9(7g:tw3\9(ص?G mEF dZ&@R9Sk\Je0bZ}U\=$*[K4~2ShIh} }; IDAT_hk)%qōl " Z:eatKc{gR &qQ Hk|H2M\8-M&9e5E͝_XuۏˏZD @FPfzVUҲxS$E[ ÿ}G^VVŖg4p~h,=ӯ~ N j* Ruج/e1d]+ 2M8r(\41!/l[l0,?U&g \{Z>߬᫖Tq8?.@ @ڜ6%f *LoQKFt"%X/1Lj&Eb%¢P7xg ՞$ݎ/F.Ћ9Fz.F./uP( _jtm$-Ք?d9^|&k3um;hXeF7Eky&PhJE4`fQ429|S}'Ye#0PD=^KôF4vE›̾qݑҳ:7[H/޸Ѧt#(mu?n>""1j 1A"lTiN1@,=?#<P=aԐ{uċ}ǂܚ'[̡/^\bR@mFhW*Ӥd}2[K~f"ɳG>ˡn?%ILz(2~!}0L:o)/ZcKNX)э֔ɑv$(7(YXسOԎܢQ,ɢo_ѵ|mG@GQvzAYQ!T}} !1=}ֿjqxv>Y.gk0èXQ}K\Il]D/;1b[e~|/cq|!|!yWnѸHqʻ|s/uS*l>Qf5'(/17UPV.(Ư*:ܙme?j ݽcGM[>ޢH"u U<{oٗΔ|~r(DQ;s͠ru9)ò0F:|;ԩ6 SLmiyEXdx)z^*(PKA@_rs+f@D*JޔUZ"l^)z3=\RHFoo=Ьy4+4C<bO=kxS222<ѯ6F}aD OURgAm(h=Nb%>/t Yh^MzKD~.  Wft5B<9 O_-|,NA?`Mٜl/QR˧ƎT-e7[ tAD1y4o`ư%0&'zved}\wWœ29E`!|~ d# F&RHeR97c9x/?#~B0E^vN͹l6ykP54d ?3o-:ݴ ,x\(o.7YޘS8%ړ(,a3O9HD 7bSV?E2 S'^nZab S~ӻǎ ,-mz@٣ȁ_݉NV~c j5aF0e9"$ƖPKg5W (v1#$m 55 4삥Zg@ G ZxqK9[s$]Vj9nX盤Q_t]Nz%RTW6sNu7&_nC3ژL(gB #Zp' %|cgfppMPOK^JnpH i M`%LoW \Vc"wFX jrPThhB:׭{pʡܟq|#ybzZz{NPFӢ\ڍO'պJA Q.QzcKZ%珌5QxLryXwis޼u_z^l9.5bzD9 1TKDbZKɰo+Mltg%E`2nI5|'KzKiL{\0Bh.(hoo7ٟqKY7/_OdJ$/xZ|ܲ Ow8R,1ľ0;4{< )pgKKl-m^|k{֟ r M@uc]+f*'I#<,&Dd*(:&&#quJHclHq:dRN3Zd{g߸pA G?z#:ye՜&{Zb=JNZK6L |S蜧/-&lDN*:?(Uv%܆zl>i-d[Ö0|xWϾ1Bmmgr9(}jZcΉ7س}uxsZr>;UDoU&zJIPKy*|.qƽu0dhthc DtֶOyP[ Wn2s'9O,ٲLLZZk"!}tJ%KxfljF*ԞCUͬ"aFxkH56}pffM>ӧ73f-[Er*쇂r!ᥥFtq ks=H&RčTHHN¾NQT((#x!;4YDBɖ Z񞟿{+) 'gkzwKGNNQQΪUOSS3;@;TcNɶ#1 )h6E9U2ӯ0 0R,MiɍEiJH6;Ex%fcw{z lݺcv?xsUWC {*i]ŃnneH;_Xrm&ݘ]4F-b<&%(Դ뱳o & j/ΙpHgnx^ 6ON3`WK 4eζGAzZkH7uAC,E :)(M$,؏|P. :bL+sA!UpS@[1uG3%d,\{ZoGOB 7;Dt\aO-Ax^o5 4>閬ɸ^2xۛP7cU-[V:rrڀ+?iOyLPO߶\&pE814ʭ D GCYy|~1S;cP{ cq*:cP4x- ctDws쬓>CGwF#o#ƺYbrGrՠUד5ۣlurlVϋ-L 4Vf7A!P-Pf?*Պ?/]7t^Ӻgݺyֽu𞢜7 Pvo {BI opÍNBνjrXLо~Ḿ[jYHI"nd"U&+%$v>WO9@D*HEY5C\8_(BraQn8(={=;;={~v}%%%{,ڳXVqp㌱c˗;ul; 1.~mˍz 4@Ufx,үP[#t$~WP rJLΕ26leŐk΢\ԭch;Rv]W5X].3Ʋn]uXV*Pch[ZszXqIfZ`PPRd':Iů?9dkEۈ *{@50D^t([4 3C(xN4, govݶqW]vn=;W 0Pɦ$?tg[/S滱`Vg4HiڀJkGsSgoK|wO!4x9:!iw@>\<.cwÄ́|%}zmxPO8~ ,>@>_|zCC}Nik u=.F=, l6BjiJZ=Iu$B"T wB/lo{ Pb(Onyc3 |B%>v=jDx؉bkr1GB}3pov&{F&8!SJO( mU+$dJF e1eTMAۈ Rd{;b hƅ Es--׿>gN8…Gι?P1OX<صĹsiٜKj<23~ťU@=A/ue"132 HFd%qTDHtVjJ3 (z^:c3)(D &#Iin5Mڲe59[e˖5kٜ;if{|q/\sǹ7Wy6EY^]5),.\s`:ƴPPYe2EYJW)(Ϭ }bpmtQu: P?aZsū./Fxv,;[ -.ԋ _AB)ZbϭNPQe'Q4k~֊=׋J %QZ1L&䥶/鿙YWPsXC"x O l#35~2QKnGog@>;Z[A [%3SoEc PPW@ꥂRY}(c|T_\~ͺG1q] EnCcQG]_O j}Β Vvv;kF?Fn^\5BlɺQQ| uM5޽t?`Mnnlh۷?e` ,lZ IDATdޕ{6N@Dnz1Ҳ_[z`yh_Wߺ6zRe[A-x!dyZOK3 dMNkŅ8d$U}1 jkiin%`2 ˲g>HnX2X=8dOobsV1kOA,_lsE(l ))lt7>($pPld)SNEԟ!z&>~o.&'iFgc<۷Å'۳wƒ]ϒpypz]ǗWQiXA7{59bC-HAcm{yFsj':f- Lɶ[)h*SICXjOVG ʧɧ=&]vgx"KOK2TЗY[;(Z]JZߥo>K_8ޚO$OfkȢ9Ydhm4JENI}?9SRQ&!Ƨ|>j,nxѭ'J%7nq]'fs+˫W|Oܑ$8n^׌Vлc`2%i`NmH^o"`xҧPO9$߄pBB,ɳ96MFigfnoBI&iۗX}UP9Q.Č[B h m‹7.Y۹s;O-zg͚5O9{oll{{Ͻs'^nn-]t܁ߟz;[oT94(q͝ vAVurK[i)u{o3hKMȜ'Dxqnwt{oM[SQQQlqQ dU,XmK^|`gA.ͻ_zjgz:"@oVPl?+x3-(%GݜĨyQ,g,_5}9!xT߼ fg$E՗9GTD-N3zQK!cX,ĸ ر3k6gf銎[B:W.Y82rsFFC }Y:+xVœ¿5|a}osz8`R[S>wWP3ZOl3=+22AKĨ4s x-[.eKn==7xz_j ^jNo6>HKM:WP{?,.}b{MPk K$3%-z3Jg  ]]\s1 ԣ@,m>>btSQIӫPC'o3ϜTl4Ѳ&jdmK2MecՉsg qѩ: k43!Z߬=]$.{uMMiђ%XV闬Z[A<8ru/^wG+ /0VA єaem|0(zI J[-6)J+dE%$z;oxa-R@nn֟>; Xr>]Ttپ}g,?ԛ(':y9hʫz I5Żꡀ¡ؗMrÓ>|1DvDf_ϑL"ӸEG~;4U:ӻDNM(5(ڛkBP{%8p=?Cݏ=dnXyh0Ϧne 5go‹xÑZ뫿Z:sn@]6![nDɸO*Z%ܦkv_*([œXUlӝvZA-JL{s`XD'`xT]YC{+{WoLB,Ϭ>wnD#~яYh&MK !U'X)PdNnIm&A`#2LOӮ47%ŒU)631S-BP;UWA(ozge?jxd +z|[a/4wX5!U$U*(<p^zg{*xNШh5&ޑeDoJX&$F9( 砬dr=l AށO-׀⽾J~'|g?_VDG+{|E|&1fG jq385LfѨc"bxý --8#>|l& gfmn,%oċ @ϜY3Fh7oLfd84rPOIYPf O,Ys-1ru=N Yx9$W qdj堺!~T^A 8RnK/!Sɖo.v֮]P|Kh%d˳v;gηd[9rꍟ*=<HA"n?@m8 $H: .apT7C2 $ ""ij_@ws[d6ɖ6m ~ܜkҥyΖk{zlYs򚞵=ɚEEɹgEo \tb՟݉?^u1 'B4s=PQz ~S)(|&T jILH%bUSP2ߴ;zZ?wI7*$]ȺL {7/2ݡ|S@Yslќ-ϵ[WVN $'Vp, K)Xh>dgqoުoR(>;ՎdIvK|n:}Mkl)|f s%{s׃D8|-bj'XA!q& *>{x:'C[m#GZ2$2 B:"ыd} ([ J["*@m}exR!SPF %\@Ao iv䜳Ek"<ٳ眈̹rKˡbb<-!ݹsYYA ( (=р/G^yb]u6cq.2gQy%(ZI%h>Щ?}QQ!^P'ĸPLG 4lh0W ]:Sz\<@A+.\mm@KPR=N'Nx` i3 s_XuVzBA0EZ޺K_X 0e)JA۲$z9LVYu[*%DӪ T'V4t +"82WL+s-i^5ӦNϞ G>O *఺ˋ.dωsiV6A)=ٸCVl.w0S==(뼯[I 4,V5$"UX(EZTk!E&ӌ۩;LfqGc%# #$C5bQ]Q$4菞νwEp߽{r_~＾/.n/bsF[Υ ZU'&չ+myİ{\3$*Yj' TPZ|L*1 1-P!ϟgch4Wjk7R5ξw'~=\PPpNKo\0LJҟCUrIUDPΦUL i6<$W2.z@Oއ,y/`P)C\Fvprƍ'sֶ]{eh/7|Ko^7^z1E2m^ꟺn\)ʹGuO;' {,X:I']]Rp773ƬUgƮS[IvL/-j3jD"eRĸsĪxd.=h*h"h ---C--廱|l0Ī_<5%(hĦwE?n!Y OG:CPQ~ nO+'J.s~r Ƥ^T-m$I+T *RvXU4$v})'QS ! zb툐#GƗAN6}$(mb VFPj ?)_ढ़U7O( S_DCAdP(ERPj6jVPV_壅*<$Y Fa0!CBpSM6aщG8E}to_:>޶mՅM:f>'7H̓gѷ _=ES$ަ9toLRʖԨT5J~VcNVXM AM~sgɀOyۤ7 y2p7!CVnJ*I5smgFʶ;斯4EU7!'iihX ScW%JGUF:.5L"/1p'?KRvdDe5<]Z!A`RfldB- ZwFκc%ٛ JEfe|p&HPmD;JRM *24] 'fO3E?UP/~Mz[Uo3:9:tHM'[3+o!$,Dm,eÁK]B?Sa 1 -<&"'ORAә:@JYYEWϮ=ک!+"Y[LǪ|?Y ~lONASou!iOL,e :trqF-8comh*mO%+fT?2Ctb91o(F7ꀨRe&>qu'"W^Fϝg 2:!Kx:J"$d;k9tLH>G_(Mo`BDT0yJX =׳_-|@˙I5fy2''MsₚnMT73Ѵ +t-^Nm'GͻG!AO^  Ha2 rD5d5|Ъ<"J'dPBb_wPAoZ]} Ĝ鎬kZiv\}0#շ1,S'__Q$'9AC-J{<PS &GHSj@R6JūJWd)!ūг**$z@жr8+v4W\6U~4˶M34AcNT3R첱mA=TReeZs\YxaJdXuV_Ԙ-ï| usjOR>nY`DdÑ[nZdF%5G]jI*9[Amkni|3|@oRPZsrQ aJA[jP[*UkJU(fW}P(+ f&'gG'Ugye\: H?oP~qyhF.KF FM ZGSA6;do{ mgeRIT>Ў4Ӣ!>A ]P6z$h) $n(SS2`7P/o~J)(q>|b3=~#{<6TtD.XҸ9B{SaNK.p/=gLޖTYoQ(3 ٴ ORmR2 geRIN\W:ŋO޺a`v μLN>G86:?#?&4N1$uD2^" ;?[\~b46((*Д]$"D_A^ ETo ]& vRrFS8bqdQU)H:3dv7`CG;s@|CCxr Ɂڬj,y˪PC+2V$ TTXDcm[la3v@~yt uIDATsiN3&@NSߪ_%,!k)U=xIANgܹ\ٶg`-LJw}g}~GN]2F` )) ]Þqk&ϺH3FAˑلy }tI1ud{k@N@Jv'w`T7ʢ$L_J2P MRAye&\PAi ϳ~ى)Coud!Cvэ26w b`I7oI1J,b:|?KAAzFb;_+ֈ0k\tBA=̏/4o NL;<#V.(UU4G&UDN!H D-^mhgMQ^HnMNI)C>%Vэ}  &^HA{0~wLP jZ0ȋH?Vlk($/c]-kK3CtSШa16GDx^dzHWIe2JYjQh ɼ1+=sڏ7sS?^'fዑO$ MXQ2 %":R1\GbzJstx #Ak#>hJvU#n+Jd((L/L<3OO|MPGi'h>:'{1<A+LN[Ë(:~b$7vu A1^)(QMXQTb ̬v˘W[#g̣D ڴUBACLA礋(j&4J#)*U1ʏTzr|w!͟Y;?~clޟIdXzס ڸYwZp W4 jߒb)h1Śa;pgJDz!ێsNG{Fw Qޑɸk{]9]]afy<1? LPRLT <O?}[;ΜY5zfzзuy GX-v{J?'ɦ@+QY$l"ef`h$ݐ>|dDbc(6_ذ'BecT_Sc\3GJk:tj icW*n 3h/EpTqAΠ&C.=A |yMPN]{,:PXt-5A:u Z;Qs& jhj& jhj& jhj}tVbp8{cvsNNYw,Vڬ^"-D t~H4 g {Z*& % 8Zޒ4!순Zd VdIn%ԒL|VVdq$ D $~$$L'$ܳnDt$ZyT4|ww:$* D  &$&T ,ҜD IDATx fY]'V䶐h(\Ɔ wh{T N1k3ZtcݴX0ҪnߐDWt}eCP$% K>3:JV423aF+J?~o9z}ǹ~q܅,Y>,YB%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%iI HK[^꟩qVi?Ea'MI и}ݙ#IIݽiڹl6t4;t;)pu+m&g_ moǁķU ~J!*Em"?{RR=MrѝdɦRuhUvV8@JǬ9IWw @ q6I-Iwm,\6tVZ)8M#}3Mb߽ر[wfnwo`.0s{;63@Uf~}ԮS|a$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i2TMY, j2@C<w̆uW}쏝6x5@w wRUu %HM еSDರ@d$ .qǍY/q Xx4J`4zs?LEZROu?1^5>!W0yڧ~ݭ*'sF_r6~&~"/+ߞ2@o:7YvD_~z|9iV :*Y܂} ?ψ*epGh4EY-$WI6i;MkߘM zcԽ-%G>]T)b=PĪ5[tG% X-^CǠz&3 ,H*QhODJߦ(7 UIҿ7tL4('B?3vN7? )uAk }ݚRA &䖑5bURLv aRH>N VVբ\0׹~i%^|zA!lPtCoFʽt*7ovSgnvTx^ V]àZ)%{_>VMO|0#aG.r64ЈR[a4 ̜>UȄ Na#x-[QƷgiK),=z2mmV)mнˠ", [o! +$Tr#.}oah?v6tw0rZѻ=SKS.TG`,Leuɻ+x~ YdmbvO+$BD ҆l/j!] eŽl>0ٙXFd>SJ^<]`[" ېbUiZm zw#M#9X0Vۿ#U+^U-I#֘@! $XrWi!V:y(O>>M'Bx'__AEf ZAdY pٝ>pB$z#L`?|Y:w8eNݒbt{ $iCVH;NʦT\zhd;qٴSp|2@g`P\]ir3B !G )$>ʡ"-YV;Y2K6wY/^JU ")~VH=N~pS!26#$Y6iNݒ Iѣ7.BS$,;mÅz'|)tZlӒt{Y@x ^X!*PŧGx!wYOEڠ{AGMU/#OE5 BP4Yeuɻz Ztq=Ƞ.$޿]TCLpi )xv!n!JGݘV%9?zOE u7Hk&T$- 9Zx! (WOٞZ:Vvh*@Ne&m&onTUV"hʥC2SSЋ Zfw4fRP-UܟB\mj <#mU@yc#T+-0I0D@Ԁ87Tq X΀G)>uc[Y9DmC=ZI6(iwTTJg#m,̓HT:֘BDh3yC28N~ʹI_TƶI.ξJDà>ml{Nd3%t$g^ya^~< zdtonA1HTh*QxiZ[iCDS<-"_reg N }D{`P zw%iD{ϡFrZ?dwafz2(BnP;.<(v/ F<O o8hMldfBĈ.b)-I#_ RyHv Ͳ^I$1 ~; QeH2>95Z[AjA%F̨7s},7or. $l?Br E2i~.ɨo5C.A·J}#wjz{zQҁX'ïo}[:S$2f*Fn!nn9."$tQķ+ϋKW{ `)'O֔:'il\7]U2@ޝ|RcgH>/Vy[U}~J%i$Z A<*]M'J(R:a%r,S3WX$(0hwQ@Dh3yCi/L;}txN|AAvAiZ<(iF)"Iy .UxLG VJ8Kq`7fAJŷh]àW n{J8RAJUvzJ CEO86;ą84}4pו Ep (JQVQ'ͮ#|8UxԨs hnaM - !B@\\:,{=Vڳ1{pQē d~63 *p qCMJM٠P!tf1:(]TYp(- nx<ܨT BTpгD!*U=FC GEՆbٍA)T=6*9T!O iR m"33h_ uTTJPD[QĹJ;N~ ]q 7S†v4jrMEP9򿻃A!oSAn5"@RʍTmHpd^DU!T(^-"tAś%.}1X Z! 3qIgHSQX~,l EƓ3)*BD7+DJBv kIHt6 `So% CKuT 7̠.j *, z)N o,ɠnĠnŠq#cPo /*p c t%(fA`PRR# =T^Ue' GfQUk2fR)%&!= Vmq }poF"*n{dP \MD&EtvhI:RʠhZ̔\d>Ib_ A$RWgG%o2µZm\dE6G0J_;T @QiB)TXc %{HD%U u|tH *( KFt Yd{Ơx+ Y.uQ"En=Eε0( xH bS3(/ isp)جS努fW} }^*AQc!Rݴ'%EfgP%ՈO߳Թ q4݂U$}W_MS$1AO͠p@i1Ǐqft xE09s>A=J?)`Q$ :UKn JJ ^}p.LʂTBe{wWay2:Iӷ$1A* A!XFzp+(-.;\%~إqyC"Rb]o[,,)R<)u݉U x<~n@~ kLffP(-pIP+`l.Aٝ9>D"NQ bKt4A ,2 {Π+a*t22sQk^@A)Щ$1)H-0$ɜ8"E0()) ?Jž2Ʀ'  /z *۠꧷AmiٙS'Ǥa+ yCf19TkͱfmPAK0d H]M)ǹ!/f7:3D6n t*~I% ~0`Pn jTmI"OP%D@<ӑ't/WgP S1(=T4s1(u"FfA4ZD7^귍A)UHingfC(X<$ t8 4lY Rt *QASA>*%v{hLirfiSk;gbPyXfPx@3.OЪx Ož i$1hʠl-I!)opU ֕p'xBI&e@OE3JY@jAAvUV(a}s"m7TJ2*2!'*ۣ(1]l<&b*lyK)[<'A+ӁK1LKA\Z8 ej#AږNh D\MIcyDc γ56&_n>|ox)+P\ip66 (XyUJ$ H)h]!/is2t`GW:[wuJ wOˬT\q(x0%fg]uGbvٷ y6?2}M|ߦ ؖ2\sH E)(bgվ&mCZ1ndRg֟O5Ϡo:՝k*JA7[q%J|EFT:uE/E ]4Z(SA%JRB?bÑ]-컷E#Us'v}$ OTs@edyˠAlP$AR-Ak1"9@gP3ܪht'scTD],j*r'uJtTruq hO7Ƞ22)QQ텟 ah^߶hߡ%SOʒ"ݱ_ IDAT" >4V.Q6R4AGKvOìbr({VL%osc y-̝AZ=Kp=ŠElAljkvsD¢`~L8AS km9:K&_ĩFbU| Z2^bPƋ\3 e.P1IJ c#.ϛ5Nuץh,sp-4 (ԢB/ d(KTV *c|@teVճ>DNl34$`SqUUpRݶ'o >Ih*Ƞ(6`ݤ#TX ڕ}L|wFۆ:@HX8jvOfO?;A|aX 6bfO\= NG7yEc:S{oxM0{\tFS#$C-IʠŨD6C-5$D+yg7DuRArB|6"(Gb㠯V=mP:Ab):)g y α"E6& v{E ] +A{@GySR'OO Π*#&Yls SmuVZvkv((Tu5)YS;0h F4}u!C|3`z7 qg_f:VqIHc讫%X1(HlY~h/~o0(e8J Ĕ9nu/!X*"*v{{fw6unkwZ1E  Tӎm#;N=2@ >D0W.pMVf56hLA]nLcbxƦ28%{Nω$G"'rڙ|nؠ – !Muc:렎l@q6u#SNAJ| %"G[6䛈nMkX :Ksw.lZ{d LR*]/U`jsѥuJZb~"\;6h@ wA)roxgt*w9C;ƬOdN1?B@ٗ<جy tʍ0NPIh 6^WK6BSrO:jIuf# W5p^=r3_sӷA$nY{L'K ȓ0F=?GcX+4]_m8pOW$qgxՋ'ֺ4m ڋ/= b-0j+ˮY7L=ם>f2 6 &,1X'S&$OAϫ+xWZ.V%[!@@ ,IT9RT(J6ntUĖ-޺H$duMNFҔ4g~#)?ORI-M%F۔K:"i O=V?1ҋ_[^Z1hN5Q(V~lYCHraDc\?k;dh%M&wJ9$C;"G`_yQ7LJ$9/8%J8C)4[ ]:<{줪F@Z'^$ =z_v^w OɠIw;uagIaCJRNڳ`T}%ʏ 6 ݄DV(욋<=ʕKK݌fЗܫ# ͞D=,5fdNgó$05ySJE'۾ϕƥK"g6xQ#-wi#^KöL[Hѡ܀sox;m]%]x>]˦'%x%Pb僂Ƞ5{ƠZ` S,Ė$iȎx9+&Mj̞Z@>F76f",u+V{^:~FdnzKAlgth>DH2qZQ@hbL2:o7)6"DXqq'!ϒ=+&${腑-I6PQ=0 x(ݣ4C+v{s},nL}# HJ@<ӏTC0)5/2Ⱦ4h3j??~c=#]Q" ^;͉-IM=u9ˆk޴M^:HwҜ$ (lTO! +m{sKx>tgnV6ʯ ;j`=a% ?EO1&ĥOrc_ڂӿl0~'f'TsA⣗#0 ->76^~/]rx-ٳDCz腑 z]7]wI66 }o-F'T8wIfƛ`-D J؞R'S EF=VWgJW w~Lg]6OShB1m&Mb8=q'!6w8mM9cV][o/Tɠ,BZ碐4'u\c#M0""ALʊLyL$/:R2Ȁ76)!.-|?C|v`[Oe?S[n1)PJ Jԓ@ &~#H4-эٛxƠ;V_>.Ӓ5<:u?M`nRxxc|6}__1hŘbeANirB6 fP˥'h]W! :e 4wlҕNs -~0BLsSBa/DŶxLž{ѸQ4fY*˷-ҁ8=EOq]u#+Qût ܤZج$Aشz{=(10BNDbP>k!M -YZ˥'} v }8yDyFWAw;KPg#KgmF/QcvZNZ.D:"aV>œ3t2Կ@;ZGv4Þ&NY;RL͚Xuco5w۠ DA Ɵpdd{pL[pLMaPX쨇lěM>dĭQh|JJFCo~kNˤK3:۠I (" sj'g5ܖjàWuESC*Tϯ{tG_hw׸{d'۔:ǝK.iɶl tcPeЙPВDb2ksM8R#n-CMinb| ԍ-d~wf$84Akg-aoh>M{gl6hPe8% 稩3O:;gK&Hg΂>,MNa-QQbddq:G$d 6wCHEm @oeY0( F3y +4#\%ePwyLQ}!E4:Ӥ-'[f}oKПZɨ=%lHӡ9 N WOe7.F#$5yr :K=svb_6. JF+ <*lÚ1=&`CD$˗'1q!mCZq݁эе=ڀNKDǗ{"U[俁muS$N$TiM̆1]; l1qhmcÓw@hRK+"Onq`6?o;fQk~V7#U𡓤TƧ $EլX63-@O )ԪecJh[ '.#UR@՛ɛp^2Aj͟D2¿~꿞ÛfhI@-"hno.\S +B ۄ0H 9a7 N%H4dF.U1vw;Bh͟6]7?D{6{nӒg̚δ tx1Lv%/{9IfM6zORh hӁoֈqß y??&f:Ico=^1吆`'CP.Qy|W7 5$AO4a$h}si3P[t=0jiyh-IQфD1(֛Շƣd9/'Lb1]r s|P( p?C2謱AON)Bz>0Ĩ!JHhAAij[pk;G듵Or͘K8% Tڟ(K柽B' _8qډXL'kH2 9#(xSSAzC8?Syz6hlzkW|VhQigOnV SIJ\Q?+D/_q/wU!Cl=Um;·nƵO*AhE߫WO 42A'9+}z JPTWO+YǍv7IM=jⳙi]Zm-YBE ъERtّ(W_ L Ф螃y/AOϚ@iie:o8IM7 zT٠C3ҨO_/ǎ=o nGn D'1bdw"?H\Y.O4];oS@z u?ڇ} PhAxȶLJ-s[[/] kޥLQOP&ƯoQDAjЩE,Ic}"]4.<m\n Ze3}3hD4_ow={] GR&BgeP23:s-@V.^- IDATTR\MC z MG6hݏ=aHR2N`SYBk-6Nx-oH aO%|a-!-9-^ʼn{s>]mL?^ 鸵A!@ _hU| ԑ3eC~ ‘CmPT ORo`hC| ~oY zfA]}=p3A!Yك :1mHxGctEC,Xm__U~ya7w{6KYc8Pc5HgԴ$ Lw?I8! ځAhˠm[:qcw<ʮ?JOMb(ߤ?.`Hb,w:3*6Nڌf njx<czuN^+;Ag'Vb6MFȲǧH7A A'~|чWZt@:(hwGvf5H̐ (e3uaPx"Nso|?С %}^5OK.Qoj[LڄC1E6/AI"=L%7mIg@qo~q}%7~ib #!k`6kA!`JDI\ (]iՋ6J=xd6YMq]04 fӶA7lmW^IHʠ"Y^Ǡ FWT$Y3 ^=k ԉ7ЕF!n^R4@_xgSm-ދE^NC,o!˶&м}P4]8)Ah{F2F+W(R)_pbm )wRi5K = B]g`גAN0/p_GGTgPZȠ[?*r3PWcEC7Z6&%tȠaI%~Aؽ$yݫ}k4`!FJJB#ZeP mcrTK]^E^Ȍ5gB(dpn -6(]QN;PȫzOҺ{a8СXzaA͈ 6cNPpcq*y>h08`P DC}`HtF ?qP4 Z4oBT_I_eX p 'nFO9d cEV*)|EC4NtB=T" 5 7)`'roΆA%_!iC; /Uɕۮ]ؾ΅o Z8Hz׻f8V5 Q8Vc7$*7D ڼ{ѾNvռPv 7XDm Y>ZJn̩ :Au2Y%xMx Eg8ڠti||˾5ft ZRhBU=FrQ!:^;kZmX5`vePt_Ư (xbܥ$ yM*yowq(`r AQ_/{3GZ=V;!cܲ5"6/lM wF1(YgV%O ZSk zѳ(h#Dm%9lΨ?U4Bgk=J̈GQi6Ckճ8VARg:uQfwOٿ\Z $bHC.՝pCmu>AxPlK_Z1聆B-B+:m~)]5f:.e 8sBB4YBnH'6(U?UYGftg%BV ګ BO6j.f嘨1%W@*"eo0GF$RwMsc8qczq%foۢm7P;T_gS|cyC2쯡ixxR+: FSJA]Ԅf=]hpzcՋhP5;r5ƻpjUG+ Zs'KoA{`ƋwZCқe CNcj[L5ݒf=IBMRW.]?`KPTZLjCo7 t^}OGEP]]>*gƃER5"'LՀhDj.G!}2kNveQ&ؠ}ycD@3ӒiV^<@M΋w= ZT$c:kB%UlB_7DM N0qzbIB$R 贚ז(eQ=MQDk(Wr#}ao%Ag{N͟`۔ӧD:@U>q'fP@(< T[BWLQ"%`~bm2( sh[tH/54r:I3@ <>I%sYY )L[֯_aQDܬ۰hcFUnϞ;ͨyQ{wtTdЛߴD[kbP/~V6(PZ#"%0=92F)nDԔL4鉷}z]h5aQJY.9o%wMMf#KjU^|L?7ʢ V)PJxvRIͣ9QWR(︌m3G2^ͷgyMiu~kr3bmPG"8qPǞ H7z>P<#MQ5J%mriA mO;. ١ķ0]L}ޫ]Kb4[j-JeiXtnƋЄg$W l1}JAUcveF1eQ [iX٢9^Norjؠt|#M3QBAFmM DSUdEN+hC([(jgkh4xO#Iyf鲄%Sˠ6_oU<yd;d:S(C(jG'V)Hǔ1%O It!'W7Aizh4Zcƚ@%4.JA~@=UL ".}{JxX) )턊ƇMQw`QcŚTqaR z^vg~g~fiie˖< 4"3I$lR͹W"2U*q1.RC3(NL|f,]Y% }< +MQA v.]a,qzQ/rT=OԽP X%mR RԩGiO-LW@$82kj7 ]B{OoYc=#9 Vq^o"rO{GMtƠ"E}eóJf^x]†hC6p :^:Kw`W*oWNZ^zڹ?#tR9rzXp.,tP?R6GQd,fOlCN ډC'ւ{([3;PQH Tr* ;Q'N-㐖wٳ"E}y'&TG12AturK1fDM?p,)л_laЎ]g0sAC tb *M#tp)4mQ8`:«7}9 P<~cȽږ4.(A!m2UAkL֔Oq Z( L 47e>et #zl8R[% Ц8}]w0LE ((I('#.ĝnNfmVׯ9%BItC}E Οo^| tZr`,`Y2rh8LaMiA[IP@Eм!RщZoHO(H:]oGEL66_ . M/2ӌ>ֿ'((5<[h4M}>Zp_RgkX=QB9mzLq$_5h0蚤݁VA_D{u1(n=.uR"i8 or&1 =E]J_KZB zzw0h $0hZEƫ\ۤ0*-`J^l :`␔ "R9ѣ17xoCh6)7og|DJdI(kTe;c{tB`xxPC :L]x-G'ۣ4B#b 4*MN{aQSoҝhLc4ֶBt-*ؠr )A .hHPC{tw*g*U_x=> =Pk]̸7Ǽw:tС{`YA j:D8}Gʵkizpi}D%>X}/OHy2=А $?/||OPNݥavŘ-%yDLwQHŏ= hHi6[ '/Cј FqH9-zdOqP*ԍGuB<ji{5,WJ䃉Ư_^/ܦ Fѵӱ?|Sh:{HE˙̊^RDYB>wt>"m0Ͼ'ꏼo= ً/p ڣ'&<)\q<'8ãح'L9@=zih'fp#G? Eh q.:,Sأ[WyN¢z~ OĿĖ{%I:Fal4IA[; P'10(̂s0<:}hQJxO-! Fh:`GwC)6A3mәG1yzcmQ%!zefM0٢N %Y`-}Q  :UTfРIW :cpN`$Re">G%UO4ǟ^N:I(!Oeоl } 99Ǿ%F*[(B*&@хUQ+tzU+z)Ac:k'WPԗ6meP*zihe ȍ'A{Z.FK|h/ E; W}1(⠑ Z͌-}h{配: &~'!yyADA_/8*Ot!?:("r^lYauO|U!K:T,ik~ DT{1}ΣNRaO+čf`b̈F$-&@ެ 4#i3S[Z>׽ӯ|z?_WKe+e݋g%Вy&0AcP9W BDKzS(*>/K6B*(Hݍw'_[Sw]WؠƟPiRm2feaT4G `ׅ7ړJ9*wc*AK~w'eH :W/ e2mtOLW H= Q.lk@V'AKGئS}}:e]I4WK!jGfBG_ne>d/;؋oldO|ZBm B'RT~cPXgߑ@V2zsh-;4xf),4A_z+Ԛ|:ZϠl7^`2z$RãzkSOW9D = g];8j^ThMIؠ"TvA ,칶F58&8'g[Ftj}';N j4w6h \VkRH{6Hle%ãBPoN` h@ ̠xE䥾08(m(CNb]a~ .Fŗ ů A%Eo;ߌwg &ҒH&ՒHԽ* .r_q]VM;3(ma-0z='NCeVi3Q-yI眊 n`PVXve}bw!r]J]GMR?xH|=hxWw"'{Z,YhϹOg0z-)Wm=v@z96wi]aZ/ Zx j;m/z},әG10vf0g6 mT+*`R#[%Gϰ4R![Hm"vaR{o,~:ԣy٠ N(4yxD2(SgE~F'xqKtK_|hpgwaPš Š]R"_,HA*& c"` {]äQ z=N Q̠(" t+ȏzNՊ$&@"Pr] 4c?JHm|[ӧ(%0p,V(fvNA Rp6)~2&NKvŠw:!R42EԗDU2@AщyɾUF!Km\;pAS$~]~ݸ;s`AexQO Π# &)D{eba}KyGonrސ0@2(FS ^09mw;U&9]T:fF12K؋DU`,vmE,^$2'^DP*ĭOB(:Gv$@, t70`wIf$S/ 3(<^ ꈔ5RnNK>S[6@AAEB ꎻH8>I@ġsc}5Iy ^D ϠQ5Tc:/Y+7 $% Pʠ )(ƈJNy3(|+ga '6L}P3 F3h 8@77:EUYNGʠ ʁ]kQ=B݀%b |(eH4I$ob njQ#/·AcEFGqĝiد=0|s9GPjZ؁A9#o ZGH0H5՚,Bڠ ~#ЊAi6,z=̠9$ĝ6hIGYJRǰ7UMaH>T[U2 $T]:|´4Ec/%^ P̣ ZڠmN|6(>,"`BĕďHA(h"1U´OZ )D*6HS^ɤ|$ *xB5q%mzYT>an/ޡr c$ݰUN-X(y>Id0 Ǡfȧ3;sTj/"Ǡ;g ΂OcR, ڊXt$}=a|=󐖇 ad^{ VMewuCh3@=Tڄ ѓ&&A3vb> ^s^ ȋ/Fn ja4~&A59^j4Ĩ\|XKĤR4Hݎ)@;n /.B Jj(#C Z#ɠB k+DY )èQQ^| Vys#ty2` BE z8k2(=vC0<*ǝtiX%_2@} Ń0MTuTiA#DWA=X|54495 fDdPԹ4tƷu4-xA;veP-Ǹ MbTй:%"Agx{G!bQ5-bjUQC;' gQ#*Ï C'hc\Co4 :%ɖ)S3()k 0b zߐ : lW'/PLUfQucPhO eSؠČnn(%1 ڊX OG%O)u!Ay4AHߵSvFu7 2`,JAc,Ih /j c↵_ o'kr 6>| ]WJz M@))HAB9X!WzdP0MǠy`NIԷg3: jލ{xSKV0@uװA̬ Z8ŏ*E{Q|7J"Vſ?+Ns @]*aw8[(TePʠA VMN⿩*KCH+F۠jv8Π2573A; r8 f@!Wqo>≕IP0²eHiZo o^P^wn9<@=S?,T}c6N7uvePw1JD ($@T3eg-?ڲ_O)dKe6$}B"͉A1r&Z3&2g(K"_O>?.y>}WgO@nOo ڊX  <9dP0̭glhdj`VK!|K #Ƞh *ʈU͠!8r2%S` Zۏ_IpJB#  HlcPKU~*A|j|vC6̫A1t*B0(8gA DXṷ=ǧB3烂p]j) ApZÓA<)fyf_Vgn) .aVMS`7[fБ(ON-p1~,NePL{3I,iMi IAQX`H V7$ H ܵg6/JS$ݽaP~Ul#P̠yHp%fy*dr MNұ8dcASAU=2Pno~ U;s0jePkP%0Vf *vO=X~ې&*!/v< &)Hx}mPz8s)|!QKdI R!}N;> BpLyr=hG/uGޫ> !wzZe!01 ʋ'̏%< u5M8IuҵA:p m|(݉gPn VZVT|,o ;%6T7 ~ D;1TaPpvxFXwu@ ݴ;/@S:IL"T-B W&\PbN-v`(]yp7խө@2a%%wZ .\v c!Q g\*/*g"mz_|AI1BW2~pjdm$0 ܶWiNGxQ!oOezT҃Nҟ&[e'PjFY$mJoCW<IeX[$|J0>x0,Jipi9I-rrG 9 A DFRm1ErSn*M]Ƞ梤3b# n9{1+ml&9弌Oy{i_q<@GI39" sʴT"t%"9dw drx /tiPEx V{xFۢ۴6ږj.ZD,; 3bT|ҁzMs"Gp[l˖2lc { )lUǗB)a,,~n_ =Ż%r}aX\ ~@b-x$&Dw8xݖ$n\x@Qx*m7\5¦T hp(PNc#ΠMsKV_qy1U 텔F d8zyKV̲-IhMAL$5Qr_m7By]=+=.fY ]cUBS箴Am<{S(dKin0PvOF4$$F\vd]wdԗE-ZeQhߌ8'O&oV }P6FA詈[axߓJeq|,11N~,׋>|otsS7ߩ*zY+:3^HAs79k'5̨6h踓gƋ#ۘGw.Iɋo@Aw'm_K7)溷X4A.@6eYvt[tb ʹJ*~뙥g3NsUǕOw!OPO wqǍWq 6\ N(ʒhե|j tlZ^; н=vj{mg{ 绸;6Y~Dmq[]J{˧#u $wO|lYdfI[2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4K+@Ϻ#wi{z-Љ6sC+Ԧ>Sg4]4 vxowHGԭ;i.3" xb@Fۜ'@6e!D~dP+wN:i~co|.Mffet6detg m<% Li]6oo pbNrV69y4uao Bso̒w͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒d:Sծeȗlv-Jڕ5Cw\ n 0f#ɗ;6P;_WGfY|ik !%_ZdQ})2|H"ܺKK9Z˔6hj-"@u/D6-@?Z/w[D|%|Yc$pV |}g؇|$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKhЙIDATj*폻IENDB`deSolve/NEWS0000644000176000001440000001741613576660626012434 0ustar ripleyusersChanges version 1.27 ================================ o C level changes to ensure compatibility with gcc 10 solution kindly provided by Brian Ripley Changes version 1.26 ================================ o fix outdated class checks to ensure R 4.0.0 compatibility (Karline, Thomas) o Fortran modernization: initialization ov variables (Karline) Changes version 1.25 ================================ o add original authors of LINPACK, ODEPACK and SPARSKIT to Authors@R (Thomas, Karline, Woody) Changes version 1.24 ================================ o fix compiler warnings to improve Fortran compatibility (Thomas, Karline, Woody) thanks to Brian Ripley and Kurt Hornik o iteration: set attribute before calling diagnostics (Karline) o add open researcher id, ORCID (Thomas) Changes version 1.23 ================================ o add FME to 'Suggests' Changes version 1.22 ================================ o small updates of examples (Thomas) o improve Fortran compiler compatibility (Thomas) Changes version 1.21 ================================ o change way how PROTECT/UNPROTECT is handled (Thomas) (suggested by Tomas Kalibera / R-Core) o fixed inconsistency in the aphid model example (suggested by Sarah Kintner) Changes version 1.20 ================================ o register native routines (Thomas) o check if event data frame has ordered time (and if not, order) o change 'event list' to event matrix or data frame in docs o intentional version jump to indicate chances at the C level Changes version 1.14 ================================ o matplot.deSolve is not anymore exported as matplot to avoid the respective startup message o please use matplot.deSolve or the alias matplot.0D instead (Thomas) o small fix that allows parameters in list format for DLLfunc and DLLres o a little bit Fortran modification (e.g. avoid real*8 and complex*16 types) Changes version 1.13 ================================ o observed data and plot.deSolve / matplot for multiple outputs (Karline) o combining compiled code function with R code event function (Karline) o check sorting of event times (Karline) o fix bug related to negative event time (patch supplied by J. Stott) o relax setting of tcrit to make integration with events slightly faster (patch from J. Stott) o adapt maxstep calculation for rk methods, print a warning if maxsteps is exceeded, fix diagnostics (Thomas) o more argument checking for rk solvers (Thomas) o add reference to book of Soetaert, Cash and Mazzia (2012) Changes version 1.12 ================================ o new functions matplot.deSolve and matplot.1D o fix valgrind issue (detected by new compilers) o small improvments of plotting functions o import standard packages as required by upcoming R versions Changes version 1.11 ================================ o compiledCode vignette now with dede example o warning and error bug resolved o Time SEXP incompatibility with R 3.1.1 resolved o CFunc compatibility (compiled code) Changes version 1.10.9 ================================ o documentation updates, hyperlinks to examples and vignettes o moved example directories Changes version 1.10.8 ================================ o remove redundant .R files from inst/doc o fixed bug in event code (patch contributed by Jonathan Stott) Changes version 1.10.7 ================================ o Fortran examples of compiled dede models (Woody) o vignettes moved to /vignettes o roles of authors (Authors@R) o function timestep is now internal o small documentation updates Changes version 1.10.6 (Thomas) ================================ o change declaration of variable dimensions from (1) to (*) in legacy Fortran code to pass automatic bounds check o remove the Jacobian examples from ?ode because banddown=0 can lead to problems on some systems; examples will come back in a next release o fixed bug in the "iteration" solver o small documentation updates Changes version 1.10.5 (Karline, Thomas) ================================ o extended subset.deSolve with argument arr, when TRUE returns an array for >2-D output o fixed the R compiler notes o plot.ode.2D now has an mtext argument, via the ..., to label multiple figures in margin... CHECK - see ode.2D o subset can also be a vector with indices in addition to logical o image with legend = TRUE changed size of plot in different layouts - now solved (by adding par(mar = par("mar")) ) o new method to output warnings and error messages o add data type check for external outputs in rk_util.c o add interface for compiled dede models o emphasize consistent order of states in y and return value of func o changes of Fortran error messages (to be continued) Changes version 1.10-4 (Thomas, Karline) ================================ o allow reverted time vector for fixed step solvers - todo: find solution for dense output methods, and Livermore solvers o all solvers now have default atol = 1e-6; before this daspk and vode had 1e-8. o multiple warnings from daspk if num steps = 500 toggled off. o added input argument "nind" to daspk, to make it compatible with radau. this also changes the way the variables are weighed, hence this differs from the original daspk 2.0 code. o improved warning printing in daspk and vode o extended sparse Jacobian input in lsodes. (2-D and 3-D sparsity with mapping var and arbitrary sparsity in ian/jan format). Changes version 1.10-3 (Karline) ================================ o rwork and iwork in lsodes from Fortran -> C (to remove compiler warnings) o roots + events: now certain roots can stop simulation + fixed bug in radau root o improved events\roots help file o diagnostics(out) gave error in case method=iteration (no rstate) now fixed o the package authors agreed to assign the maintainer role to T.P., but the order of authorship and credits remain unchanged. Changes version 1.10-2 (Karline) ================================ o remove NAs from forcing functions - when used in DLL (file forcings.R) o new argument "restructure" in ode.1D, for use with implicit solvers not in deSolve o removed requirement to have eventfunc in compiled code when func is in compiled code o subsetting on summary.deSolve Changes version 1.10-1 (Thomas) =============================== o remove several redundant variables from C code o add NEWS file Changes version 1.10 (Karline, Thomas) ====================================== o compiled code using mass in daspk o cleanEventTimes Changes version 1.9+ (Karline) ============================== o roots, events, lags in radau o roots in lsodes o lags in daspk o ode (method = "iteration") Changes version 1.9 (Karline, Thomas) ===================================== o summary.deSolve o subset.deSolve o plotting deSolve objects improved: - plot more than one output in same figures (scenarios), - add observations o vignette improved o fixed bug in 'timesteps' Changes version 1.8.1 (Thomas, Woody, Karline) ============================================== o fixed compiler warnings using valgrind o fixed compiler warning C-code Changes version 1.8 (Thomas) ============================ o Dormand-Prince 8(7) coefficients use now common instead of decimal fractions Changes version 1.8 (Karline) ============================= o Runge-Kuttas: - extra output: number of failed steps (see also 2) - number of function evaluations + 1 for initial condition - dense output for cash-karp - dopri8(7) added - radau added!! implicit runge kutta, solves also DAE up to index 3! o other: - image function for ode.2-D added. - changed warning printing in FORTRAN code - common interface for radau and daspk: both can solve systems written as M*dy = f(x,y). daspk can also solve systems written as 0 = g(x,y,dy) (=default for daspk) deSolve/R/0000755000176000001440000000000013572677236012126 5ustar ripleyusersdeSolve/R/DLLfunc.R0000644000176000001440000001600613572677236013543 0ustar ripleyusers## Karline: made compatible with CFunc DLLfunc <- function (func, times, y, parms, dllname, initfunc=dllname, rpar=NULL, ipar=NULL, nout=0, outnames=NULL, forcings=NULL, initforc = NULL, fcontrol=NULL) { ## check the input if (!is.numeric(y)) stop("`y' must be numeric") n <- length(y) if (! is.null(times)&&!is.numeric(times)) stop("`times' must be NULL or numeric") if (! is.null(outnames)) if (length(outnames) != nout) stop("length outnames should be = nout") if (is.list(func)) { if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$initforc)) initforc <- func$initforc if (!is.null(func$dllname)) dllname <- func$dllname func <- func$func } ## is there an initialiser? - initialiser has the same name as the dll file ModelInit <- NULL Outinit <- NULL flist <- list(fmat=0,tmat=0,imat=0,ModelForc=NULL) Ynames <- attr(y, "names") if (! inherits(func, "CFunc")) if (is.null(dllname) || !is.character(dllname)) stop("`dllname' must be a name referring to a dll") if (! is.null(initfunc)) { if (inherits(initfunc, "CFunc")) ModelInit <- body(initfunc)[[2]] else if (is.loaded(initfunc, PACKAGE = dllname, type = "") || is.loaded(initfunc, PACKAGE = dllname, type = "Fortran")) {ModelInit <- getNativeSymbolInfo(initfunc, PACKAGE = dllname)$address } else if (initfunc != dllname && ! is.null(initfunc)) stop(paste("cannot integrate: initfunc not loaded ",initfunc)) } if (is.null(initfunc)) initfunc <- NA if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,TRUE,fcontrol) ## the function if (inherits(func, "CFunc")) Func <- body(func)[[2]] else if (!is.character(func)) stop("`func' must be a *name* referring to a function in a dll or of class CFunc") else if (is.loaded(func, PACKAGE = dllname)) { Func <- getNativeSymbolInfo(func, PACKAGE = dllname)$address } else stop(paste("cannot run DLLfunc: dyn function not loaded: ",func)) dy <- rep(0,n) storage.mode(y) <- storage.mode(dy) <- "double" # out <- .Call("call_DLL", y, dy, as.double(times[1]), Func, ModelInit, #Outinit, # as.double(parms),as.integer(nout), # as.double(rpar),as.integer(ipar), 1L, # flist, PACKAGE = "deSolve") out <- .Call("call_DLL", y, dy, as.double(times[1]), Func, ModelInit, #Outinit, parms, as.integer(nout), as.double(rpar),as.integer(ipar), 1L, flist, PACKAGE = "deSolve") vout <- if (nout>0) out[(n + 1):(n + nout)] else NA out <- list(dy = out[1:n], var = vout) if (!is.null(Ynames)) names(out$dy) <-Ynames if (! is.null(outnames)) names(out$var) <- outnames return(out) # a list with the rate of change (dy) and output variables (var) } DLLres <- function (res, times, y, dy, parms, dllname, initfunc=dllname, rpar=NULL, ipar=NULL, nout=0, outnames=NULL, forcings=NULL, initforc = NULL, fcontrol=NULL) { ## check the input if (!is.numeric(y)) stop("`y' must be numeric") if (!is.numeric(dy)) stop("`dy' must be numeric") n <- length(y) if (length(dy) != n) stop("`dy' and 'y' muxt hve the same length") if (! is.null(times)&&!is.numeric(times)) stop("`time' must be NULL or numeric") if (! is.null(outnames)) if (length(outnames) != nout) stop("length outnames should be = nout") if (is.list(res)) { if (!is.null(dllname) & "dllname" %in% names(res)) stop("If 'res' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(res)) stop("If 'res' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(initforc) & "initforc" %in% names(res)) stop("If 'res' is a list that contains initforc, argument 'initforc' should be NULL") dllname <- res$dllname initfunc <- res$initfunc initforc <- res$initforc res <- res$res } ## is there an initialiser? - initialiser has the same name as the dll file ModelInit <- NULL Outinit<- NULL flist<-list(fmat=0,tmat=0,imat=0,ModelForc=NULL) Ynames <- attr(y, "names") if (!inherits(res, "CFunc")) if(is.null(dllname)|| !is.character(dllname)) stop("`dllname' must be a name referring to a dll") if (! is.null(initfunc)){ if (inherits(initfunc, "CFunc")) ModelInit <- body(initfunc)[[2]] else if (is.loaded(initfunc, PACKAGE = dllname, type = "") || is.loaded(initfunc, PACKAGE = dllname, type = "Fortran")) {ModelInit <- getNativeSymbolInfo(initfunc, PACKAGE = dllname)$address } else if (initfunc != dllname && ! is.null(initfunc)) stop(paste("cannot integrate: initfunc not loaded ",initfunc)) } if (is.null(initfunc)) initfunc <- NA if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,TRUE,fcontrol) ## the function if (inherits(res, "CFunc")) Res <- body(res)[[2]] else if (!is.character(res)) stop("`res' must be a *name* referring to a function in a dll") else if (is.loaded(res, PACKAGE = dllname)) { Res <- getNativeSymbolInfo(res, PACKAGE = dllname)$address } else stop(paste("cannot run DLLres: res function not loaded: ",res)) storage.mode(y) <- storage.mode(dy) <- "double" # out <- .Call("call_DLL", y, dy, as.double(times[1]), Res, ModelInit, #Outinit, # as.double(parms),as.integer(nout), # as.double(rpar),as.integer(ipar), 2L, # flist, PACKAGE = "deSolve") out <- .Call("call_DLL", y, dy, as.double(times[1]), Res, ModelInit, #Outinit, parms, as.integer(nout), as.double(rpar), as.integer(ipar), 2L, flist, PACKAGE = "deSolve") vout <- if (nout>0) out[(n + 1):(n + nout)] else NA out <- list(delta = out[1:n], var = vout) if (!is.null(Ynames)) names(out$delta) <-Ynames if (! is.null(outnames)) names(out$var) <- outnames return(out) # a list with the residual and output variables (var) } deSolve/R/Aquaphy.R0000644000176000001440000000126313136461011013635 0ustar ripleyusersaquaphy <- function(times, y, parms, PAR=NULL, ...) { if (length(y) != 4) stop ("length of state variable vector should be 4") if (length(parms) != 19) stop ("length of parameter vector should be 19") names(y) <- c("DIN","PROTEIN","RESERVE","LMW") outnames <- c("PAR","TotalN","PhotoSynthesis", "NCratio","ChlCratio","Chlorophyll") if (is.null(PAR)) ode(y,times,dllname="deSolve", func="aquaphy",initfunc="iniaqua", parms=parms,nout=6,outnames=outnames,...) else ode(y,times,dllname="deSolve", func="aquaphyforc",initfunc="iniaqua", initforc="initaqforc",forcings=PAR, parms=parms,nout=6,outnames=outnames,...) } deSolve/R/printmessage.R0000644000176000001440000000120313136461011014720 0ustar ripleyusers## internal helper functions for printing solver return code messages ## these functions are not exported ## print combined messages (message and numeric output) printmessage <-function(message1, state, message2 = NULL, Nr = 1:length(message1)) { if (is.null(message2)) { cat("\n", paste(formatC(Nr, "##", width = 2), message1, signif(state, digits = getOption("digits")), "\n"), "\n") } else { cat("\n", paste(formatC(Nr, "##", width = 2), message1, signif(state, digits = getOption("digits")), message2, "\n"), "\n") } } ## print short messages printM <- function(message) cat(message, "\n") deSolve/R/Utilities.R0000644000176000001440000012705713572677236014240 0ustar ripleyusers### ============================================================================ ### ============================================================================ ### S3 methods ### karline+Thomas: from version 1.9, also possible to plot multiple ### outputs and to add observations. ### ============================================================================ ### ============================================================================ ### ============================================================================ ### first some common functions ### ============================================================================ ## ============================================================================= ## Update range, taking into account neg values for log transformed values ## ============================================================================= Range <- function(Range, x, log) { if ((log) & (!is.null(x))) x[x <= 0] <- min(x[x > 0]) # remove zeros return(range(Range, x, na.rm = TRUE) ) } ## ============================================================================= ## Checking and expanding arguments in dots (...) with default ## ============================================================================= expanddots <- function (dots, default, n) { dots <- if (is.null(dots)) default else dots rep(dots, length.out = n) } # lists: e.g. xlim and ylim.... expanddotslist <- function (dots, n) { if (is.null(dots)) return(dots) dd <- if (!is.list(dots )) list(dots) else dots rep(dd, length.out = n) } ## ============================================================================= ## Expanding arguments in dots (...) ## ============================================================================= repdots <- function(dots, n) if (is.function(dots)) dots else rep(dots, length.out = n) setdots <- function(dots, n) lapply(dots, repdots, n) ## ============================================================================= ## Extracting element 'index' from dots (...) ## ============================================================================= extractdots <- function(dots, index) { ret <- lapply(dots, "[", index) ret <- lapply(ret, unlist) # flatten list return(ret) } ## ============================================================================= ## Merge two observed data files; assumed that first column = 'x' and ignored ## ============================================================================= # from 3-columned format (what, where, value) to wide format... convert2wide <- function(Data) { cnames <- as.character(unique(Data[,1])) MAT <- Data[Data[,1] == cnames[1], 2:3] colnames.MAT <- c("x", cnames[1]) for ( ivar in cnames[-1]) { sel <- Data[Data[,1] == ivar, 2:3] nt <- cbind(sel[,1], matrix(nrow = nrow(sel), ncol = ncol(MAT)-1, data = NA), sel[,2]) MAT <- cbind(MAT, NA) colnames(nt) <- colnames(MAT) MAT <- rbind(MAT, nt) colnames.MAT <- c(colnames.MAT, ivar) } colnames(MAT) <- colnames.MAT return(MAT) } # merge two observed data sets in one mergeObs <- function(obs, Newobs) { if (! inherits(Newobs, c("data.frame", "matrix"))) stop ("the elements in 'obs' should be either a 'data.frame' or a 'matrix'") if (is.character(Newobs[, 1]) | is.factor(Newobs[, 1])) Newobs <- convert2wide(Newobs) obsname <- colnames(obs) ## check if some observed variables in NewObs are already in obs newname <- colnames(Newobs)[-1] # 1st column = x-var and ignored ii <- which (newname %in% obsname) if (length(ii) > 0) obsname <- c(obsname, newname[-ii] ) else obsname <- c(obsname, newname) ## padding with NA of the two datasets O1 <- matrix(nrow = nrow(Newobs), ncol = ncol(obs), data = NA) O1[ ,1] <- Newobs[, 1] for (j in ii) { # observed data in common are put in correct position jj <- which (obsname == newname[j]) O1[,jj] <- Newobs[, j+1] } O1 <- cbind(O1, Newobs[, -c(1, ii+1)] ) colnames(O1) <- obsname nnewcol <- ncol(Newobs)-1 - length (ii) # number of new columns if (nnewcol > 0) { O2 <- matrix(nrow = nrow(obs), ncol = nnewcol, data = NA) O2 <- cbind(obs, O2) colnames(O2) <- obsname } else O2 <- obs obs <- rbind(O2, O1) return(obs) } ## ============================================================================= ## Set the mfrow parameters and whether to "ask" for opening a new device ## ============================================================================= setplotpar <- function(ldots, nv, ask) { nmdots <- names(ldots) # nv = number of variables to plot if (!any(match(nmdots, c("mfrow", "mfcol"), nomatch = 0))) { nc <- min(ceiling(sqrt(nv)), 3) nr <- min(ceiling(nv/nc), 3) mfrow <- c(nr, nc) } else if ("mfcol" %in% nmdots) mfrow <- rev(ldots$mfcol) else mfrow <- ldots$mfrow if (! is.null(mfrow)) mf <- par(mfrow = mfrow) ## interactively wait if there are remaining figures if (is.null(ask)) ask <- prod(par("mfrow")) < nv && dev.interactive() return(ask) } ## ============================================================================= ## find a variable ## ============================================================================= selectvar <- function (Which, var, NAallowed = FALSE) { if (!is.numeric(Which)) { ln <- length(Which) ## the loop is necessary so as to keep ordering... Select <- NULL for ( i in 1:ln) { ss <- which(Which[i] == var) if (length(ss) ==0 & ! NAallowed) stop("variable ", Which[i], " not in variable names") else if (length(ss) == 0) Select <- c(Select, NA) else Select <- c(Select, ss) } } else { Select <- Which + 1 # "Select" now refers to the column number if (max(Select) > length(var)) stop("index in 'which' too large: ", max(Select)-1) if (min(Select) < 1) stop("index in 'which' should be > 0") } return(Select) } ### ============================================================================ ### print a deSolve object ### ============================================================================ print.deSolve <- function(x, ...) print(as.data.frame(x), ...) ### ============================================================================ ### Create a histogram for a list of variables ### ============================================================================ hist.deSolve <- function (x, select = 1:(ncol(x)-1), which = select, ask = NULL, subset = NULL, ...) { t <- 1 # column with independent variable ("times") varnames <- colnames(x) Which <- selectvar(which, varnames) np <- length(Which) ldots <- list(...) ## Set par mfrow and ask ask <- setplotpar(ldots, np, ask) if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } ## expand all dots to np values (no defaults) Dotmain <- setdots(ldots, np) ## different from default settings Dotmain$main <- expanddots (ldots$main, varnames[Which], np) Dotmain$xlab <- expanddots (ldots$xlab, varnames[t], np) # Dotmain$xlab <- expanddots (ldots$xlab, "" , np) ## xlim and ylim are special: they are vectors or lists xxlim <- expanddotslist(ldots$xlim, np) yylim <- expanddotslist(ldots$ylim, np) if (!missing(subset)){ e <- substitute(subset) r <- eval(e, as.data.frame(x), parent.frame()) if (is.numeric(r)) { isub <- r } else { if (!is.logical(r)) stop("'subset' must evaluate to logical or be a vector with integers") isub <- r & !is.na(r) } } else isub <- TRUE ## plotting for (ip in 1:np) { ix <- Which[ip] dotmain <- extractdots(Dotmain, ip) if (! is.null(xxlim[[ip]])) dotmain$xlim <- xxlim[[ip]] if (! is.null(yylim[[ip]])) dotmain$ylim <- yylim[[ip]] do.call("hist", c(alist(x[isub, ix]), dotmain)) } } ### ============================================================================ ### Image, filled.contour and persp plots ### ============================================================================ image.deSolve <- function (x, select = NULL, which = select, ask = NULL, add.contour = FALSE, grid = NULL, method = "image", legend = FALSE, subset = NULL, ...) { if (!missing(subset)){ e <- substitute(subset) r <- eval(e, as.data.frame(x), parent.frame()) if (is.numeric(r)) { isub <- r } else { if (!is.logical(r)) stop("'subset' must evaluate to logical or be a vector with integers") isub <- r & !is.na(r) } } else isub <- TRUE dimens <- attributes(x)$dimens if (is.null(dimens)) stop("cannot make an image from deSolve output which is 0-dimensional") else if (length(dimens) ==1) # 1-D plot.ode1D(x, which, ask, add.contour, grid, method=method, legend = legend, isub = isub, ...) else if (length(dimens) ==2) # 2-D plot.ode2D(x, which, ask, add.contour, grid, method=method, legend = legend, isub = isub, ...) else stop("cannot make an image from deSolve output with more than 2 dimensions") } ### ============================================================================ ### Plot utilities for the S3 plot method, 0-D, 1-D, 2-D ### ============================================================================ ## ============================================================================ ## Observations cleanup ## ============================================================================ SetData <- function(obs) { ## check observed data nobs <- 0 obs.pos <- NULL obsname <- NULL if (! is.null(obs)) { if (!is.data.frame(obs) & is.list(obs)) { # a list with different data sets Obs <- obs obs <- Obs[[1]] obs.pos <- matrix(nrow = 1, c(1, nrow(obs))) if (! inherits(obs, c("data.frame", "matrix"))) stop ("'obs' should be either a 'data.frame' or a 'matrix'") if (length(Obs) > 1) for ( i in 2 : length(Obs)) { obs <- mergeObs(obs, Obs[[i]]) obs.pos <- rbind(obs.pos, c(obs.pos[nrow(obs.pos), 2] +1, nrow(obs))) } obsname <- colnames(obs) } else { # a data.frame or matrix if (is.character(obs[, 1]) | is.factor(obs[, 1])) # long format - convert obs <- convert2wide(obs) obsname <- colnames(obs) if (! inherits(obs, c("data.frame", "matrix"))) stop ("'obs' should be either a 'data.frame' or a 'matrix'") obs.pos <- matrix(nrow = 1, c(1, nrow(obs))) } DD <- duplicated(obsname) if (sum(DD) > 0) obs <- mergeObs(obs[,!DD], cbind(obs[, 1], obs[, DD])) nobs <- nrow(obs.pos) } return(list(dat = obs, pos = obs.pos, name = obsname, length = nobs)) } ## ============================================================================ ## create several lists: x2: other deSolve objects, ## dotmain, dotpoints: remaining (plotting) parameters ## ============================================================================ splitdots <- function(ldots, varnames){ x2 <- list() dots <- list() nd <- 0 nother <- 0 ndots <- names(ldots) if (length(ldots) > 0) for ( i in 1:length(ldots)) if (inherits(ldots[[i]], "deSolve")) { # a deSolve object x2[[nother <- nother + 1]] <- ldots[[i]] names(x2)[nother] <- ndots[i] # a list of deSolve objects } else if (is.list(ldots[[i]]) & inherits(ldots[[i]][[1]], "deSolve")) { for (j in 1:length(ldots[[i]])) { x2[[nother <- nother+1]] <- ldots[[i]][[j]] names(x2)[nother] <- names(ldots[[i]])[[j]] } } else if (! is.null(ldots[[i]])) { # a graphical parameter dots[[nd <- nd+1]] <- ldots[[i]] names(dots)[nd] <- ndots[i] } nmdots <- names(dots) # check compatibility of all deSolve objects if (nother > 0) { for ( i in 1:nother) { if (min(colnames(x2[[i]]) == varnames) == 0) stop("'x' is not compatible with other deSolve objects - colnames not the same") } } # plotting parameters : split in plot parameters and point parameters plotnames <- c("xlab", "ylab", "xlim", "ylim", "main", "sub", "log", "asp", "ann", "axes", "frame.plot", "panel.first", "panel.last", "cex.lab", "cex.axis", "cex.main") # plot.default parameters ii <- names(dots) %in% plotnames dotmain <- dots[ii] # point parameters ip <- !names(dots) %in% plotnames dotpoints <- dots[ip] list(points = dotpoints, main = dotmain, nother = nother, x2 = x2) } ## ============================================================================= ## Which variable in common between observed and selected variables ## ============================================================================= WhichVarObs <- function(Which, obs, nvar, varnames, remove1st = TRUE) { if (is.null(Which) & is.null(obs$dat)) # All variables plotted Which <- 1 : nvar else if (is.null(Which)) { # All common variables in x and obs plotted Which <- which(varnames %in% obs$name) if (remove1st) Which <- Which[Which != 1] # remove first element (x-value) Which <- varnames[Which] # names rather than numbers } return(Which) } ## ============================================================================= ## Update Obs with position of observed variable in x ## ============================================================================= updateObs <- function (obs, varnames, xWhich) { if (obs$length > 0 ) { obs$Which <- selectvar(varnames[xWhich], obs$name, NAallowed = TRUE) obs$Which [ obs$Which > ncol(obs$dat)] <- NA # if (nrow(obs$pos) != length(obs$Which)) # obs$pos <- matrix(nrow = length(obs$Which), ncol = ncol(obs$pos), # byrow = TRUE, data =obs$pos[1,]) } else obs$Which <- rep(NA, length(xWhich)) return(obs) } updateObs2 <- function (obs, varnames, xWhich) { if (obs$length > 0 ) { obs$Which <- selectvar(varnames[xWhich], obs$name, NAallowed = TRUE) obs$Which [ obs$Which > ncol(obs$dat)] <- NA if (nrow(obs$pos) != length(obs$Which)) obs$pos <- matrix(nrow = length(obs$Which), ncol = ncol(obs$pos), byrow = TRUE, data =obs$pos[1,]) } else obs$Which <- rep(NA, length(xWhich)) return(obs) } ## ============================================================================= ## Set range of a plot, depending on deSolve object and data... ## ============================================================================= SetRange <- function(lim, x, x2, isub, ix, obs, io, Log) { nother <- length (x2) if ( is.null (lim)) { yrange <- Range(NULL, x[isub, ix], Log) if (nother>0) for (j in 1:nother) yrange <- Range(yrange, x2[[j]][isub,ix], Log) if (! is.na(io)) yrange <- Range(yrange, obs$dat[,io], Log) } else yrange <- lim return(yrange) } ## ============================================================================= ## Add observed data to a plot ## ============================================================================= plotObs <- function (obs, io, xyswap = FALSE) { oLength <- min(nrow(obs$pos), obs$length) if (! xyswap) { for (j in 1: oLength) { i.obs <- obs$pos[j, 1] : obs$pos[j, 2] if (length (i.obs) > 0) do.call("points", c(alist(obs$dat[i.obs, 1], obs$dat[i.obs, io]), extractdots(obs$par, j) )) } } else { for (j in 1: oLength) if (length (i.obs <- obs$pos[j, 1]:obs$pos[j, 2]) > 0) do.call("points", c(alist(obs$dat[i.obs, io], obs$dat[i.obs, 1]), extractdots(obs$par, j) )) } } ### ============================================================================ ### Plotting 0-D variables ### ============================================================================ plot.deSolve <- function (x, ..., select = NULL, which = select, ask = NULL, obs = NULL, obspar = list(), subset = NULL) { t <- 1 # column with independent variable "times" # Set the observed data obs <- SetData(obs) # variables to be plotted varnames <- colnames(x) Which <- WhichVarObs(which, obs, ncol(x) - 1, varnames) # Position of variables to be plotted in "x" xWhich <- selectvar(Which, varnames) np <- length(xWhich) # Position of variables in "obs" (NA = not observed) obs <- updateObs(obs, varnames, xWhich) obs$par <- lapply(obspar, repdots, obs$length) # The ellipsis ldots <- list(...) # number of figures in a row and interactively wait if remaining figures ask <- setplotpar(ldots, np, ask) if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } Dots <- splitdots(ldots, varnames) nother <- Dots$nother x2 <- Dots$x2 nx <- nother + 1 # total number of deSolve objects to be plotted Dotmain <- setdots(Dots$main, np) # expand to np for each plot # these are different from the default Dotmain$xlab <- expanddots(ldots$xlab, varnames[t] , np) Dotmain$ylab <- expanddots(ldots$ylab, "" , np) Dotmain$main <- expanddots(ldots$main, varnames[xWhich], np) # ylim and xlim can be lists and are at least two values yylim <- expanddotslist(ldots$ylim, np) xxlim <- expanddotslist(ldots$xlim, np) Dotpoints <- setdots(Dots$points, nx) # expand all dots to nx values # these are different from default Dotpoints$type <- expanddots(ldots$type, "l", nx) Dotpoints$lty <- expanddots(ldots$lty, 1:nx, nx) Dotpoints$pch <- expanddots(ldots$pch, 1:nx, nx) Dotpoints$col <- expanddots(ldots$col, 1:nx, nx) Dotpoints$bg <- expanddots(ldots$bg, 1:nx, nx) if (!missing(subset)){ e <- substitute(subset) r <- eval(e, as.data.frame(x), parent.frame()) if (is.numeric(r)) { isub <- r } else { if (!is.logical(r)) stop("'subset' must evaluate to logical or be a vector with integers") isub <- r & !is.na(r) } } else { isub <- TRUE } # LOOP for each output variable (plot) for (ip in 1 : np) { ix <- xWhich[ip] # position of variable in 'x' io <- obs$Which[ip] # position of variable in 'obs' # plotting parameters for deSolve output 1 (opens a plot) dotmain <- extractdots(Dotmain, ip) dotpoints <- extractdots(Dotpoints, 1) # 1st dotpoints Xlog <- Ylog <- FALSE if (! is.null(dotmain$log)) { Ylog <- length(grep("y",dotmain$log)) Xlog <- length(grep("x",dotmain$log)) } dotmain$ylim <- SetRange(yylim[[ip]], x, x2, isub, ix, obs, io, Ylog) dotmain$xlim <- SetRange(xxlim[[ip]], x, x2, isub, t, obs, 1, Xlog) # first deSolve object plotted (new plot created) do.call("plot", c(alist(x[isub, t], x[isub, ix]), dotmain, dotpoints)) if (nother > 0) # if other deSolve outputs for (j in 2:nx) do.call("lines", c(alist(x2[[j-1]][isub, t], x2[[j-1]][isub, ix]), extractdots(Dotpoints, j)) ) if (! is.na(io)) plotObs(obs, io) # add observed variables } } ## ============================================================================= ## to draw a legend ## ============================================================================= drawlegend <- function (parleg, dots) { Plt <- par(plt = parleg) par(new = TRUE) usr <- par("usr") ix <- 1 minz <- dots$zlim[1] maxz <- dots$zlim[2] binwidth <- (maxz - minz)/64 iy <- seq(minz + binwidth/2, maxz - binwidth/2, by = binwidth) iz <- matrix(iy, nrow = 1, ncol = length(iy)) image(ix, iy, iz, xaxt = "n", yaxt = "n", xlab = "", ylab = "", col = dots$col) do.call("axis", list(side = 4, mgp = c(3, 1, 0), las = 2)) par(plt = Plt) par(usr = usr) par(new = FALSE) } ## ============================================================================= ## to drape a color over a persp plot. ## ============================================================================= drapecol <- function (A, col = colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000"))(100), NAcol = "white", Range = NULL) { nr <- nrow(A) nc <- ncol(A) ncol <- length(col) AA <- 0.25 * (A[1:(nr - 1), 1:(nc - 1)] + A[1:(nr - 1), 2:nc] + A[2:nr, 1:(nc - 1)] + A[2:nr, 2:nc]) if (is.null(Range)) Range <- range(A, na.rm = TRUE) else { AA[AA > Range[2]] <- Range[2] AA[AA < Range[1]] <- Range[1] } Ar <- Range rn <- Ar[2] - Ar[1] ifelse(rn != 0, drape <- col[1 + trunc((AA - Ar[1])/rn * (ncol - 1))], drape <- rep(col[1], ncol)) drape[is.na(drape)] <- NAcol return(drape) } ## ============================================================================= ## Finding 1-D variables ## ============================================================================= select1dvar <- function (Which, var, att) { if (is.null(att$map)) proddim <- prod(att$dimens) else proddim <- sum(!is.na(att$map)) ln <- length(Which) csum <- cumsum(att$lengthvar) + 2 if (!is.numeric(Which)) { # loop used to keep ordering... Select <- NULL for ( i in 1 : ln) { ss <- which(Which[i] == var) if (length(ss) == 0) stop("variable ", Which[i], " not in variable names") Select <- c(Select, ss) } } else { Select <- Which # "Select now refers to the column number if (max(Select) > length(var)) stop("index in 'which' too large") if (min(Select) < 1) stop("index in 'which' should be > 0") } istart <- numeric(ln) istop <- numeric(ln) for ( i in 1 : ln) { if (Select[i] <= att$nspec) { ii <- Select[i] istart[i] <- (ii-1)*proddim + 2 istop[i] <- istart[i] + proddim - 1 } else { ii <- Select[i] - att$nspec istart[i] <- csum[ii] istop[i] <- csum[ii+1]-1 } if (istart[i] == istop[i]) stop ("variable ",Which[i], " is not a 1-D variable") } return(list(Which = Select, istart = istart, istop = istop)) } ## ============================================================================= ## Finding 2-D variables ## ============================================================================= select2dvar <- function (Which, var, att) { if (is.null(att$map)) proddim <- prod(att$dimens) else proddim <- sum(!is.na(att$map)) ln <- length(Which) csum <- cumsum(att$lengthvar) + 2 if (!is.numeric(Which)) { # loop to keep ordering... Select <- NULL for ( i in 1 : ln) { ss <- which(Which[i] == var) if (length(ss) == 0) stop("variable ", Which[i], " not in variable names") Select <- c(Select, ss) } } else { Select <- Which # "Select now refers to the column number if (max(Select) > length(var)) stop("index in 'which' too large") if (min(Select) < 1) stop("index in 'which' should be > 0") } istart <- numeric(ln) istop <- numeric(ln) dimens <- list() for ( i in 1 : ln) { if (Select[i] <= att$nspec) { # a state variable ii <- Select[i] istart[i] <- (ii-1)*proddim + 2 istop[i] <- istart[i] + proddim-1 dimens[[i]] <- att$dimens } else { ii <- Select[i] - att$nspec istart[i] <- csum[ii] istop[i] <- csum[ii+1]-1 ij <- which(names(att$dimvar) == var[Select[i]]) if (length(ij) == 0) stop("variable ",var[Select]," is not two-dimensional") dimens[[i]] <- att$dimvar[[ij]] } } return(list(Which = Select, istart = istart, istop = istop, dim = dimens)) } ## ============================================================================= ## Adding a vertical axis to a plot ## ============================================================================= DrawVerticalAxis <- function (dot, xmin) { if (is.null(dot$xlim)) v <- xmin else v <- dot$xlim[1] abline(h = dot$ylim[2]) abline(v = v) axis(side = 2) axis(side = 3, mgp = c(3,0.5,0)) } ### ============================================================================ ### plotting 1-D variables as line plot, one for each time ### ============================================================================ plot.1D <- function (x, ... , select= NULL, which = select, ask = NULL, obs = NULL, obspar = list(), grid = NULL, xyswap = FALSE, delay = 0, vertical = FALSE, subset = NULL) { ## Check settings of x att <- attributes(x) nspec <- att$nspec dimens <- att$dimens proddim <- prod(dimens) if (length(dimens) != 1) stop ("plot.1D only works for models solved with 'ode.1D'") if ((ncol(x)- nspec*proddim) < 1) stop("ncol of 'x' should be > 'nspec' * dimens if x is a vector") # Set the observed data obs <- SetData(obs) # 1-D variable names varnames <- if (! is.null(att$ynames)) att$ynames else 1:nspec if (! is.null(att$lengthvar)) varnames <- c(varnames, names(att$lengthvar)[-1]) # variables to be plotted, common between obs and x Which <- WhichVarObs(which, obs, nspec, varnames, remove1st = FALSE) np <- length(Which) Select <- select1dvar(Which, varnames, att) xWhich <- Select$Which # add Position of variables to be plotted in "obs" obs <- updateObs (obs, varnames, xWhich) obs$par <- lapply(obspar, repdots, obs$length) # karline: small bug fixed here # the ellipsis ldots <- list(...) ## number of figures in a row and interactively wait if remaining figures ask <- setplotpar(ldots, np, ask) if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } Dots <- splitdots(ldots, colnames(x)) # for time-moving figures; number of plots should = mfrow settings prodx <- prod(par("mfrow")) if (np < prodx) eplot <- prodx - np else eplot <- 0 nother <- Dots$nother x2 <- Dots$x2 nx <- nother + 1 # total number of deSolve objects to be plotted Dotmain <- setdots(Dots$main, np) # expand to np for each plot Dotpoints <- setdots(Dots$points, nx) # These are different from defaulst Dotmain$xlab <- expanddots(ldots$xlab, "x", np) Dotmain$ylab <- expanddots(ldots$ylab, varnames[xWhich], np) # xlim and ylim are special: xxlim <- expanddotslist(ldots$xlim, np) yylim <- expanddotslist(ldots$ylim, np) xyswap <- rep(xyswap, length = np) vertical <- rep(vertical, length = np) grid <- expanddotslist(grid, np) if (!missing(subset)){ e <- substitute(subset) r <- eval(e, as.data.frame(x), parent.frame()) if (is.numeric(r)) { isub <- r } else { if (!is.logical(r)) stop("'subset' must evaluate to logical or be a vector with integers") isub <- which(r & !is.na(r)) } } else { isub <- 1:nrow(x) } # allow individual xlab and ylab (vectorized) times <- x[isub,1] Dotsmain <- expanddots(Dotmain$main, paste("time", times), length(times)) for (j in isub) { for (ip in 1:np) { istart <- Select$istart[ip] istop <- Select$istop[ip] io <- obs$Which[ip] out <- x[j,istart:istop] Grid <- grid[[ip]] if (is.null(Grid)) Grid <- 1:length(out) dotmain <- extractdots(Dotmain, ip) dotpoints <- extractdots(Dotpoints, 1) # 1st one dotmain$main <- Dotsmain[j] if (vertical[ip]) { # overrules other settings; vertical profiles xyswap[ip] <- TRUE dotmain$axes <- FALSE dotmain$xlab <- "" dotmain$xaxs <- "i" dotmain$yaxs <- "i" } Xlog <- Ylog <- FALSE if (! is.null(dotmain$log)) { Ylog <- length(grep("y",dotmain$log)) Xlog <- length(grep("x",dotmain$log)) } if (! xyswap[ip]) { if (! is.null(xxlim[[ip]])) dotmain$xlim <- xxlim[[ip]] dotmain$ylim <- SetRange(yylim[[ip]], x, x2, isub, istart:istop, obs, io, Ylog) } else { if (! is.null(yylim[[ip]])) dotmain$ylim <- yylim[[ip]] dotmain$xlim <- SetRange(xxlim[[ip]], x, x2, isub, istart:istop, obs, io, Xlog) if (is.null(yylim[[ip]]) & xyswap[ip]) dotmain$ylim <- rev(range(Grid)) # y-axis } if (! xyswap[ip]) { do.call("plot", c(alist(Grid, out), dotmain, dotpoints)) if (nother > 0) # if other deSolve outputs for (jj in 2:nx) do.call("lines", c(alist(Grid, x2[[jj-1]][j,istart:istop]), extractdots(Dotpoints, jj)) ) if (! is.na(io)) plotObs(obs, io) } else { if (is.null(Dotmain$xlab[ip]) | is.null(Dotmain$ylab[ip])) { dotmain$ylab <- Dotmain$xlab[ip] dotmain$xlab <- Dotmain$ylab[ip] } do.call("plot", c(alist(out, Grid), dotmain, dotpoints)) if (nother > 0) # if other deSolve outputs for (jj in 2:nx) do.call("lines", c(alist(x2[[jj-1]][j,istart:istop], Grid), extractdots(Dotpoints, jj)) ) if (vertical[ip]) DrawVerticalAxis(dotmain,min(out)) if (! is.na(io)) plotObs(obs, io, xyswap = TRUE) } } # end loop ip if (eplot > 0) for (i in 1:eplot) plot(0, type ="n", axes = FALSE, xlab="", ylab="") if (delay > 0) Sys.sleep(0.001 * delay) } } ### ============================================================================ plot.ode1D <- function (x, which, ask, add.contour, grid, method = "image", legend, isub = 1:nrow(x), ...) { # Default color scheme BlueRed <- colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000")) # if x is vector, check if there are enough columns ... att <- attributes(x) nspec <- att$nspec dimens <- att$dimens proddim <- prod(dimens) if ((ncol(x)- nspec * proddim) < 1) stop("ncol of 'x' should be > 'nspec' * dimens if x is a vector") # variables to be plotted if (is.null(which)) Which <- 1 : nspec else Which <- which np <- length(Which) varnames <- if (! is.null(att$ynames)) att$ynames else 1:nspec if (! is.null(att$lengthvar)) varnames <- c(varnames, names(att$lengthvar)[-1]) Select <- select1dvar(Which, varnames, att) Which <- Select$Which ldots <- list(...) # number of figures in a row and interactively wait if remaining figures ask <- setplotpar(ldots, np, ask) if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } Dotmain <- setdots(ldots, np) # expand dots to np values (no defaults) # different from the default Dotmain$main <- expanddots(ldots$main, varnames[Which], np) Dotmain$xlab <- expanddots(ldots$xlab, "times", np) Dotmain$ylab <- expanddots(ldots$ylab, "", np) # colors - different if persp, image or filled.contour if (method == "persp") dotscol <- ldots$col else if (method == "filled.contour") { dotscolorpalette <- if (is.null(ldots$color.palette)) BlueRed else ldots$color.palette dotscol <- dotscolorpalette(100) add.contour <- FALSE legend <- FALSE } else if (is.null(ldots$col)) dotscol <- BlueRed(100) else dotscol <- ldots$col Addcontour <- rep(add.contour, length = np) # xlim, ylim and zlim are special: xxlim <- expanddotslist(ldots$xlim, np) yylim <- expanddotslist(ldots$ylim, np) zzlim <- expanddotslist(ldots$zlim, np) times <- x[isub,1] if (legend) { parplt <- par("plt") - c(0,0.07,0,0) parleg <- c(parplt[2]+0.02, parplt[2]+0.05, parplt[3], parplt[4]) plt.or <- par(plt = parplt) # on.exit(par(plt = plt.or)) } # Check if grid is increasing... if (! is.null(grid)) gridOK <- min(diff (grid)) >0 else gridOK <- TRUE if (! gridOK) grid <- rev(grid) # for each output variable (plot) for (ip in 1:np) { # ix <- Which[ip] istart <- Select$istart[ip] istop <- Select$istop[ip] if (gridOK) out <- x[isub ,istart:istop] else out <- x[isub ,istop:istart] dotmain <- extractdots(Dotmain, ip) if (! is.null(xxlim)) dotmain$xlim <- xxlim[[ip]] if (! is.null(yylim)) dotmain$ylim <- yylim[[ip]] if (! is.null(zzlim)) dotmain$zlim <- zzlim[[ip]] else dotmain$zlim <- range(out, na.rm=TRUE) List <- alist(z = out, x = times) if (! is.null(grid)) List$y = grid if (method == "persp") { if (is.null(dotmain$zlim)) # this to prevent error when range = 0 if (diff(range(out, na.rm=TRUE)) == 0) dotmain$zlim <- c(0, 1) if (is.null(dotscol)) dotmain$col <- drapecol(out, col = BlueRed (100), Range = dotmain$zlim) else dotmain$col <- drapecol(out, col = dotscol, Range = dotmain$zlim) } else if (method == "filled.contour") dotmain$color.palette <- dotscolorpalette else dotmain$col <- dotscol do.call(method, c(List, dotmain)) if (Addcontour[ip]) do.call("contour", c(List, add = TRUE)) if (legend) { if (method == "persp") if (is.null(dotscol)) dotmain$col <- BlueRed(100) else dotmain$col <- dotscol if (is.null(dotmain$zlim)) dotmain$zlim <- range(out, na.rm=TRUE) drawlegend(parleg, dotmain) } } if (legend) { par(plt = plt.or) par(mar = par("mar")) # TRICK TO PREVENT R FROM SETTING DEFAULTPLOT = FALSE } } ### ============================================================================ ### plotting 2-D variables ### ============================================================================ plot.ode2D <- function (x, which, ask, add.contour, grid, method = "image", legend = TRUE, isub = 1:nrow(x), ...) { # Default color scheme BlueRed <- colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000")) # if x is vector, check if there are enough columns ... att <- attributes(x) nspec <- att$nspec dimens <- att$dimens proddim <- prod(dimens) Mask <- att$map map <- (! is.null(Mask)) if (!map & (ncol(x) - nspec*proddim) < 1) stop("ncol of 'x' should be > 'nspec' * dimens if x is a vector") # variables to be plotted if (is.null(which)) Which <- 1:nspec else Which <- which np <- length(Which) varnames <- if (! is.null(att$ynames)) att$ynames else 1:nspec if (! is.null(att$lengthvar)) varnames <- c(varnames, names(att$lengthvar)[-1]) Select <- select2dvar(Which,varnames,att) Which <- Select$Which ldots <- list(...) Mtext <- ldots$mtext ldots$mtext <- NULL # number of figures in a row and interactively wait if remaining figures Ask <- setplotpar(ldots, np, ask) # here ask is always true by default... if (is.null(ask)) ask <- TRUE if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } N <- np * nrow(x) if (method == "filled.contour") { add.contour <- FALSE legend <- FALSE } Dotmain <- setdots(ldots, N) # expand dots to np values (no defaults) # different from the default Dotmain$main <- expanddots(ldots$main, varnames[Which], N) Dotmain$xlab <- expanddots(ldots$xlab, "x" , N) Dotmain$ylab <- expanddots(ldots$ylab, "y" , N) if (method == "persp") dotscol <- ldots$col else if (method == "filled.contour") { dotscolorpalette <- if (is.null(ldots$color.palette)) BlueRed else ldots$color.palette dotscol <- dotscolorpalette(100) add.contour <- FALSE legend <- FALSE } else if (is.null(ldots$col)) dotscol <- BlueRed(100) else dotscol <- ldots$col dotslim <- ldots$zlim xxlim <- expanddotslist(ldots$xlim, np) yylim <- expanddotslist(ldots$ylim, np) zzlim <- expanddotslist(ldots$zlim, np) Addcontour <- rep(add.contour, length = np) i <- 0 if (legend) { parplt <- par("plt") - c(0, 0.05, 0, 0) parleg <- c(parplt[2] + 0.02, parplt[2] + 0.05, parplt[3], parplt[4]) plt.or <- par(plt = parplt) # on.exit(par(plt = plt.or)) } x <- x[isub,] if (length(isub) > 1 & sum (isub) == 1) x <- matrix (nrow = 1, data =x) if (! is.null(Mtext)) Mtext <- rep(Mtext, length.out = nrow(x)) for (nt in 1:nrow(x)) { for (ip in 1:np) { i <- i+1 istart <- Select$istart[ip] istop <- Select$istop[ip] if (map) { out <- rep (NA, length = prod(Select$dim[[ip]])) ii <- which (! is.na(Mask)) out[ii] <- x[nt, istart:istop] } else out <- x[nt, istart:istop] dim(out) <- Select$dim[[ip]] dotmain <- extractdots(Dotmain, i) if (! is.null(xxlim)) dotmain$xlim <- xxlim[[ip]] if (! is.null(yylim)) dotmain$ylim <- yylim[[ip]] if (! is.null(zzlim)) dotmain$zlim <- zzlim[[ip]] else { dotmain$zlim <- range(out, na.rm=TRUE) if (diff(dotmain$zlim ) == 0 ) dotmain$zlim[2] <- dotmain$zlim[2] +1 } if (map) { if (is.null(dotmain$zlim)) dotmain$zlim <- range(out, na.rm=TRUE) out[is.na(out)] <- dotmain$zlim[1] - 0.01*max(1e-18,diff(dotmain$zlim)) dotmain$zlim [1] <- dotmain$zlim[1] - 0.01*max(1e-18,diff(dotmain$zlim)) } List <- alist(z = out) if (! is.null(grid)) { List$x <- grid$x List$y <- grid$y } if (method == "persp") { if (is.null(dotmain$zlim)) if (diff(range(out, na.rm = TRUE)) == 0) dotmain$zlim <- c(0, 1) if (is.null(dotscol)) dotmain$col <- drapecol(out, col = BlueRed(100), Range = dotmain$zlim) else dotmain$col <- drapecol(out, col = dotscol, Range = dotmain$zlim) } else if (method == "image") { dotmain$col <- dotscol if (map) dotmain$col <- c("black", dotmain$col) } else if (method == "filled.contour") dotmain$color.palette <- dotscolorpalette do.call(method, c(List, dotmain)) drawbox <- ! method %in% c("persp", "filled.contour") if (! is.null(ldots$frame.plot)) if (! ldots$frame.plot) drawbox <- FALSE if (drawbox) box() if (add.contour) do.call("contour", c(List, add = TRUE)) if (legend) { if (method == "persp") if (is.null(dotscol)) dotmain$col <- BlueRed(100) else dotmain$col <- dotscol if (is.null(dotmain$zlim)) dotmain$zlim <- range(out, na.rm=TRUE) drawlegend(parleg, dotmain) } } if (! is.null(Mtext)) mtext(outer = TRUE, side = 3, Mtext[nt], cex = 1.5, line = par("oma")[3]-1.5) } if (legend) { par(plt = plt.or) par(mar = par("mar")) # TRICK TO PREVENT R FROM SETTING DEFAULTPLOT = FALSE } # karline: ??? removed that... make it an argument? # if (sum(par("mfrow") - c(1, 1)) == 0 ) # mtext(outer = TRUE, side = 3, paste("time ", x[nt, 1]), # cex = 1.5, line = -1.5) } ### ============================================================================ ### Summaries of ode variables ### ============================================================================ summary.deSolve <- function(object, select = NULL, which = select, subset = NULL, ...){ att <- attributes(object) svar <- att$lengthvar[1] # number of state variables lvar <- att$lengthvar[-1] # length of other variables nspec <- att$nspec # for models solved with ode.1D, ode.2D dimens <- att$dimens if (is.null(svar)) svar <- att$dim[2]-1 # models solved as DLL # variable names: information for state and ordinary variables is different if (is.null(att$ynames)) if (is.null(dimens)) varnames <- colnames(object)[2:(svar+1)] else varnames <- 1:nspec else varnames <- att$ynames # this gives one name for multi-dimensional var. if (length(lvar) > 0) { lvarnames <- names(lvar) if (is.null(lvarnames)) lvarnames <- (length(varnames)+1):(length(varnames)+length(lvar)) varnames <- c(varnames, lvarnames) } # length of state AND other variables if (is.null(dimens)) # all 0-D state variables lvar <- c(rep(1, len = svar), lvar) else lvar <- c(rep(prod(dimens), nspec), lvar) # multi-D state variables if (!missing(subset)){ e <- substitute(subset) r <- eval(e, as.data.frame(object), parent.frame()) if (is.numeric(r)) { isub <- r } else { if (!is.logical(r)) stop("'subset' must evaluate to logical or be a vector with integers") isub <- r & !is.na(r) object <- object[isub,] } } # summaries for all variables Summ <- NULL for (i in 1:length(lvar)) { if (lvar[i] > 1) { Select <- select1dvar(i, varnames, att) out <- as.vector(object[, Select$istart:Select$istop]) } else { Select <- selectvar(varnames[i], colnames(object), NAallowed = TRUE) if (is.na(Select)) # trick for composite names, e.g. "A.x" rather than "A" Select <- cumsum(lvar)[i] out <- object[ ,Select] } Summ <- rbind(Summ, c(summary(out, ...), N = length(out), sd = sd(out))) } rownames(Summ) <- varnames # rownames or an extra column? if (! is.null(which)) Summ <- Summ[which,] data.frame(t(Summ)) # like this or not transposed? } ### ============================================================================ ### Subsets of ode variables ### ============================================================================ subset.deSolve <- function(x, subset = NULL, select = NULL, which = select, arr = FALSE, ...) { Which <- which # for compatibility between plot.deSolve and subset if (arr & length(Which) > 1) stop("cannot combine 'arr = TRUE' when more than one variable is selected") if (missing(subset)) r <- TRUE else { e <- substitute(subset) r <- eval(e, as.data.frame(x), parent.frame()) if (is.numeric(r)) { isub <- r } else { if (!is.logical(r)) stop("'subset' must evaluate to logical or be a vector with integers") r <- r & !is.na(r) } } if (is.numeric(Which)) return(x[r ,Which+1]) if (is.null(Which)) return(x[r , -1]) # Default: all variables, except time att <- attributes(x) svar <- att$lengthvar[1] # number of state variables lvar <- att$lengthvar[-1] # length of other variables nspec <- att$nspec # for models solved with ode.1D, ode.2D dimens <- att$dimens if (arr & length(dimens) <= 1 ) warning("does not make sense to have 'arr = TRUE' when output is not 2D or 3D") if (is.null(svar)) svar <- att$dim[2]-1 # models solved as DLL if(is.null(nspec)) nspec <- svar # variable names: information for state and ordinary variables is different if (is.null(att$ynames)) if (is.null(dimens)) varnames <- colnames(x)[2:(svar+1)] else varnames <- 1:nspec else varnames <- att$ynames # this gives one name for multi-dimensional var. varnames <- c("time",varnames) if (length(lvar) > 0) { lvarnames <- names(lvar) if (is.null(lvarnames)) lvarnames <- (length(varnames)+1):(length(varnames)+length(lvar)) varnames <- c(varnames, lvarnames) } # length of state AND other variables if (is.null(dimens)) # all 0-D state variables lvar <- c(rep(1, len = svar), lvar) else lvar <- c(rep(prod(dimens), nspec), lvar) # multi-D state variables cvar <- cumsum(c(1,lvar)) # Add selected variables to Out Out <- NULL for (iw in 1:length(Which)) { i <- which (varnames == Which[iw]) if (length(i) == 0) { i <- which (colnames(x) == Which[iw]) if (length(i) == 0) stop ("cannot find variable ", Which[iw], " in output") Out <- cbind(Out, x[,i]) } else { if (is.null(i)) stop ("cannot find variable ", Which[iw], " in output") istart <- 1 if (i > 1) istart <- cvar[i-1]+1 istop <- cvar[i] Out <- cbind(Out, x[ ,istart:istop]) } } if (length(Which) == ncol(Out)) colnames(Out) <- Which OO <- Out[r, ] if(is.vector(OO)) OO <- matrix(ncol = ncol(Out), data = OO) times <- x[r,1] if (arr & length(dimens) > 1 & ncol(OO) == prod(dimens)) { Nr <- nrow(OO) OO <- array(dim = c(dimens, Nr) , data = t(OO)) } attr(OO, "times") <- times return(OO) } deSolve/R/radau.R0000644000176000001440000002454413572677236013356 0ustar ripleyusers ### ============================================================================ ### radau, implicit runge-kutta ### ============================================================================ radau <- function(y, times, func, parms, nind = c(length(y), 0, 0), rtol = 1e-6, atol = 1e-6, jacfunc = NULL, jactype = "fullint", mass = NULL, massup = NULL, massdown = NULL, rootfunc = NULL, verbose = FALSE, nroot = 0, hmax = NULL, hini = 0, ynames = TRUE, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, events = NULL, lags = NULL,...) { ### check input if (is.list(func)) { ### IF a list if (!is.null(jacfunc) & "jacfunc" %in% names(func)) stop("If 'func' is a list that contains jacfunc, argument 'jacfunc' should be NULL") if (!is.null(rootfunc) & "rootfunc" %in% names(func)) stop("If 'func' is a list that contains rootfunc, argument 'rootfunc' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(func)) stop("If 'func' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(func)) { if (! is.null(events)) events$func <- func$eventfunc else events <- list(func = func$eventfunc) } jacfunc <- func$jacfunc rootfunc <- func$rootfunc initfunc <- func$initfunc initforc <- func$initforc func <- func$func } hmax <- checkInput (y, times, func, rtol, atol, NULL, NULL, 0, hmax, hini, dllname) n <- length(y) if (is.null(hini)) hini <- 0 if (hini <= 0) hini <- 0 ### atol and rtol have to be of same length here... if (length(rtol) != length(atol)) { if (length(rtol) > length(atol)) atol <- rep(atol, length.out=n) else rtol <- rep(rtol, length.out=n) } ### Number of steps until the solver gives up nsteps <- min(.Machine$integer.max, maxsteps * length(times)) ### index if (length(nind) != 3) stop("length of `nind' must be =3") if (sum(nind) != n) stop("sum of of `nind' must equal n, the number of equations") ### Jacobian full <- TRUE if (jactype == "fullint" ) { # full, calculated internally ijac <- 0 banddown <- n bandup <- n } else if (jactype == "fullusr" ) { # full, specified by user function ijac <- 1 banddown <- n bandup <- n } else if (jactype == "bandusr" ) { # banded, specified by user function ijac <- 1 full <- FALSE if (is.null(banddown) || is.null(bandup)) stop("'bandup' and 'banddown' must be specified if banded Jacobian") } else if (jactype == "bandint" ) { # banded, calculated internally ijac <- 0 full <- FALSE if (is.null(banddown) || is.null(bandup)) stop("'bandup' and 'banddown' must be specified if banded Jacobian") } else stop("'jactype' must be one of 'fullint', 'fullusr', 'bandusr' or 'bandint'") nrjac <- as.integer(c(ijac, banddown, bandup)) # check other specifications depending on Jacobian if (ijac == 1 && is.null(jacfunc)) stop ("'jacfunc' NOT specified; either specify 'jacfunc' or change 'jactype'") ### model and Jacobian function JacFunc <- NULL Ynames <- attr(y,"names") flist <- list(fmat=0,tmat=0,imat=0,ModelForc=NULL) ModelInit <- NULL RootFunc <- NULL Eventfunc <- NULL events <- checkevents(events, times, Ynames, dllname, TRUE) if (! is.null(events$newTimes)) times <- events$newTimes if (is.character(func) | inherits(func, "CFunc")) { # function specified in a DLL or inline compiled DLL <- checkDLL(func,jacfunc,dllname, initfunc,verbose,nout, outnames) ## Is there a root function? if (!is.null(rootfunc)) { if (!is.character(rootfunc) & !inherits(rootfunc, "CFunc")) stop("If 'func' is dynloaded, so must 'rootfunc' be") rootfuncname <- rootfunc if (inherits(rootfunc, "CFunc")) RootFunc <- body(rootfunc)[[2]] else if (is.loaded(rootfuncname, PACKAGE = dllname)) { RootFunc <- getNativeSymbolInfo(rootfuncname, PACKAGE = dllname)$address } else stop(paste("root function not loaded in DLL",rootfunc)) if (nroot == 0) stop("if 'rootfunc' is specified in a DLL, then 'nroot' should be > 0") } ModelInit <- DLL$ModelInit Func <- DLL$Func JacFunc <- DLL$JacFunc Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,verbose,fcontrol) if (is.null(ipar)) ipar<-0 if (is.null(rpar)) rpar<-0 Eventfunc <- events$func if (is.function(Eventfunc)) rho <- environment(Eventfunc) else rho <- emptyenv() } else { if (is.null(initfunc)) initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) # func overruled, either including ynames, or not # This allows to pass the "..." arguments and the parameters if (ynames) { Func <- function(time,state) { attr(state,"names") <- Ynames unlist(func (time,state,parms,...)) } Func2 <- function(time,state) { attr(state,"names") <- Ynames func (time,state,parms,...) } JacFunc <- function(time,state) { attr(state,"names") <- Ynames jacfunc(time,state,parms,...) } RootFunc <- function(time,state) { attr(state,"names") <- Ynames rootfunc(time,state,parms,...) } if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) { attr(state,"names") <- Ynames events$func(time,state,parms,...) } } else { # no ynames... Func <- function(time,state) unlist(func (time,state,parms,...)) Func2 <- function(time,state) func (time,state,parms,...) JacFunc <- function(time,state) jacfunc(time,state,parms,...) RootFunc <- function(time,state) rootfunc(time,state,parms,...) if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) events$func(time,state,parms,...) } ## Check function and return the number of output variables +name FF <- checkFunc(Func2,times,y,rho) Nglobal<-FF$Nglobal Nmtot <- FF$Nmtot ## Check event function if (! is.null(events$Type)) if (events$Type == 2) checkEventFunc(Eventfunc,times,y,rho) ## Check jacobian function if (ijac == 1) { tmp <- eval(JacFunc(times[1], y), rho) if (!is.matrix(tmp)) stop("Jacobian function 'jacfunc' must return a matrix\n") dd <- dim(tmp) if ((!full && any(dd != c(bandup+banddown+1,n))) || ( full && any(dd != c(n,n)))) stop("Jacobian dimension not ok") } ## and for rootfunc if (! is.null(rootfunc)) { tmp2 <- eval(rootfunc(times[1],y,parms,...), rho) if (!is.vector(tmp2)) stop("root function 'rootfunc' must return a vector\n") nroot <- length(tmp2) } else nroot = 0 } ### The mass matrix mlmas <- n mumas <- n if (is.null(mass)) { imas <- 0 lmas <- n MassFunc <- NULL } else { imas <- 1 dimens <- dim(mass) if(is.null(dimens)) { mass <- matrix(nrow = 1, data = mass) dimens <- dim(mass) } if (dimens[2] != n) stop ("mass matrix should have as many columns as number of variables in 'y'") if (dimens[1] != n) { mumas <- massup mlmas <- massdown if (dimens[1] != mlmas + mumas +1) stop ("nr of rows in mass matrix should equal the number of variables in 'y' or 'massup'+'massdown'+1 ") } MassFunc <- function (n,lm) { if (nrow(mass) != lm || ncol(mass) != n) stop ("dimensions of mass matrix not ok") return(mass) } } lmas <- n nrmas <- as.integer(c(imas, mlmas, mumas)) if (banddown == n) { ljac <- n if (imas == 1) lmas <- n le <- n } else { ljac <- banddown + bandup + 1 lmas <- mlmas + mumas + 1 le <- 2*banddown + bandup + 1 } ### work arrays iwork, rwork # length of rwork and iwork lrw <- n * (ljac + lmas + 3*le + 12) + 20 liw <- 20 + 3*n # only first 20 elements passed; other will be allocated in C-code iwork <- vector("integer",20) rwork <- vector("double",20) rwork[] <- 0. iwork[] <- 0 iwork[2] <- nsteps iwork[5:7] <- nind rwork[1] <- .Machine$double.neg.eps rwork[2] <- 0.9 # safety factor error reductin rwork[3] <- 0.001 # recalculation of jacobian factor rwork[7] <- hmax if(is.null(times)) times<-c(0,1e8) ### print to screen... if (verbose) { printtask(0,func,jacfunc) printM("\n--------------------") printM("Integration method") printM("--------------------") printM( "radau5") } ### lags <- checklags(lags,dllname) ### calling solver storage.mode(y) <- storage.mode(times) <- "double" tcrit <- NULL on.exit(.C("unlock_solver")) out <- .Call("call_radau",y,times,Func,MassFunc,JacFunc,initpar, rtol, atol, nrjac, nrmas, rho, ModelInit, as.double(rwork), as.integer(iwork), as.integer(Nglobal), as.integer(lrw),as.integer(liw), as.double (rpar), as.integer(ipar), as.double(hini), flist, lags, RootFunc, as.integer(nroot), Eventfunc, events, PACKAGE="deSolve") ### saving results out <- saveOut(out, y, n, Nglobal, Nmtot, func, Func2, iin= 1:7, iout=c(1,3,4,2,13,13,10)) attr(out, "type") <- "radau5" if (verbose) diagnostics(out) return(out) } deSolve/R/iteration.R0000644000176000001440000000670313572677236014255 0ustar ripleyusers### ============================================================================ ### Interface to C code for Euler's ODE solver ### with fixed step size and without interpolation, see helpfile for details. ### ============================================================================ iteration <- function(y, times, func, parms, hini = NULL, verbose = FALSE, ynames = TRUE, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, ...) { if (is.list(func)) { ### IF a list if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") initfunc <- func$initfunc initforc <- func$initforc func <- func$func } if (abs(diff(range(diff(times)))) > 1e-10) stop (" times should be equally spaced") dt <- diff(times[1:2]) if (is.null(hini)) hini <- dt nsteps <- as.integer(dt / hini) if (nsteps == 0) stop (" hini should be smaller than times interval ") if (nsteps * hini != dt) warning(" hini recalculated as integer fraction of times interval ",dt/nsteps) ## check input checkInputEuler(y, times, func, dllname) n <- length(y) ## Model as shared object (DLL)? Ynames <- attr(y, "names") Initfunc <- NULL flist <-list(fmat = 0, tmat = 0, imat = 0, ModelForc = NULL) Nstates <- length(y) # assume length of states is correct if (is.character(func) | inherits(func, "CFunc")) { DLL <- checkDLL(func, NULL, dllname, initfunc, verbose, nout, outnames) Initfunc <- DLL$ModelInit Func <- DLL$Func Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings, times, dllname, initforc, verbose, fcontrol) rho <- NULL if (is.null(ipar)) ipar <- 0 if (is.null(rpar)) rpar <- 0 } else { initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) ## func and jac are overruled, either including ynames, or not ## This allows to pass the "..." arguments and the parameters if(ynames) { Func <- function(time, state, parms) { attr(state, "names") <- Ynames func (time, state, parms, ...) } } else { # no ynames ... Func <- function(time, state, parms) func (time, state, parms, ...) } ## Call func once to figure out whether and how many "global" ## results it wants to return and some other safety checks FF <- checkFuncEuler(Func, times, y, parms, rho, Nstates) Nglobal <- FF$Nglobal Nmtot <- FF$Nmtot } ## the CALL to the integrator on.exit(.C("unlock_solver")) out <- .Call("call_iteration", as.double(y), as.double(times), nsteps, Func, Initfunc, parms, as.integer(Nglobal), rho, as.integer(verbose), as.double(rpar), as.integer(ipar), flist, PACKAGE = "deSolve") ## saving results out <- saveOutrk(out, y, n, Nglobal, Nmtot, iin = c(1, 12, 13, 15), iout = c(1:3, 18)) attr(out, "type") <- "iteration" if (verbose) diagnostics(out) out } deSolve/R/lsoda.R0000644000176000001440000002215513572677236013360 0ustar ripleyusers# ks 21-12-09: Func <- unlist() ... output variables now set in C-code ### ============================================================================ ### lsoda -- solves ordinary differential equation systems ### Compared to the other integrators of odepack ### lsoda switches automatically between stiff and nonstiff methods. ### This means that the user does not have to determine whether the ### problem is stiff or not, and the solver will automatically choose the ### appropriate method. It always starts with the nonstiff method. ### ============================================================================ lsoda <- function(y, times, func, parms, rtol=1e-6, atol=1e-6, jacfunc=NULL, jactype = "fullint", rootfunc = NULL, verbose = FALSE, nroot = 0, tcrit = NULL, hmin=0, hmax=NULL, hini=0, ynames=TRUE, maxordn = 12, maxords = 5, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname=NULL, initfunc=dllname, initpar=parms, rpar=NULL, ipar=NULL, nout=0, outnames=NULL, forcings=NULL, initforc = NULL, fcontrol = NULL, events = NULL, lags=NULL, ...) { ### check input if (! is.null(rootfunc)) return(lsodar (y, times, func, parms, rtol, atol, jacfunc, jactype, rootfunc, verbose, nroot, tcrit, hmin, hmax, hini, ynames, maxordn, maxords, bandup, banddown, maxsteps, dllname, initfunc, initpar, rpar, ipar, nout, outnames, forcings, initforc, fcontrol, events, lags, ...)) if (is.list(func)) { ### IF a list if (!is.null(jacfunc) & "jacfunc" %in% names(func)) stop("If 'func' is a list that contains jacfunc, argument 'jacfunc' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(func)) stop("If 'func' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(func)) { if (! is.null(events)) events$func <- func$eventfunc else events <- list(func = func$eventfunc) } if (!is.null(func$jacfunc)) jacfunc <- func$jacfunc if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$dllname)) dllname <- func$dllname if (!is.null(func$initforc)) initforc <- func$initforc func <- func$func } hmax <- checkInput (y, times, func, rtol, atol, jacfunc, tcrit, hmin, hmax, hini, dllname) n <- length(y) if (!is.numeric(maxordn)) stop("`maxordn' must be numeric") if(maxordn < 1 || maxordn > 12) stop("`maxord' must be >1 and <=12") if (!is.numeric(maxords)) stop("`maxords' must be numeric") if(maxords < 1 || maxords > 5) stop("`maxords' must be >1 and <=5") ### Jacobian, method flag if (jactype == "fullint" ) jt <- 2 # full, calculated internally else if (jactype == "fullusr" ) jt <- 1 # full, specified by user function else if (jactype == "bandusr" ) jt <- 4 # banded, specified by user function else if (jactype == "bandint" ) jt <- 5 # banded, calculated internally else stop("'jactype' must be one of 'fullint', 'fullusr', 'bandusr' or 'bandint'") ## check other specifications depending on Jacobian if (jt %in% c(4,5) && is.null(bandup)) stop("'bandup' must be specified if banded Jacobian") if (jt %in% c(4,5) && is.null(banddown)) stop("'banddown' must be specified if banded Jacobian") if (is.null(banddown)) banddown <-1 if (is.null(bandup )) bandup <-1 if (jt %in% c(1,4) && is.null(jacfunc)) stop ("'jacfunc' NOT specified; either specify 'jacfunc' or change 'jactype'") ### model and Jacobian function Ynames <- attr(y,"names") JacFunc <- NULL flist<-list(fmat=0,tmat=0,imat=0,ModelForc=NULL) ModelInit <- NULL Eventfunc <- NULL events <- checkevents(events, times, Ynames, dllname) # KS: added... if (! is.null(events$newTimes)) times <- events$newTimes if (jt == 4 && banddown>0) erow<-matrix(data=0, ncol=n, nrow=banddown) else erow<-NULL if (is.character(func) | inherits(func, "CFunc")) { # function specified in a DLL or inline compiled DLL <- checkDLL(func, jacfunc, dllname, initfunc, verbose, nout, outnames) ModelInit <- DLL$ModelInit Func <- DLL$Func JacFunc <- DLL$JacFunc Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,verbose,fcontrol) if (is.null(ipar)) ipar<-0 if (is.null(rpar)) rpar<-0 Eventfunc <- events$func if (is.function(Eventfunc)) rho <- environment(Eventfunc) else rho <- NULL } else { if(is.null(initfunc)) initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) ## func and jac are overruled, either including ynames, or not ## This allows to pass the "..." arguments and the parameters if (ynames) { Func <- function(time,state) { attr(state,"names") <- Ynames unlist(func (time,state,parms,...)) } Func2 <- function(time,state) { attr(state,"names") <- Ynames func (time,state,parms,...) } JacFunc <- function(time,state) { attr(state,"names") <- Ynames rbind(jacfunc(time,state,parms,...),erow) } if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) { attr(state,"names") <- Ynames events$func(time,state,parms,...) } } else { # no ynames... Func <- function(time,state) unlist(func (time,state,parms,...)) Func2 <- function(time,state) func (time,state,parms,...) JacFunc <- function(time,state) rbind(jacfunc(time,state,parms,...),erow) if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) events$func(time,state,parms,...) } ## Check function and return the number of output variables +name FF <- checkFunc(Func2,times,y,rho) Nglobal<-FF$Nglobal Nmtot <- FF$Nmtot if (! is.null(events$Type)) if (events$Type == 2) checkEventFunc(Eventfunc,times,y,rho) if (jt %in% c(1,4)) { tmp <- eval(JacFunc(times[1], y), rho) if (!is.matrix(tmp)) stop("Jacobian function, 'jacfunc' must return a matrix\n") dd <- dim(tmp) if((jt ==4 && any(dd != c(bandup+banddown+banddown+1,n))) || (jt ==1 && any(dd != c(n,n)))) # thpe: add any (2 times) stop("Jacobian dimension not ok") } } ### work arrays iwork, rwork # length of rwork and iwork if(jt %in% c(1,2)) lmat <- n^2+2 else if(jt %in% c(4,5)) lmat <- (2*banddown+bandup+1)*n+2 lrn = 20+n*(maxordn+1)+ 3*n # length in case non-stiff method lrs = 20+n*(maxords+1)+ 3*n +lmat # length in case stiff method lrw = max(lrn,lrs) # actual length: max of both liw = 20 + n # only first 20 elements passed to solver; other will be allocated in C-code iwork <- vector("integer",20) rwork <- vector("double",20) rwork[] <- 0. iwork[] <- 0 iwork[1] <- banddown iwork[2] <- bandup iwork[6] <- maxsteps if (maxordn != 12) iwork[8] <- maxordn if (maxords != 5) iwork[9] <- maxords if (verbose) iwork[5] = 1 # prints method switches to screen if(! is.null(tcrit)) rwork[1] <- tcrit rwork[5] <- hini rwork[6] <- hmax rwork[7] <- hmin ### the task to be performed. if (! is.null(times)) itask <- ifelse (is.null (tcrit), 1,4) else # times specified itask <- ifelse (is.null (tcrit), 2,5) # only one step if(is.null(times)) times<-c(0,1e8) ### print to screen... if (verbose) printtask(itask,func,jacfunc) ### calling solver storage.mode(y) <- storage.mode(times) <- "double" IN <-1 lags <- checklags(lags,dllname) on.exit(.C("unlock_solver")) out <- .Call("call_lsoda",y,times,Func,initpar, rtol, atol, rho, tcrit, JacFunc, ModelInit, Eventfunc, as.integer(verbose), as.integer(itask), as.double(rwork), as.integer(iwork), as.integer(jt), as.integer(Nglobal), as.integer(lrw),as.integer(liw), as.integer(IN), NULL, 0L, as.double(rpar), as.integer(ipar), 0L, flist, events, lags, PACKAGE="deSolve") ### saving results out <- saveOut(out, y, n, Nglobal, Nmtot, func, Func2, iin=c(1,12:21), iout=c(1:3,14,5:9,15:16), nr = 5) attr(out, "type") <- "lsoda" if (verbose) diagnostics(out) out } deSolve/R/forcings.R0000644000176000001440000001236713572677236014074 0ustar ripleyusers### ============================================================================ ### Check forcing function data set, event inputs and time-lag input ### ============================================================================ checkforcings <- function (forcings, times, dllname, initforc, verbose, fcontrol = list()) { ## Check the names of the initialiser function if (is.null(initforc)) stop(paste("initforc should be loaded if there are forcing functions ",initforc)) if (inherits (initforc, "CFunc")) { ModelForc <- body(initforc)[[2]] } else if (is.loaded(initforc, PACKAGE = dllname, type = "") || is.loaded(initforc, PACKAGE = dllname, type = "Fortran")) { ModelForc <- getNativeSymbolInfo(initforc, PACKAGE = dllname)$address } else stop(paste("initforc should be loaded if there are forcing functions ",initforc)) ## Check the type of the forcing function data series if (is.data.frame(forcings)) forcings <- list(a=forcings) if (! is.list(forcings)) forcings <- list(a=forcings) nf <- length(forcings) #1 check if each forcing function consists of a 2-columned matrix for (i in 1:nf) { if (ncol(forcings[[i]]) != 2) stop("forcing function data sets should consist of two-colum matrix") } ## Check the control elements (see optim code) con <- list(method="linear", rule = 2, f = 0, ties = "ordered") nmsC <- names(con) con[(namc <- names(fcontrol))] <- fcontrol if (length(noNms <- namc[!namc %in% nmsC]) > 0) warning("unknown names in fcontrol: ", paste(noNms, collapse = ", ")) method <- pmatch(con$method, c("linear", "constant")) if (is.na(method)) stop("invalid interpolation method for forcing functions") # 1 if linear, 2 if constant... ## Check the timespan of the forcing function data series # time span of forcing function data sets should embrace simulation time... # although extrapolation is allowed if con$rule = 2 (the default) r_t <- range(times) for (i in 1:nf) { r_f <- range(forcings[[i]][,1]) # time range of this forcing function if (r_f[1] > r_t[1]) { if (con$rule == 2) { mint <- c(r_t[1],forcings[[i]][1,2] ) forcings[[i]] <- rbind(mint,forcings[[i]]) if(verbose) warning(paste("extrapolating forcing function data sets to first timepoint",i)) } else stop(paste("extrapolating forcing function data sets to first timepoint",i)) } nr <- nrow(forcings[[i]]) if (r_f[2] < r_t[2]) { if (con$rule == 2) { maxt <- c(r_t[2],forcings[[i]][nr,2] ) forcings[[i]] <- rbind(forcings[[i]],maxt) if(verbose) warning(paste("extrapolating forcing function data sets to last timepoint",i)) } else stop(paste("extrapolating forcing function data sets to last timepoint",i)) } } ## Check what needs to be done in case the time series is not "ordered" if (!identical(con$ties, "ordered")) { # see approx code for (i in 1:nf) { x <- forcings[[i]][,1] nx <- length(x) if (length(ux <- unique(x)) < nx) { # there are non-unique values y <- forcings[[i]][,2] ties <- con$tiesn if (missing(ties)) warning("collapsing to unique 'x' values") y <- as.vector(tapply(y, x, ties)) x <- sort(ux) forcings[[i]] <- cbind(x, y) } else { # values are unique, but need sorting y <- forcings[[i]][,2] o <- order(x) x <- x[o] y <- y[o] forcings[[i]] <- cbind(x,y) } } # i } ## In case the interpolation is of type "constant" and f not equal to 0 ## convert y-series, so that always the left value is taken if (method == 2 & con$f != 0) { for (i in 1:nf) { y <- forcings[[i]][,2] YY <- c(y,y[length(y)])[-1] forcings[[i]][,2] <- (1-con$f)*y + con$f*YY } } ## all forcings in one vector; adding index to start/end fmat <- tmat <- NULL imat <- rep(1,nf+1) for (i in 1:nf) { # Karline: check for NA in forcing series and remove those ii <- apply(forcings[[i]],1,function(x)any(is.na(x))) if (sum(ii) > 0) forcings[[i]] <- forcings[[i]][!ii,] tmat <- c(tmat, forcings[[i]][,1]) fmat <- c(fmat, forcings[[i]][,2]) imat[i+1]<-imat[i]+nrow(forcings[[i]]) } storage.mode(tmat) <- storage.mode(fmat) <- "double" storage.mode(imat) <- "integer" # DIRTY trick not to inflate the number of arguments: # add method (linear/constant) to imat return(list(tmat = tmat, fmat = fmat, imat = c(imat, method), ModelForc = ModelForc)) } ### ============================================================================ ### Check timelags data set - also passes "dllname" now (not yet used) ### ============================================================================ checklags <- function (lags, dllname) { if (!is.null(lags)) { lags$islag = 1L if (is.null(lags$mxhist)) lags$mxhist <- 1e4 if (lags$mxhist <1) lags$mxhist <- 1e4 lags$mxhist<-as.integer(lags$mxhist) if (is.null(lags$interpol)) # 1= hermitian, 2 = higher order interpolation lags$interpol <- 1 lags$interpol<-as.integer(lags$interpol) lags$isfun <- 0L } else lags$islag <- 0L return(lags) } deSolve/R/functions.R0000644000176000001440000003143713572677236014271 0ustar ripleyusers## ======================================================================== ## General functions of deSolve ## ======================================================================== timestep <- function (prev = TRUE) { out <- .Call("getTimestep", PACKAGE = "deSolve") if (prev) return(out[1]) else return(out[2]) } ## ======================================================================== ## Check solver input - livermore solvers and rk ## ======================================================================== checkInput <- function(y, times, func, rtol, atol, jacfunc, tcrit, hmin, hmax, hini, dllname, jacname = "jacfunc") { if (!is.numeric(y)) stop("`y' must be numeric") n <- length(y) if (! is.null(times) && !is.numeric(times)) stop("`times' must be NULL or numeric") if (!is.function(func) && !is.character(func)) stop("`func' must be a function or character vector") if (is.character(func) && (is.null(dllname) || !is.character(dllname))) stop("specify the name of the dll or shared library where func can be found (without extension)") if (!is.numeric(rtol)) stop("`rtol' must be numeric") if (!is.numeric(atol)) stop("`atol' must be numeric") if (!is.null(tcrit) & !is.numeric(tcrit)) stop("`tcrit' must be numeric") if (!is.null(jacfunc) && !(is.function(jacfunc) || is.character(jacfunc))) stop(paste(jacname," must be a function or character vector")) if (length(atol) > 1 && length(atol) != n) stop("`atol' must either be a scalar, or as long as `y'") if (length(rtol) > 1 && length(rtol) != n) stop("`rtol' must either be a scalar, or as long as `y'") if (!is.numeric(hmin)) stop("`hmin' must be numeric") if (hmin < 0) stop("`hmin' must be a non-negative value") if (is.null(hmax)) hmax <- if (is.null(times)) 0 else max(abs(diff(times))) if (!is.numeric(hmax)) stop("`hmax' must be numeric") if (hmax < 0) stop("`hmax' must be a non-negative value") if (hmax == Inf) hmax <- 0 if (!is.null(hini)) if(hini < 0) stop("`hini' must be a non-negative value") return(hmax) } ## ======================================================================== ## Check solver input - euler and rk4 ## ======================================================================== checkInputEuler <- function (y, times, func, dllname) { if (!is.numeric(y)) stop("`y' must be numeric") n <- length(y) if (! is.null(times) && !is.numeric(times)) stop("`times' must be NULL or numeric") if (!is.function(func) && !is.character(func)) stop("`func' must be a function or character vector") if (is.character(func) && (is.null(dllname) || !is.character(dllname))) stop("You need to specify the name of the dll or shared library where func can be found (without extension)") } ## ======================================================================== ## Check ode function call - livermore solvers ## ======================================================================== checkFunc<- function (Func2, times, y, rho) { ## Call func once to figure out whether and how many "global" ## results it wants to return and some other safety checks tmp <- eval(Func2(times[1], y), rho) if (!is.list(tmp)) stop("Model function must return a list\n") if (length(tmp[[1]]) != length(y)) stop(paste("The number of derivatives returned by func() (", length(tmp[[1]]), ") must equal the length of the initial conditions vector (", length(y), ")", sep = "")) ## use "unlist" here because some output variables are vectors/arrays Nglobal <- if (length(tmp) > 1) length(unlist(tmp[-1])) else 0 ## Karline: changed this: ## Nmtot is now a list with names, dimensions,... for 1-D, 2-D vars Nmtot <- list() Nmtot$colnames <- attr(unlist(tmp[-1]), "names") Nmtot$lengthvar <- unlist(lapply(tmp, length)) if (length(Nmtot$lengthvar) < Nglobal+1){ Nmtot$dimvar <- lapply(tmp[-1], dim) } return(list(Nglobal = Nglobal, Nmtot = Nmtot)) } ## ======================================================================== ## Check event function calls ## ======================================================================== checkEventFunc<- function (Func, times, y, rho) { ## Call func once tmp <- eval(Func(times[1], y), rho) if (length(tmp) != length(y)) stop(paste("The number of values returned by events$func() (", length(tmp), ") must equal the length of the initial conditions vector (", length(y), ")", sep = "")) if (!is.vector(tmp)) stop("The event function 'events$func' must return a vector\n") } ## ======================================================================== ## Check ode function call - euler and rk solvers ## ======================================================================== checkFuncEuler<- function (Func, times, y, parms, rho, Nstates) { ## Call func once to figure out whether and how many "global" ## results it wants to return and some other safety checks tmp <- eval(Func(times[1], y, parms), rho) if (!is.list(tmp)) stop("Model function must return a list\n") if (length(tmp[[1]]) != Nstates) stop(paste("The number of derivatives returned by func() (", length(tmp[[1]]), "must equal the length of the initial conditions vector (", Nstates, ")", sep="")) ## use "unlist" because output variables can be vectors/arrays Nglobal <- if (length(tmp) > 1) length(unlist(tmp[-1])) else 0 Nmtot <- list() Nmtot$colnames <- attr(unlist(tmp[-1]), "names") Nmtot$lengthvar <- unlist(lapply(tmp, length)) if (length(Nmtot$lengthvar) < Nglobal+1){ Nmtot$dimvar <- lapply(tmp[-1], dim) } return(list(Nglobal = Nglobal, Nmtot = Nmtot)) } ## ======================================================================== ## check ode DLL input ## ======================================================================== checkDLL <- function (func, jacfunc, dllname, initfunc, verbose, nout, outnames, JT = 1) { if (sum(duplicated (c(func, initfunc, jacfunc))) > 0) stop("func, initfunc, or jacfunc cannot be the same") ModelInit <- NA if (! is.null(initfunc)) # to allow absence of initfunc if (inherits (initfunc, "CFunc")) ModelInit <- body(initfunc)[[2]] else if (is.loaded(initfunc, PACKAGE = dllname, type = "") || is.loaded(initfunc, PACKAGE = dllname, type = "Fortran")) { ModelInit <- getNativeSymbolInfo(initfunc, PACKAGE = dllname)$address } else if (initfunc != dllname && ! is.null(initfunc)) stop(paste("'initfunc' not loaded ", initfunc)) ## Easier to deal with NA in C-code if (is.null(initfunc)) ModelInit <- NA ## copy value of func to funcname ## check to make sure it describes a function in a loaded dll funcname <- func ## get the pointer and put it in func if (inherits (func, "CFunc")) Func <- body(func)[[2]] else if(is.loaded(funcname, PACKAGE = dllname)) { Func <- getNativeSymbolInfo(funcname, PACKAGE = dllname)$address } else stop(paste("dyn function 'func' not loaded", funcname)) ## Finally, is there a Jacobian? if (!is.null(jacfunc)) { if (!is.character(jacfunc)) switch (JT, stop("If 'func' is dynloaded, so must 'jacfunc' be"), stop("If 'func' is dynloaded, so must 'jacvec' be") ) jacfuncname <- jacfunc if (inherits (jacfunc, "CFunc")) JacFunc <- body(jacfunc)[[2]] else if(is.loaded(jacfuncname, PACKAGE = dllname)) { JacFunc <- getNativeSymbolInfo(jacfuncname, PACKAGE = dllname)$address } else stop(paste("cannot integrate: jac function not loaded ", jacfunc)) } else JacFunc <- NULL Nglobal <- nout Nmtot <- list() if (is.null(outnames)) { Nmtot$colnames <- NULL} else if (length(outnames) == nout) { Nmtot$colnames <- outnames} else if (length(outnames) > nout) Nmtot$colnames <- outnames[1:nout] else Nmtot$colnames <- c(outnames,(length(outnames)+1):nout) cnames <- outnames unames <- unique(outnames) if (length(cnames) > length(unames)) Nmtot$lengthvar <- c(NA, sapply (unames, FUN = function(x) length(which(cnames == x)))) return(list(ModelInit = ModelInit, Func = Func, JacFunc = JacFunc, Nglobal = Nglobal, Nmtot = Nmtot)) } ## ============================================================================= ## print integration task ## ============================================================================= printtask <- function(itask, func, jacfunc) { printM("\n--------------------") printM("Time settings") printM("--------------------\n") if (itask==1) printM(" Normal computation of output values of y(t) at t = TOUT") else if (itask==2) printM(" Take one step only and return.") else if (itask==3) printM(" istop at the first internal mesh point at or beyond t = TOUT and return. ") else if (itask==4) printM(" Normal computation of output values of y(t) at t = TOUT but without overshooting t = TCRIT.") else if (itask==5) printM(" Take one step, without passing TCRIT, and return.") printM("\n--------------------") printM("Integration settings") printM("--------------------\n") if (is.character(func)) printM(paste(" Model function a DLL: ", func)) else printM(" Model function an R-function: ") if (is.character(jacfunc)) printM(paste (" Jacobian specified as a DLL: ", jacfunc)) else if (!is.null(jacfunc)) printM(" Jacobian specified as an R-function: ") else printM(" Jacobian not specified") cat("\n") } ## ============================================================================= ## Make Istate vector similar for all solvers. ## ============================================================================= setIstate <- function(istate, iin, iout) { IstateOut <- rep(NA, 21) IstateOut[iout] <- istate[iin] IstateOut } ## ============================================================================= ## Output cleanup - for the Livermore solvers ## ============================================================================= saveOut <- function (out, y, n, Nglobal, Nmtot, func, Func2, iin, iout, nr = 4) { troot <- attr(out, "troot") istate <- attr(out, "istate") istate <- setIstate(istate,iin,iout) valroot <- attr(out, "valroot") indroot <- attr(out, "indroot") Rstate <- attr(out, "rstate") rstate <- rep(NA,5) rstate[1:nr] <- Rstate[1:nr] nm <- c("time", if (!is.null(attr(y, "names"))) names(y) else as.character(1:n)) if (Nglobal > 0) { nm <- c(nm, if (!is.null(Nmtot$colnames)) Nmtot$colnames else as.character((n+1) : (n + Nglobal))) } attr(out,"istate") <- istate attr(out, "rstate") <- rstate if (! is.null(Nmtot$lengthvar)) if (is.na(Nmtot$lengthvar[1]))Nmtot$lengthvar[1] <- length(y) attr(out, "lengthvar") <- Nmtot$lengthvar if (! is.null(troot)) attr(out, "troot") <- troot if (! is.null(valroot)) attr(out, "valroot") <- matrix(nrow = n, valroot) if (! is.null(indroot)) attr(out, "indroot") <- indroot ii <- if (is.null(Nmtot$dimvar)) NULL else !(unlist(lapply(Nmtot$dimvar, is.null))) # variables with dimension if (sum(ii) >0) attr(out, "dimvar") <- Nmtot$dimvar[ii] # dimensions that are not null class(out) <- c("deSolve", "matrix") # a differential equation dimnames(out) <- list(nm, NULL) return (t(out)) } ## ============================================================================= ## Output cleanup - for the Runge-Kutta solvers ## ============================================================================= saveOutrk <- function(out, y, n, Nglobal, Nmtot, iin, iout, transpose = FALSE) { ## Names for the outputs nm <- c("time", if (!is.null(attr(y, "names"))) names(y) else as.character(1:n) ) ## Global outputs if (Nglobal > 0) { nm <- c(nm, if (!is.null(Nmtot$colnames)) Nmtot$colnames else as.character((n + 1) : (n + Nglobal)) ) } ## Column names and state information dimnames(out) <- list(NULL, nm) istate <- attr(out, "istate") istate <- setIstate(istate, iin, iout) attr(out,"istate") <- istate if (! is.null(Nmtot$lengthvar)) if (is.na(Nmtot$lengthvar[1])) Nmtot$lengthvar[1] <- length(y) attr(out, "lengthvar") <- Nmtot$lengthvar ii <- if (is.null(Nmtot$dimvar)) NULL else !(unlist(lapply(Nmtot$dimvar, is.null))) # variables with dimension if (sum(ii) >0) attr(out, "dimvar") <- Nmtot$dimvar[ii] # only those which are not null class(out) <- c("deSolve", "matrix") # output of a differential equation if (transpose) return(t(out)) else return(out) } deSolve/R/rk4.R0000644000176000001440000001113013572677236012745 0ustar ripleyusers### ============================================================================ ### Interface to a special code for the classsical Runge-Kutta ODE solver ### with fixed step size and without interpolation, see helpfile for details. ### ============================================================================ rk4 <- function(y, times, func, parms, verbose = FALSE, ynames = TRUE, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, ...) { if (is.list(func)) { ### IF a list if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$dllname)) dllname <- func$dllname if (!is.null(func$initforc)) initforc <- func$initforc func <- func$func } ## check for unsupported solver options dots <- list(...); nmdots <- names(dots) if(any(c("hmin", "hmax") %in% nmdots)) warning("hmin and hmax cannot be used in 'rk4' (fixed steps).") if("hini" %in% nmdots) { cat("'hini' is not supported by this version of rk4,\n") cat("but you can use ode(......, method = 'rk4', hini= .....)\n") cat("to set internal time steps smaller than external steps.\n") } if(any(c("events", "rootfunc") %in% nmdots)) { warning("events and roots are not supported by this version of rk4,\n", " but you can use ode(......, method = 'rk4', .....)\n") } if(any(c("jacfunc", "jactype", "mf", "bandup", "banddown") %in% nmdots)) { warning("Euler and Runge-Kutta solvers make no use of a Jacobian,\n", " ('jacfunc', 'jactype', 'mf', 'bandup' and 'banddown' are ignored).\n") } if(any(c("lags") %in% nmdots)) { warning("lags are not yet implemented for Euler and Runge-Kutta solvers,\n", " (argument 'lags' is ignored).\n") } ## check input checkInputEuler(y, times, func, dllname) n <- length(y) Ynames <- attr(y,"names") Initfunc <- NULL flist <-list(fmat = 0, tmat = 0, imat = 0, ModelForc = NULL) Nstates <- length(y) # assume length of states is correct ## Model as shared object (DLL)? if (is.character(func) | inherits(func, "CFunc")) { # function specified in a DLL or inline compiled DLL <- checkDLL(func, NULL, dllname, initfunc, verbose, nout, outnames) Initfunc <- DLL$ModelInit Func <- DLL$Func Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings, times, dllname, initforc, verbose, fcontrol) rho <- NULL if (is.null(ipar)) ipar <- 0 if (is.null(rpar)) rpar <- 0 } else { initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) ## func and jac are overruled, either including ynames, or not ## This allows to pass the "..." arguments and the parameters if(ynames) { Func <- function(time, state, parms) { attr(state, "names") <- Ynames func (time,state,parms,...) } } else { # no ynames... Func <- function(time, state, parms) func (time, state, parms,...) } ## Call func once to figure out whether and how many "global" ## results it wants to return and some other safety checks FF <- checkFuncEuler(Func,times,y,parms,rho,Nstates) Nglobal <- FF$Nglobal Nmtot <- FF$Nmtot } vrb <- FALSE # TRUE forces internal debugging output of the C code ## the CALL to the integrator ## rk can be nested, so no "unlock_solver" needed on.exit(.C("unlock_solver")) out <- .Call("call_rk4", as.double(y), as.double(times), Func, Initfunc, parms, as.integer(Nglobal), rho, as.integer(vrb), as.double(rpar), as.integer(ipar), flist) out <- saveOutrk(out, y, n, Nglobal, Nmtot, iin = c(1, 12, 13, 15), iout=c(1:3, 18)) attr(out, "type") <- "rk" if (verbose) diagnostics(out) return(out) } deSolve/R/lsodes.R0000644000176000001440000004001313572677236013540 0ustar ripleyusers### ============================================================================ ### lsodes -- solves ordinary differential equation systems with general ### sparse Jacobian matrix. ### The sparsity structure of the Jacobian is either specified ### by the user, estimated internally (default), or of a special type. ### To date, "1D", "2D", "3D" are supported as special types. ### These are the sparsity associated with 1- 2- and 3-Dimensional PDE models ### ### as from deSolve 1.9.1, lsode1 finds the root of at least one of a set ### of constraint functions g(i) of the independent and dependent variables. ### It finds only those roots for which some g(i), as a function ### of t, changes sign in the interval of integration. ### It then returns the solution at the root, if that occurs ### sooner than the specified stop condition, and otherwise returns ### the solution according the specified stop condition. ### ### Karline: version 1.10.4: ### added 2-D with mapping - still in testing phase, undocumented ### ============================================================================ lsodes <- function(y, times, func, parms, rtol = 1e-6, atol = 1e-6, jacvec = NULL, sparsetype = "sparseint", nnz = NULL, inz = NULL, rootfunc = NULL, verbose = FALSE, nroot = 0, tcrit = NULL, hmin = 0, hmax = NULL, hini = 0, ynames = TRUE, maxord = NULL, maxsteps = 5000, lrw = NULL, liw = NULL, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, events = NULL, lags = NULL, ...) { ### check input if (is.list(func)) { ### IF a list if (!is.null(jacvec) & "jacvec" %in% names(func)) stop("If 'func' is a list that contains jacvec, argument 'jacvec' should be NULL") if (!is.null(rootfunc) & "rootfunc" %in% names(func)) stop("If 'func' is a list that contains rootfunc, argument 'rootfunc' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(func)) stop("If 'func' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(func)) { if (! is.null(events)) events$func <- func$eventfunc else events <- list(func = func$eventfunc) } if (!is.null(func$jacvec)) jacvec <- func$jacvec if (!is.null(func$rootfunc)) rootfunc <- func$rootfunc if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$dllname)) dllname <- func$dllname if (!is.null(func$initforc)) initforc <- func$initforc func <- func$func } hmax <- checkInput (y, times, func, rtol, atol, jacvec, tcrit, hmin, hmax, hini, dllname,"jacvec") n <- length(y) if (is.null (maxord)) maxord <- 5 if (maxord > 5 ) stop ("'maxord' too large: should be <= 5") if (maxord < 1 ) stop ("`maxord' must be >1") ### Sparsity type and Jacobian method flag imp if (sparsetype=="sparseusr" && is.null(inz)) stop("'inz' must be specified if 'sparsetype' = 'sparseusr'") if (sparsetype=="sparsejan" && is.null(inz)) stop("'inz' must be specified if 'sparsetype' = 'sparsejan'") if (sparsetype=="1D" && ! is.null(jacvec)) stop("cannot combine 'sparsetype=1D' and 'jacvec'") if (sparsetype %in% c("2D", "2Dmap") && ! is.null(jacvec)) stop("cannot combine 'sparsetype=2D' and 'jacvec'") if (sparsetype %in% c("3D", "3Dmap") && ! is.null(jacvec)) stop("cannot combine 'sparsetype=3D' and 'jacvec'") # imp = method flag as used in lsodes if (! is.null(jacvec) && sparsetype %in% c("sparseusr", "sparsejan")) imp <- 21 # inz supplied,jac supplied else if (! is.null(jacvec) && !sparsetype=="sparseusr") imp <- 121 # inz internally generated,jac supplied else if (is.null(jacvec) && sparsetype%in%c("sparseusr","1D","2D","2Dmap","3D","3Dmap","sparsejan")) imp <- 22 # inz supplied,jac not supplied else imp <- 222 # sparse Jacobian, calculated internally ## Special-purpose sparsity structures: 1-D and 2-D reaction-transport problems ## Typically these applications are called via ode.1D, ode.2D and ode.3D ## Here the sparsity is specified in the C-code; this needs extra input: ## the number of components *nspec* and the dimensionality of the problem ## (number of boxes in each direction). ## This information is passed by ode.1D, ode.2D and ode.3D in parameter ## nnz (a vector). ## nnz is altered to include the number of nonzero elements (element 1). ## 'Type' contains the type of sparsity + nspec + num boxes + cyclicBnd + bandwidth if (sparsetype == "1D") { nspec <- nnz[1] bandwidth <- 1 # nnz[3] Type <- c(2,nnz) #type=2 nnz <- n*(2+nspec*bandwidth)-2*nspec } else if (sparsetype %in% c("2D","2Dmap")) { nspec <- nnz[1] dimens <- nnz[2:3] bandwidth <- 1# nnz[6] maxdim <- max(dimens) if (sparsetype == "2D") { Type <- c(3, nnz) #type=3 nnz <- n*(4+nspec*bandwidth)-2*nspec*(sum(dimens)) } else { ## Karline: changes for 2D map Type <- c(30, nnz) #type=30 for 2Dmap nnz <- (nspec*prod(dimens))*(4+nspec*bandwidth)-2*nspec*(sum(dimens)) } if (Type[5]==1) { # cyclic boundary in x-direction nnz <- nnz + 2*maxdim*nspec*bandwidth } if (Type[6] ==1) {# cyclic boundary in y-direction nnz <- nnz + 2*maxdim*nspec*bandwidth } } else if (sparsetype %in% c("3D","3Dmap")) { nspec <- nnz[1] dimens <- nnz[2:4] #type=4 bandwidth <- 1# nnz[8] if (sparsetype == "3D") { Type <- c(4,nnz) nnz <- n*(6+nspec*bandwidth)-2*nspec*(sum(dimens)) } else { ## Karline: changes for 3D map Type <- c(40, nnz) #type=40 for 3Dmap nnz <- (nspec*prod(dimens))*(6+nspec*bandwidth)-2*nspec*(sum(dimens)) } if (Type[6]== 1) { # cyclic boundary in x-direction nnz <- nnz + 2*dimens[2]*dimens[3]*nspec } if (Type[7] == 1) {# cyclic boundary in y-direction nnz <- nnz + 2*dimens[1]*dimens[3]*nspec } if (Type[8] == 1) {# cyclic boundary in y-direction nnz <- nnz + 2*dimens[1]*dimens[2]*nspec } } else if (sparsetype == "sparseusr") { Type <- 0 nnz <- nrow(inz) } else if (sparsetype == "sparsejan") { # ian and jan inputted, as a vector Type <- 0 nnz <- length(inz) - n } else { Type <- 1 if (is.null(nnz)) nnz <- n*n } if (nnz < 1) stop ("Jacobian should at least contain one non-zero value") ### model and Jacobian function JacFunc <- NULL Ynames <- attr(y,"names") RootFunc <- NULL flist <- list(fmat=0,tmat=0,imat=0,ModelForc=NULL) ModelInit <- NULL Eventfunc <- NULL events <- checkevents(events, times, Ynames, dllname,TRUE) if (! is.null(events$newTimes)) times <- events$newTimes if (is.character(func) | inherits(func, "CFunc")) { # function specified in a DLL or inline compiled DLL <- checkDLL(func,jacvec,dllname, initfunc,verbose,nout, outnames, JT=2) ## Is there a root function? if (!is.null(rootfunc)) { if (!is.character(rootfunc) & !inherits(rootfunc, "CFunc")) stop("If 'func' is dynloaded, so must 'rootfunc' be") rootfuncname <- rootfunc if (inherits(rootfunc, "CFunc")) RootFunc <- body(rootfunc)[[2]] else if (is.loaded(rootfuncname, PACKAGE = dllname)) { RootFunc <- getNativeSymbolInfo(rootfuncname, PACKAGE = dllname)$address } else stop(paste("root function not loaded in DLL",rootfunc)) if (nroot == 0) stop("if 'rootfunc' is specified in a DLL, then 'nroot' should be > 0") } ModelInit <- DLL$ModelInit Func <- DLL$Func JacFunc <- DLL$JacFunc Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,verbose,fcontrol) if (is.null(ipar)) ipar<-0 if (is.null(rpar)) rpar<-0 Eventfunc <- events$func if (is.function(Eventfunc)) rho <- environment(Eventfunc) else rho <- NULL } else { if(is.null(initfunc)) initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) # func and jac are overruled, either including ynames, or not # This allows to pass the "..." arguments and the parameters if (ynames) { Func <- function(time,state) { attr(state,"names") <- Ynames unlist(func (time,state,parms,...)) } Func2 <- function(time,state) { attr(state,"names") <- Ynames func (time,state,parms,...) } JacFunc <- function(time,state,J){ attr(state,"names") <- Ynames jacvec(time,state,J,parms,...) } RootFunc <- function(time,state) { attr(state,"names") <- Ynames rootfunc(time,state,parms,...) } if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) { attr(state,"names") <- Ynames events$func(time,state,parms,...) } } else { # no ynames... Func <- function(time,state) unlist(func (time,state,parms,...)) Func2 <- function(time,state) func (time,state,parms,...) JacFunc <- function(time,state,J) jacvec(time,state,J,parms,...) RootFunc <- function(time,state) rootfunc(time,state,parms,...) if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) events$func(time,state,parms,...) } ## Check function and return the number of output variables +name FF <- checkFunc(Func2,times,y,rho) Nglobal<-FF$Nglobal Nmtot <- FF$Nmtot ## Check event function if (! is.null(events$Type)) if (events$Type == 2) checkEventFunc(Eventfunc,times,y,rho) ## and for rootfunc if (! is.null(rootfunc)) { tmp2 <- eval(rootfunc(times[1],y,parms,...), rho) if (!is.vector(tmp2)) stop("root function 'rootfunc' must return a vector\n") nroot <- length(tmp2) } else nroot = 0 } ### work arrays iwork, rwork # 1. Estimate length of rwork and iwork if not provided via arguments lrw, liw moss <- imp%/%100 # method to be used to obtain sparsity meth <- imp%%100%/%10 # basic linear multistep method miter <- imp%%10 # corrector iteration method lenr = 2 # real to integer wordlength ratio (2 due to double precision) if (is.null(lrw)) { # make a guess of real work space needed lrw = 20+n*(maxord+1)+3*n +20 #extra 20 to make sure if(miter == 1) lrw = lrw + 2*nnz + 2*n + (nnz+9*n)/lenr if(miter == 2) lrw = lrw + 2*nnz + 2*n + (nnz+10*n)/lenr if(miter == 3) lrw = lrw + n + 2 if (sparsetype == "1D") lrw <- lrw*1.2 # increase to be sure it is enough... } # if (is.null(liw)) { # make a guess of integer work space needed KS->THOMAS: if not NULL, should be large enough! if (moss == 0 && miter %in% c(1,2)) liw <- max(liw, 31+n+nnz +30) else # extra 30 liw <- max(liw, 30) # } lrw <- max(20, lrw) + 3*nroot # 2. Allocate and set values # only first 20 elements of rwork passed to solver; # other elements will be allocated in C-code # for iwork: only first 30 elements, except when sparsity imposed rwork <- vector("double",20) rwork[] <- 0. # iwork will contain sparsity structure (ian,jan) # See documentation of DLSODES how this is done if(sparsetype=="sparseusr") { iwork <- vector("integer",liw) iwork[] <- 0 iw <- 32+n iwork[31]<- iw # input = 2-columned matrix inz; converted to ian,jan and put in iwork # column indices should be sorted... rr <- inz[,2] if (min(rr[2:nnz]-rr[1:(nnz-1)])<0) stop ("cannot proceed: column indices (2nd column of inz) should be sorted") for(i in 1:n) { ii <- which (rr==i) il <- length(ii) i1 <- iwork[i+30] i2 <- iwork[i+30]+il-1 iwork[i+31] <- i2+1 if (il>0) iwork[i1:i2] <- inz[ii,1] } iwork[31:(31+n)] <- iwork[31:(31+n)]-31-n } else if(sparsetype=="sparsejan") { iwork <- vector("integer",liw) iwork[] <- 0 iw <- 32+n linz <- 30 + length(inz) iwork[31:linz] <- inz } else { # sparsity not imposed; only 30 element of iwork allocated. iwork <- vector("integer",30) iwork[] <- 0 } # other elements of iwork, rwork iwork[5] <- maxord iwork[6] <- maxsteps if(! is.null(tcrit)) rwork[1] <- tcrit rwork[5] <- hini rwork[6] <- hmax rwork[7] <- hmin # the task to be performed. if (! is.null(times)) itask <- ifelse (is.null (tcrit), 1,4) else # times specified itask <- ifelse (is.null (tcrit), 2,5) # only one step if(is.null(times)) times <- c(0,1e8) ### print to screen... if (verbose) { printtask(itask,func,jacvec) printM("\n--------------------") printM("Integration method") printM("--------------------\n") txt <- "" # to avoid txt being not defined... if (imp == 21) txt <- " The user has supplied indices to nonzero elements of Jacobian, and a Jacobian function" else if (imp == 22) { if (sparsetype %in% c("sparseusr","sparsejan")) txt <-" The user has supplied indices to nonzero elements of Jacobian, the Jacobian will be estimated internally, by differences" if (sparsetype=="1D") txt <-" The nonzero elements are according to a 1-D model, the Jacobian will be estimated internally, by differences" if (sparsetype %in% c("2D", "2Dmap")) txt <-" The nonzero elements are according to a 2-D model, the Jacobian will be estimated internally, by differences" if (sparsetype %in% c("3D","3Dmap")) txt <-" The nonzero elements are according to a 3-D model, the Jacobian will be estimated internally, by differences" } else if (imp == 122) txt <-" The user has supplied the Jacobian, its structure (indices to nonzero elements) will be obtained from NEQ+1 calls to jacvec" else if (imp == 222) txt <-" The Jacobian will be generated internally, its structure (indices to nonzero elements) will be obtained from NEQ+1 calls to func" printM(txt) } ### calling solver storage.mode(y) <- storage.mode(times) <- "double" IN <- 3 if (!is.null(rootfunc)) IN <- 7 lags <- checklags(lags, dllname) on.exit(.C("unlock_solver")) out <- .Call("call_lsoda",y,times,Func,initpar, rtol, atol, rho, tcrit, JacFunc, ModelInit, Eventfunc, as.integer(verbose), as.integer(itask), as.double(rwork), as.integer(iwork), as.integer(imp),as.integer(Nglobal), as.integer(lrw),as.integer(liw),as.integer(IN), RootFunc, as.integer(nroot), as.double (rpar), as.integer(ipar), as.integer(Type),flist, events, lags, PACKAGE="deSolve") ### saving results if (nroot>0) iroot <- attr(out, "iroot") out <- saveOut(out, y, n, Nglobal, Nmtot, func, Func2, iin=c(1,12:20), iout=c(1:3,14,5:9,17)) if (nroot>0) attr(out, "iroot") <- iroot attr(out, "type") <- "lsodes" if (verbose) diagnostics(out) out } deSolve/R/lsodar.R0000644000176000001440000002444013572677236013541 0ustar ripleyusers### ============================================================================ ### lsodar -- solves ordinary differential equation systems ### Compared to the other integrators of odepack ### (a) lsodar switches automatically between stiff and nonstiff methods. ### This means that the user does not have to determine whether the ### problem is stiff or not, and the solver will automatically choose the ### appropriate method. It always starts with the nonstiff method. ### This is similar to lsoda. ### (b) lsodar finds the root of at least one of a set of constraint ### functions g(i) of the independent and dependent variables. ### It finds only those roots for which some g(i), as a function ### of t, changes sign in the interval of integration. ### It then returns the solution at the root, if that occurs ### sooner than the specified stop condition, and otherwise returns ### the solution according the specified stop condition. ### ============================================================================ lsodar <- function(y, times, func, parms, rtol=1e-6, atol=1e-6, jacfunc=NULL, jactype = "fullint", rootfunc=NULL, verbose=FALSE, nroot = 0, tcrit = NULL, hmin=0, hmax=NULL, hini=0, ynames=TRUE, maxordn = 12, maxords = 5, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname=NULL,initfunc=dllname, initpar=parms, rpar=NULL, ipar=NULL, nout=0, outnames=NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, events=NULL, lags = NULL, ...) { ### check input if (is.list(func)) { ### IF a list if (!is.null(jacfunc) & "jacfunc" %in% names(func)) stop("If 'func' is a list that contains jacfunc, argument 'jacfunc' should be NULL") if (!is.null(rootfunc) & "rootfunc" %in% names(func)) stop("If 'func' is a list that contains rootfunc, argument 'rootfunc' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(func)) stop("If 'func' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(func)) { if (! is.null(events)) events$func <- func$eventfunc else events <- list(func = func$eventfunc) } if (!is.null(func$jacfunc)) jacfunc <- func$jacfunc if (!is.null(func$rootfunc)) rootfunc <- func$rootfunc if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$dllname)) dllname <- func$dllname if (!is.null(func$initforc)) initforc <- func$initforc func <- func$func } hmax <- checkInput (y, times, func, rtol, atol, jacfunc, tcrit, hmin, hmax, hini, dllname) n <- length(y) if (!is.numeric(maxordn)) stop("`maxordn' must be numeric") if(maxordn < 1 || maxordn > 12) stop("`maxord' must be >1 and <=12") if (!is.numeric(maxords)) stop("`maxords' must be numeric") if(maxords < 1 || maxords > 5) stop("`maxords' must be >1 and <=5") ### Jacobian, method flag if (jactype == "fullint" ) jt <- 2 # full, calculated internally else if (jactype == "fullusr" ) jt <- 1 # full, specified by user function else if (jactype == "bandusr" ) jt <- 4 # banded, specified by user function else if (jactype == "bandint" ) jt <- 5 # banded, calculated internally else stop("'jactype' must be one of 'fullint', 'fullusr', 'bandusr' or 'bandint'") ## check other specifications depending on Jacobian if (jt %in% c(4,5) && is.null(bandup)) stop("'bandup' must be specified if banded Jacobian") if (jt %in% c(4,5) && is.null(banddown)) stop("'banddown' must be specified if banded Jacobian") if (is.null(banddown)) banddown <-1 if (is.null(bandup )) bandup <-1 if (jt %in% c(1,4) && is.null(jacfunc)) stop ("'jacfunc' NOT specified; either specify 'jacfunc' or change 'jactype'") ### model and Jacobian function Ynames <- attr(y,"names") JacFunc <- NULL RootFunc <- NULL flist<-list(fmat=0,tmat=0,imat=0,ModelForc=NULL) ModelInit <- NULL Eventfunc <- NULL events <- checkevents(events, times, Ynames, dllname, TRUE) if (! is.null(events$newTimes)) times <- events$newTimes if (jt == 4 && banddown>0) erow<-matrix(data=0, ncol=n, nrow=banddown) else erow<-NULL if (is.character(func) | inherits(func, "CFunc")) { # function specified in a DLL or inline compiled DLL <- checkDLL(func,jacfunc,dllname, initfunc,verbose,nout, outnames) ## Is there a root function? if (!is.null(rootfunc)) { if (!is.character(rootfunc) & !inherits(rootfunc, "CFunc")) stop("If 'func' is dynloaded, so must 'rootfunc' be") rootfuncname <- rootfunc if (inherits(rootfunc, "CFunc")) RootFunc <- body(rootfunc)[[2]] else if (is.loaded(rootfuncname, PACKAGE = dllname)) { RootFunc <- getNativeSymbolInfo(rootfuncname, PACKAGE = dllname)$address } else stop(paste("root function not loaded in DLL",rootfunc)) if (nroot == 0) stop("if 'rootfunc' is specified in a DLL, then 'nroot' should be > 0") } ModelInit <- DLL$ModelInit Func <- DLL$Func JacFunc <- DLL$JacFunc Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,verbose,fcontrol) if (is.null(ipar)) ipar<-0 if (is.null(rpar)) rpar<-0 Eventfunc <- events$func if (is.function(Eventfunc)) rho <- environment(Eventfunc) else rho <- NULL } else { if(is.null(initfunc)) initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) ## func and jac are overruled, either including ynames, or not ## This allows to pass the "..." arguments and the parameters if (ynames) { Func <- function(time,state) { attr(state,"names") <- Ynames unlist(func (time,state,parms,...)) } Func2 <- function(time,state) { attr(state,"names") <- Ynames func (time,state,parms,...) } JacFunc <- function(time,state){ attr(state,"names") <- Ynames rbind(jacfunc(time,state,parms,...),erow) } RootFunc <- function(time,state) { attr(state,"names") <- Ynames rootfunc(time,state,parms,...) } if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) { attr(state,"names") <- Ynames events$func(time,state,parms,...) } } else { # no ynames... Func <- function(time,state) unlist(func (time,state,parms,...)) Func2 <- function(time,state) func (time,state,parms,...) JacFunc <- function(time,state) rbind(jacfunc(time,state,parms,...),erow) RootFunc <- function(time,state) rootfunc(time,state,parms,...) if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) events$func(time,state,parms,...) } ## Check derivative function and return the number of output variables +name FF <- checkFunc(Func2,times,y,rho) Nglobal<-FF$Nglobal Nmtot <- FF$Nmtot ## Check event function if (! is.null(events$Type)) if (events$Type == 2) checkEventFunc(Eventfunc,times,y,rho) ## and for rootfunc if (! is.null(rootfunc)) { tmp2 <- eval(rootfunc(times[1],y,parms,...), rho) if (!is.vector(tmp2)) stop("root function 'rootfunc' must return a vector\n") nroot <- length(tmp2) } else nroot = 0 if (jt %in% c(1,4)) { tmp <- eval(JacFunc(times[1], y), rho) if (!is.matrix(tmp)) stop("Jacobian function, 'jacfunc' must return a matrix\n") dd <- dim(tmp) if((jt ==4 && any(dd != c(bandup+banddown+1,n))) || (jt ==1 && any(dd != c(n,n)))) stop("Jacobian dimension not ok") } } ### work arrays iwork, rwork ## length of rwork and iwork if(jt %in% c(1,2)) lmat <- n^2+2 else if(jt %in% c(4,5)) lmat <- (2*banddown+bandup+1)*n+2 lrn = 20+n*(maxordn+1)+ 3*n +3*nroot # length in case non-stiff method lrs = 20+n*(maxords+1)+ 3*n +lmat+3*nroot # length in case stiff method lrw = max(lrn,lrs) # actual length: max of both liw = 20 + n ## only first 20 elements passed to solver; other will be allocated in C-code iwork <- vector("integer",20) rwork <- vector("double",20) rwork[] <- 0. iwork[] <- 0 iwork[1] <- banddown iwork[2] <- bandup iwork[6] <- maxsteps if (maxordn != 12) iwork[8] <- maxordn if (maxords != 5) iwork[9] <- maxords if (verbose) iwork[5] = 1 # prints method switches to screen if(! is.null(tcrit)) rwork[1] <- tcrit rwork[5] <- hini rwork[6] <- hmax rwork[7] <- hmin ## the task to be performed. if (! is.null(times)) itask <- ifelse (is.null (tcrit), 1,4) else # times specified itask <- ifelse (is.null (tcrit), 2,5) # only one step if(is.null(times)) times<-c(0,1e8) ## print to screen... if (verbose) printtask(itask,func,jacfunc) ### calling solver storage.mode(y) <- storage.mode(times) <- "double" IN <-4 lags <- checklags(lags, dllname) on.exit(.C("unlock_solver")) out <- .Call("call_lsoda",y,times,Func,initpar, rtol, atol, rho, tcrit, JacFunc, ModelInit, Eventfunc, as.integer(verbose), as.integer(itask), as.double(rwork), as.integer(iwork), as.integer(jt),as.integer(Nglobal), as.integer(lrw),as.integer(liw),as.integer(IN),RootFunc, as.integer(nroot), as.double (rpar), as.integer(ipar), 0L, flist, events, lags, PACKAGE="deSolve") ### saving results iroot <- attr(out, "iroot") out <- saveOut(out, y, n, Nglobal, Nmtot, func, Func2, iin=c(1,12:21), iout=c(1:3,14,5:9,15:16),nr = 5) attr(out, "iroot") <- iroot attr(out, "type") <- "lsodar" if (verbose) diagnostics(out) return(out) } deSolve/R/matplot.R0000644000176000001440000002777213572677236013750 0ustar ripleyusers## ============================================================================= ## matplot methods - it is not an S3 generic... ## ============================================================================= ## the following code was used to make 'matplot' a generic, but ## we disabled this because of unwanted side-effects to other packages, ## see also outcommented code at the end of this file #matplot <- function (x, ...) UseMethod("matplot") #matplot.default <- function (x, ...) { #if (inherits (x, "deSolve")) # matplot.deSolve(x,...) #else # graphics::matplot(x,...) # #NextMethod() #} matplot.deSolve <- function(x, ..., select = NULL, which = select, obs = NULL, obspar = list(), subset = NULL, legend = list(x = "topright")) { # legend can be a list t <- 1 # column with independent variable "times" # Set the observed data obs <- SetData(obs) # variables to be plotted and their position in "x" varnames <- colnames(x) xWhich <- NULL lW <- length(which) WhichVar <- function(xWhich, obs, varnames) { if (is.null(xWhich) & is.null(obs$dat)) # All variables plotted Which <- 2 : length(varnames) else if (is.null(xWhich)) { # All common variables in x and obs plotted Which <- which(varnames %in% obs$name) Which <- Which [Which > 1] } else if (is.character(xWhich)) { Which <- which(varnames %in% xWhich) if (length(Which) != length(xWhich)) stop ("unknown variable", paste(xWhich, collapse = ",")) } else Which <- xWhich + 1 return(Which) } if (lW & is.list(which)) xWhich <- lapply(which, FUN = function (x) WhichVar(x, obs, varnames)) else if (lW) xWhich <- list(WhichVar(which, obs, varnames)) else xWhich <- list(2:length(varnames)) vn <- lapply(xWhich, FUN = function(x) paste(varnames[x], collapse = ",")) vn2 <- unlist(lapply(xWhich, FUN = function(x) paste(varnames[x]))) np <- length(xWhich) # number of y-axes nx <- length(unlist(xWhich)) # number of y-variables # add Position of variables to be plotted in "obs" obs <- updateObs2 (obs, varnames, unlist(xWhich)) # The ellipsis ldots <- list(...) Dots <- splitdots(ldots, varnames) if (Dots$nother > 1) stop ("can plot only one deSolve output object at a time with matplot") Dotmain <- setdots(Dots$main, np) # these are different from the default Dotmain$xlab <- expanddots(ldots$xlab, varnames[t] , np) Dotmain$ylab <- expanddots(ldots$ylab, vn , np) Dotmain$main <- expanddots(ldots$main, as.character(substitute(x)), np) # ylim and xlim can be lists and are at least two values yylim <- expanddotslist(ldots$ylim, np) xxlim <- expanddotslist(ldots$xlim, np) Dotpoints <- setdots(Dots$points, nx) # expand all dots to nx values # these are different from default Dotpoints$type <- expanddots(ldots$type, "l", nx) Dotpoints$lty <- expanddots(ldots$lty, 1:nx, nx) Dotpoints$pch <- expanddots(ldots$pch, 1:nx, nx) Dotpoints$col <- expanddots(ldots$col, 1:nx, nx) Dotpoints$bg <- expanddots(ldots$bg, 1:nx, nx) if (! is.null(obs)) { ii <- which(unlist(xWhich) %in% unlist(obs$Which)) ii <- ii[! is.na(ii)] if (is.null(obs$par)) obs$par <- list() else obs$par <- lapply(obspar, repdots, obs$length) if (is.null(obs$par$pch)) obs$par$pch <- Dotpoints$pch[ii] if (is.null(obs$par$cex)) obs$par$cex <- Dotpoints$cex[ii] if (is.null(obs$par$col)) obs$par$col <- Dotpoints$col[ii] if (is.null(obs$par$bg)) obs$par$bg <- Dotpoints$bg[ii] } if (!missing(subset)){ e <- substitute(subset) r <- eval(e, as.data.frame(x), parent.frame()) if (is.numeric(r)) { isub <- r } else { if (!is.logical(r)) stop("'subset' must evaluate to logical or be a vector with integers") isub <- r & !is.na(r) } } else { isub <- TRUE } # LOOP for each (set of) output variables (and y-axes) if (np > 1) par(mar = c(5.1, 4.1, 4.1, 2.1) + c(0, (np-1)*4, 0, 0)) ii <- 1 for (ip in 1 : np) { ix <- xWhich[[ip]] # position of y-variables in 'x' iL <- length(ix) iip <- ii:(ii+iL-1) # for dotpoints ii <- ii + iL io <- obs$Which[iip] # plotting parameters for matplot and axes dotmain <- extractdots(Dotmain, ip) if (is.null(dotmain$axes)) dotmain$axes <- FALSE if (is.null(dotmain$frame.plot)) dotmain$frame.plot <- TRUE dotpoints <- extractdots(Dotpoints, iip) # for all variables Xlog <- Ylog <- FALSE if (! is.null(dotmain$log)) { Ylog <- length(grep("y",dotmain$log)) Xlog <- length(grep("x",dotmain$log)) } SetRangeMat <- function(lim, x, isub, ix, obs, io, Log) { if ( is.null (lim)) { yrange <- Range(NULL, as.vector(x[isub, ix]), Log) if (! is.na(io[1])) yrange <- Range(yrange, as.vector(obs$dat[,io]), Log) } else yrange <- lim return(yrange) } dotmain$ylim <- SetRangeMat(yylim[[ip]], x, isub, ix, obs, io, Ylog) dotmain$xlim <- SetRangeMat(xxlim[[ip]], x, isub, t, obs, io, Xlog) Ylab <- dotmain$ylab dotmain$ylab <- "" if (ip > 1) { par(new = TRUE) dotmain$xlab <- dotmain$main <- "" } do.call("matplot", c(alist(x[isub, t], x[isub, ix]), dotmain, dotpoints)) if (ip == 1) axis(1, cex = dotmain$cex.axis) cex <- ifelse (is.null(dotmain$cex.lab), 0.9, 0.9*dotmain$cex.lab) bL <- 4*(ip-1) axis(side = 2, line = bL, cex = dotmain$cex.axis) mtext(side = 2, line = bL+2, Ylab, cex = cex) if (! is.na(io[1])) for (j in 1: length(io)) { i <- which (obs$Which == io[j]) if (length (i.obs <- obs$pos[i, 1]:obs$pos[i, 2]) > 0) do.call("points", c(alist(obs$dat[i.obs, 1], obs$dat[i.obs, io[j]]), extractdots(obs$par, j) )) } } if (is.null(legend)) legend <- list(x = "topright") if (is.list(legend)){ # can also be FALSE if (length(legend$legend)) L <- legend$legend else L <- vn2 legend$legend <- NULL if (is.null(legend$x)) legend$x <- "topright" lty <- Dotpoints$lty pch <- Dotpoints$pch lty[Dotpoints$type == "p"] <- NA pch[Dotpoints$type == "l"] <- NA do.call ("legend", c(legend, alist(lty = lty, lwd = Dotpoints$lwd, pch =pch, col = Dotpoints$col, pt.bg =Dotpoints$bg, legend = L))) } } ### ============================================================================ ### plotting 1-D variables as line plot, one for each time ### ============================================================================ matplot.1D <- function (x, select= NULL, which = select, ask = NULL, obs = NULL, obspar = list(), grid = NULL, xyswap = FALSE, vertical = FALSE, subset = NULL, ...) { ## Check settings of x att <- attributes(x) nspec <- att$nspec dimens <- att$dimens proddim <- prod(dimens) if (length(dimens) != 1) stop ("matplot.1D only works for models solved with 'ode.1D'") if ((ncol(x)- nspec*proddim) < 1) stop("ncol of 'x' should be > 'nspec' * dimens if x is a vector") # Set the observed data obs <- SetData(obs) # 1-D variable names varnames <- if (! is.null(att$ynames)) att$ynames else 1:nspec if (! is.null(att$lengthvar)) varnames <- c(varnames, names(att$lengthvar)[-1]) # variables to be plotted, common between obs and x Which <- WhichVarObs(which, obs, nspec, varnames, remove1st = FALSE) np <- length(Which) # Position of variables to be plotted in "x" Select <- select1dvar(Which, varnames, att) # also start and end position xWhich <- Select$Which # add Position of variables to be plotted in "obs" obs <- updateObs (obs, varnames, xWhich) obs$par <- lapply(obspar, repdots, obs$length) # the ellipsis ldots <- list(...) # number of figures in a row and interactively wait if remaining figures ask <- setplotpar(ldots, np, ask) if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } Dots <- splitdots(ldots, varnames) nother <- Dots$nother Dotpoints <- Dots$points Dotmain <- setdots(Dots$main, np) # expand all dots to np values (no defaults) # These are different from defaults Dotmain$xlab <- expanddots(ldots$xlab, "x", np) Dotmain$ylab <- expanddots(ldots$ylab, "", np) Dotmain$main <- expanddots(ldots$main, varnames[xWhich], np) # xlim and ylim are special: xxlim <- expanddotslist(ldots$xlim, np) yylim <- expanddotslist(ldots$ylim, np) xyswap <- rep(xyswap, length = np) vertical <- rep(vertical, length = np) if (!missing(subset)){ e <- substitute(subset) r <- eval(e, as.data.frame(x), parent.frame()) if (is.numeric(r)) { isub <- r } else { if (!is.logical(r)) stop("'subset' must evaluate to logical or be a vector with integers") isub <- r & !is.na(r) } } else isub <- 1:nrow(x) grid <- expanddotslist(grid, np) for (ip in 1:np) { istart <- Select$istart[ip] istop <- Select$istop[ip] io <- obs$Which[ip] out <- t(x[ isub, istart:istop]) if (length (isub) > 1 & sum (isub) == 1) out <- matrix (out) Grid <- grid[[ip]] if (is.null(Grid)) Grid <- 1:nrow(out) dotmain <- extractdots(Dotmain, ip) Xlog <- Ylog <- FALSE if (! is.null(dotmain$log)) { Ylog <- length(grep("y", dotmain$log)) Xlog <- length(grep("x", dotmain$log)) } if (vertical[ip]) { # overrules other settings; vertical profiles xyswap[ip] <- TRUE dotmain$axes <- FALSE dotmain$xlab <- "" dotmain$xaxs <- "i" dotmain$yaxs <- "i" } if (! xyswap[ip]) { if (! is.null(xxlim[[ip]])) dotmain$xlim <- xxlim[[ip]] dotmain$ylim <- SetRange(yylim[[ip]], x, NULL, isub, istart:istop, obs, io, Ylog) } else { if (! is.null(yylim[[ip]])) dotmain$ylim <- yylim[[ip]] dotmain$xlim <- SetRange(xxlim[[ip]], x, NULL, isub, istart:istop, obs, io, Xlog) if (is.null(yylim[[ip]]) & xyswap[ip]) dotmain$ylim <- rev(range(Grid)) # y-axis } if (! xyswap[ip]) { do.call("matplot", c(alist(Grid, out), dotmain, Dotpoints)) if (! is.na(io)) plotObs(obs, io) } else { if (is.null(dotmain$xlab[ip]) | is.null(dotmain$ylab[ip])) { dotmain$ylab <- dotmain$xlab[ip] dotmain$xlab <- dotmain$ylab[ip] } do.call("matplot", c(alist(out, Grid), dotmain, Dotpoints)) if (vertical[ip]) DrawVerticalAxis(dotmain, min(out)) if (! is.na(io)) plotObs(obs, io, xyswap = TRUE) } } } ## ============================================================================= ## S3/S4 compatibility ## ============================================================================= ## make matplot an S4 method and then extend generic for class deSolve ## but note that matplot.1D is not (yet) a generic, because .1D is just an ## alternative way of plotting and not a well defined class setGeneric("matplot", function(x, ...) graphics::matplot(x, ...)) setOldClass("deSolve") setMethod("matplot", list(x = "deSolve"), matplot.deSolve) ## thpe: 2016-06-20, deSolve 1.14 ## exporting matplot leads to annoying messages during package startup ## experimental approach: ## - do not anymore export matplot ## - instead, use exported 'matplot.deSolve' or alias 'matplot.0D' matplot.0D <- matplot.deSolve deSolve/R/diagnostics.R0000644000176000001440000002372613136461011014544 0ustar ripleyusers## ============================================================================= ## print the return code settings - all except rk and daspk ## ============================================================================= printidid <- function(idid) { cat(paste("\n return code (idid) = ", idid), "\n") if (idid == 2 || idid ==0) cat(" Integration was successful.\n") else if (idid == 3) cat(" Integration was successful and a root was found before reaching the end.\n") else if (idid == -1) cat(" Excess work done on this call. (Perhaps wrong Jacobian type MF.)\n") else if (idid == -2) cat(" Excess accuracy requested. (Tolerances too small.)\n") else if (idid == -3) cat(" Illegal input detected. (See printed message.)\n") else if (idid == -4) cat(" Repeated error test failures. (Check all input.)\n") else if (idid == -5) cat(" Repeated convergence failures. (Perhaps bad Jacobian supplied or wrong choice of MF or tolerances.)\n") else if (idid == -6) cat(" Error weight became zero during problem. (Solution component i vanished, and ATOL or ATOL(i) = 0.)\n") else if (idid == -7) cat(" Work space insufficient to finish (see messages).\n") else if (idid == -8) cat(" A fatal error came from sparse solver CDRV by way of DPRJS or DSOLSS.\n") } ## ============================================================================= ## print the return code settings - all except rk and daspk ## ============================================================================= printidid_rk <- function(idid) { cat(paste("\n return code (idid) = ", idid), "\n") if (idid == 2 || idid ==0) cat(" Integration was successful.\n") else if (idid == -1) cat(" Excess work done on this call. (Perhaps maxstep exceeded.)\n") else if (idid == -2) cat(" Excess accuracy requested. (Tolerances too small.)\n") else cat(" Unknown error code, please inform package developers.\n") } ## ============================================================================= ## print the return code settings - only daspk ## ============================================================================= printidid_daspk <- function(idid) { cat(paste("\n return code (idid) = ", idid), "\n") if (idid > 0) { cat (" integration was succesful\n") if (idid == 1) cat(" A step was successfully taken in the intermediate-output mode. The code has not yet reached TOUT.\n") if (idid == 2) cat(" The integration to TSTOP was successfully completed (T = TSTOP) by stepping exactly to TSTOP.\n") if (idid == 3) cat(" The integration to TOUT was successfully completed (T = TOUT) by stepping past TOUT. Y(*) and YPRIME(*) are obtained by interpolation.\n") if (idid == 4) cat(" The initial condition calculation, with INFO(11) > 0, was successful, and INFO(14) = 1. No integration steps were taken, and the solution is not considered to have been started.\n") } else if (idid < 0 & idid > -33) { cat (" integration was interrupted\n") if (idid == -1) cat(" A large amount of work has been expended (about 500 steps).\n") else if (idid == -2) cat(" The error tolerances are too stringent.\n") else if (idid == -3) cat(" The local error test cannot be satisfied because a zero component in ATOL was specified and the corresponding computed solution component is zero. Thus, a pure relative error test is impossible for this component.\n") else if (idid == -5) cat(" There were repeated failures in the evaluation or processing of the preconditioner (in jacfunc).\n") else if (idid == -6) cat(" DDASPK had repeated error test failures on the last attempted step.\n") else if (idid == -7) cat(" The nonlinear system solver in the time integration could not converge.\n") else if (idid == -8) cat(" The matrix of partial derivatives appears to be singular (direct method).\n") else if (idid == -9) cat(" The nonlinear system solver in the time integration failed to achieve convergence, and there were repeated error test failures in this step.\n") else if (idid == -10) cat(" The nonlinear system solver in the time integration failed to achieve convergence because IRES was equal to -1.\n") else if (idid == -11) cat(" IRES = -2 was encountered and control is being returned to the calling program.\n") else if (idid == -12) cat(" DDASPK failed to compute the initial Y, YPRIME.\n") else if (idid == -13) cat(" Unrecoverable error encountered inside user's PSOL routine, and control is being returned to the calling program.\n") else if (idid == -14) cat(" The Krylov linear system solver could not achieve convergence.\n") } else if (idid ==-33) { cat (" integration was terminated\n") cat(" The code has encountered trouble from which it cannot recover. A message is printed explaining the trouble and control is returned to the calling program.\n") } } ## ============================================================================= ## print the integer diagnostics ## ============================================================================= printIstate <- function(istate, name, all = TRUE) { df <- c( "The return code :", #1 "The number of steps taken for the problem so far:", #2 "The number of function evaluations for the problem so far:", #3 "The number of Jacobian evaluations so far:", #4 "The method order last used (successfully):", #5 "The order of the method to be attempted on the next step:", #6 "If return flag =-4,-5: the largest component in error vector", #7 "The length of the real work array actually required:", #8 "The length of the integer work array actually required:", #9 "The number of matrix LU decompositions so far:", #10 "The number of nonlinear (Newton) iterations so far:", #11 "The number of convergence failures of the solver so far ", #12 "The number of error test failures of the integrator so far:", #13 "The number of Jacobian evaluations and LU decompositions so far:", #14, "The method indicator for the last succesful step, 1=adams (nonstiff), 2= bdf (stiff):" , #15 "The current method indicator to be attempted on the next step, 1=adams (nonstiff), 2= bdf (stiff):", #16 "The number of nonzero elements in the sparse Jacobian:" , #17 "The order (or maximum order) of the method:", #18 "The number of convergence failures of the linear iteration so far", #19 "The number of linear (Krylov) iterations so far ", #20 "The number of psol calls so far:") #21 if (name =="mebdfi") df[19:21] <- c( "The number of backsolves so far", "The number of times a new coefficient matrix has been formed so far", "The number of times the order of the method has been changed so far") # if (is.na(istate[14])) istate[14]<-istate[4]+istate[10] # Jacobian+LU cat("\n--------------------\n") cat("INTEGER values\n") cat("--------------------\n") if (all) ii <- 1:19 else ii <- which(!is.na(istate)) printmessage(df[ii], istate[ii], Nr=ii) } ## ============================================================================= ## print the real diagnostics ## ============================================================================= printRstate <- function( rstate) { if(is.null(rstate)) return() df <- c( "The step size in t last used (successfully):", "The step size to be attempted on the next step:", "The current value of the independent variable which the solver has reached:", "Tolerance scale factor > 1.0 computed when requesting too much accuracy:", "The value of t at the time of the last method switch, if any:") cat("--------------------\n") cat("RSTATE values\n") cat("--------------------\n") ii <- which(!is.na(rstate)) printmessage(df[ii], rstate[ii]) } ## ============================================================================= ## print all diagnostic messages ## ============================================================================= diagnostics.deSolve <- function(obj, Full = FALSE, ...) { Attr <- attributes(obj) name <- Attr$type istate <- Attr$istate rstate <- Attr$rstate cat("\n--------------------\n") cat(paste(name,"return code")) cat("\n--------------------\n") idid <- istate[1] if (name == "lsodes" && idid == -7) idid <- -8 if (name == "rk") printidid_rk if (name == "daspk") printidid_daspk(idid) else printidid(idid) printIstate(istate, name, all=Full) if (name != "rk") printRstate(rstate) if (!is.null(Attr$nroot)) { cat("--------------------\n") cat("ROOT + event \n") cat("--------------------\n") cat("\n root found at times :", signif(Attr$troot, digits = 5), "\n") } if (name == "lsodar" || (name %in% c("lsode","lsodes","radau") && !is.null(Attr$iroot))) { cat("--------------------\n") cat("ROOT\n") cat("--------------------\n") iroot <- which (Attr$iroot ==1) if (length (iroot) > 0) { cat("\n root found for root equation:", signif(iroot, digits = 0), "\n") cat("\n at time :", signif(Attr$troot, digits = 5), "\n") } else if (is.null(Attr$nroot)) cat("\n NO root found \n") invisible(list(istate=istate, rstate=rstate, iroot = iroot)) } else invisible(list(istate=istate, rstate=rstate)) } diagnostics.default <- function(obj, ...) warning("No diagnostics available for class '", class(obj), "'") diagnostics <- function(obj, ...) UseMethod("diagnostics") deSolve/R/ode.R0000644000176000001440000004502313572677236013024 0ustar ripleyusers### ============================================================================ ### ### ode.1D, ode.2D ode.band: special-purpose integration routines ### ode.1D is designed for solving multi-component 1-D reaction-transport models ### ode.2D is designed for solving multi-component 2-D reaction-transport models ### ode.band is designed for solving single-component 1-D reaction-transport models ### ode.1D,ode.band offer the choice between the integrators vode, ### lsode, lsoda, lsodar and lsodes. ### ode.2D uses lsodes. ### ### KS: added **bandwidth** to ode.1D ### to do: make it work with lsodes + with ode.2D, ode.3D!! ### ============================================================================ ode <- function (y, times, func, parms, method = c("lsoda","lsode","lsodes","lsodar","vode","daspk", "euler", "rk4", "ode23", "ode45", "radau", "bdf", "bdf_d", "adams", "impAdams", "impAdams_d", "iteration"), ...) { if (is.null(method)) method <- "lsoda" if (is.list(method)) { # is() should work from R 2.7 on ... # if (!is(method, "rkMethod")) if (!inherits(method, "rkMethod" )) stop("'method' should be given as string or as a list of class 'rkMethod'") out <- rk(y, times, func, parms, method = method, ...) } else if (is.function(method)) out <- method(y, times, func, parms,...) else if (is.complex(y)) out <- switch(match.arg(method), vode = zvode(y, times, func, parms, ...), bdf = zvode(y, times, func, parms, mf = 22, ...), bdf_d = zvode(y, times, func, parms, mf = 23, ...), adams = zvode(y, times, func, parms, mf = 10, ...), impAdams = zvode(y, times, func, parms, mf = 12, ...), impAdams_d = zvode(y, times, func, parms, mf = 13, ...) ) else out <- switch(match.arg(method), lsoda = lsoda(y, times, func, parms, ...), vode = vode(y, times, func, parms, ...), lsode = lsode(y, times, func, parms, ...), lsodes= lsodes(y, times, func, parms, ...), lsodar= lsodar(y, times, func, parms, ...), daspk = daspk(y, times, func, parms, ...), euler = rk(y, times, func, parms, method = "euler", ...), rk4 = rk(y, times, func, parms, method = "rk4", ...), ode23 = rk(y, times, func, parms, method = "ode23", ...), ode45 = rk(y, times, func, parms, method = "ode45", ...), radau = radau(y, times, func, parms, ...), bdf = lsode(y, times, func, parms, mf = 22, ...), bdf_d = lsode(y, times, func, parms, mf = 23, ...), adams = lsode(y, times, func, parms, mf = 10, ...), impAdams = lsode(y, times, func, parms, mf = 12, ...), impAdams_d = lsode(y, times, func, parms, mf = 13, ...), iteration = iteration(y, times, func, parms, ...) ) return(out) } ### ============================================================================ ode.1D <- function (y, times, func, parms, nspec = NULL, dimens = NULL, method = c("lsoda","lsode", "lsodes","lsodar","vode","daspk", "euler", "rk4", "ode23", "ode45","radau", "bdf", "adams", "impAdams", "iteration"), names = NULL, bandwidth = 1, restructure = FALSE, ...) { # check input if (is.character(method)) method <- match.arg(method) islsodes <- FALSE if (is.character(method)) if (method=="lsodes") islsodes <- TRUE if (is.null(method)) method <- "lsoda" if (any(!is.na(pmatch(names(list(...)), "jacfunc")))) stop ("cannot run ode.1D with jacfunc specified - remove jacfunc from call list") if (is.null(nspec) && is.null(dimens)) stop ("cannot run ode.1D: nspec OR dimens should be specified") # if (islsodes && bandwidth != 1) # stop ("cannot combine 'method = lsodes' with 'bandwidth' not = 1") iscomplex <- is.complex(y) N <- length(y) if (is.null(nspec) ) nspec <- N/dimens if (N %% nspec != 0 ) stop ("cannot run ode.1D: nspec is not an integer fraction of number of state variables") if (! is.null(names) && length(names) != nspec) stop("length of 'names' should equal 'nspec'") # Use ode.band if implicit method with nspec=1 if (is.character(method)) if( nspec == 1 & method %in% c("lsoda","lsode","lsodar","vode","daspk","radau")) { out <- ode.band(y, times, func, parms, nspec = nspec, method = method, bandup = nspec * bandwidth, banddown = nspec * bandwidth, ...) attr(out,"ynames") <- names if (is.null(dimens)) dimens <- N/nspec attr (out, "dimens") <- dimens attr (out, "nspec") <- nspec return(out) } # Use lsodes explicit <- FALSE adams_expl <- FALSE if (is.character(method)){ if (method %in% c("euler", "rk4", "ode23", "ode45", "iteration")) explicit <- TRUE adams_expl <- explicit | method == "adams" } if (is.character(func) & !explicit || islsodes) { if (is.character(method)) if (! method %in% c("lsodes", "euler", "rk4", "ode23", "ode45", "iteration")) warning("ode.1D: R-function specified in a DLL-> integrating with lsodes") if (is.null(dimens) ) dimens <- N/nspec if (bandwidth != 1) # try to remove this.... out <- lsodes(y=y,times=times,func=func,parms,...) else out <- lsodes(y=y,times=times,func=func,parms,sparsetype="1D", nnz=c(nspec,dimens,bandwidth),...) # a Runge-Kutta or Euler } else if (is.list(method)) { # is() should work from R 2.7 on ... # if (!is(method, "rkMethod")) if (!inherits(method, "rkMethod" )) stop("'method' should be given as string or as a list of class 'rkMethod'") out <- rk(y, times, func, parms, method = method, ...) # a function that does not need restructuring } else if (is.function(method) && !restructure) out <- method(y, times, func, parms,...) else if (is.function(method) && restructure) { NL <- names(y) # internal function # bmodel <- function (time,state,pars,model,...) { Modconc <- model(time,state[ij],pars,...) # ij: reorder state variables c(list(Modconc[[1]][ii]), Modconc[-1]) # ii: reorder rate of change } if (is.character(func)) stop ("cannot run ode.1D with R-function specified in a DLL") ii <- as.vector(t(matrix(data=1:N,ncol=nspec))) # from ordering per slice -> per spec ij <- as.vector(t(matrix(data=1:N,nrow=nspec))) # from ordering per spec -> per slice bmod <- function(time,state,pars,...) bmodel(time,state,pars,func,...) out <- method(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) out[,(ii+1)] <- out[,2:(N+1)] if (! is.null(NL)) colnames(out)[2:(N+1)]<- NL } # an explicit method... as a string else if (adams_expl) { if (method == "euler") out <- rk(y, times, func, parms, method = "euler", ...) else if (method == "rk4") out <- rk(y, times, func, parms, method = "rk4", ...) else if (method == "ode23") out <- rk(y, times, func, parms, method = "ode23", ...) else if (method == "ode45") out <- rk(y, times, func, parms, method = "ode45", ...) else if (method == "adams" && ! iscomplex) out <- lsode(y, times, func, parms, mf = 10, ...) else if (method == "adams" && iscomplex) out <- zvode(y, times, func, parms, mf = 10, ...) else if (method == "iteration") out <- iteration(y, times, func, parms, ...) # an implicit method that needs restructuring... } else { NL <- names(y) # internal function # bmodel <- function (time,state,pars,model,...) { Modconc <- model(time,state[ij],pars,...) # ij: reorder state variables c(list(Modconc[[1]][ii]), Modconc[-1]) # ii: reorder rate of change } if (is.character(func)) stop ("cannot run ode.1D with R-function specified in a DLL") ii <- as.vector(t(matrix(data=1:N,ncol=nspec))) # from ordering per slice -> per spec ij <- as.vector(t(matrix(data=1:N,nrow=nspec))) # from ordering per spec -> per slice bmod <- function(time,state,pars,...) bmodel(time,state,pars,func,...) if (is.null(method)) method <- "lsode" if (iscomplex) { if (method == "vode") out <- zvode(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) else if (method == "bdf") out <- zvode(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) else if (method == "impAdams") out <- zvode(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, mf = 15, ...) } else if (method == "vode") out <- vode(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) else if (method == "lsode" || method == "bdf") out <- lsode(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) else if (method == "impAdams") out <- lsode(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, mf = 15, ...) else if (method == "lsoda") out <- lsoda(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) else if (method == "lsodar") out <- lsodar(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) else if (method == "daspk") out <- daspk(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) else if (method == "radau") out <- radau(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) else stop ("cannot run ode.1D: not a valid 'method'") out[,(ii+1)] <- out[,2:(N+1)] if (! is.null(NL)) colnames(out)[2:(N+1)]<- NL } if (is.null(dimens)) dimens <- N/nspec attr (out, "dimens") <- dimens attr (out, "nspec") <- nspec attr(out, "ynames") <- names return(out) } ### ============================================================================ ode.2D <- function (y, times, func, parms, nspec=NULL, dimens, method= c("lsodes","euler", "rk4", "ode23", "ode45", "adams","iteration"), names = NULL, cyclicBnd = NULL, ...) { # check input if (is.character(method)) method <- match.arg(method) if (is.null(method)) method <- "lsodes" islsodes <- FALSE if (is.character(method)) if (method=="lsodes") islsodes <- TRUE if (any(!is.na(pmatch(names(list(...)), "jacfunc")))) stop ("cannot run ode.2D with jacfunc specified - remove jacfunc from call list") if (is.null(dimens)) stop ("cannot run ode.2D: dimens should be specified") if (length(dimens)!=2) stop ("cannot run ode.2D: dimens should contain 2 values") N <- length(y) if (N%%prod(dimens) !=0 ) stop ("cannot run ode.2D: dimensions are not an integer fraction of number of state variables") if (is.null (nspec)) nspec <- N/prod(dimens) else if (nspec*prod(dimens) != N) stop ("cannot run ode.2D: dimens[1]*dimens[2]*nspec is not equal to number of state variables") if (! is.null(names) && length(names) != nspec) stop("length of 'names' should equal 'nspec'") Bnd <- c(0,0) if (! is.null(cyclicBnd)) { if (max(cyclicBnd) > 2 ) stop ("cannot run ode.2D: cyclicBnd should be a vector or number not exceeding 2") Bnd[cyclicBnd[cyclicBnd>0]]<-1 } # use lsodes - note:expects rev(dimens)... if (is.character(func) || islsodes) { if (is.character(method)) if ( method != "lsodes") warning("ode.2D: R-function specified in a DLL-> integrating with lsodes") # if (bandwidth != 1) # try to use sparsetype also for bandwidth != 1 # out <- lsodes(y=y,times=times,func=func,parms,...) # else bandwidth<-1 out <- lsodes(y=y, times=times, func=func, parms, sparsetype="2D", nnz=c(nspec, rev(dimens), rev(Bnd), bandwidth), ...) # a runge kutta } else if (is.list(method)) { if (!inherits(method, "rkMethod" )) stop("'method' should be given as string or as a list of class 'rkMethod'") out <- rk(y, times, func, parms, method = method, ...) # a function } else if (is.function(method)) out <- method(y, times, func, parms,...) # an explicit method else if (method %in% c("euler", "rk4", "ode23", "ode45", "adams","iteration")) { if (method == "euler") out <- rk(y, times, func, parms, method = "euler", ...) else if (method == "rk4") out <- rk(y, times, func, parms, method = "rk4", ...) else if (method == "ode23") out <- rk(y, times, func, parms, method = "ode23", ...) else if (method == "ode45") out <- rk(y, times, func, parms, method = "ode45", ...) else if (method == "adams") out <- lsode(y, times, func, parms, mf = 10, ...) else if (method == "iteration") out <- iteration(y, times, func, parms, ...) } else { stop ("cannot run ode.2D: not a valid 'method'") } attr (out,"dimens") <- dimens attr (out,"nspec") <- nspec attr (out,"ynames") <- names return(out) } ### ============================================================================ ode.3D <- function (y, times, func, parms, nspec=NULL, dimens, method= c("lsodes","euler", "rk4", "ode23", "ode45", "adams","iteration"), names = NULL, cyclicBnd = NULL, ...){ # check input if (is.character(method)) method <- match.arg(method) if (is.null(method)) method <- "lsodes" if (any(!is.na(pmatch(names(list(...)), "jacfunc")))) stop ("cannot run ode.3D with jacfunc specified - remove jacfunc from call list") if (is.null(dimens)) stop ("cannot run ode.3D: dimens should be specified") if (length(dimens)!=3) stop ("cannot run ode.3D: dimens should contain 3 values") N <- length(y) if (N%%prod(dimens) !=0 ) stop ("cannot run ode.3D: dimensions are not an integer fraction of number of state variables") if (is.null (nspec)) nspec <- N/prod(dimens) else if (nspec*prod(dimens) != N) stop ("cannot run ode.3D: dimens[1]*dimens[2]*dimens[3]*nspec is not equal to number of state variables") if (! is.null(names) && length(names) != nspec) stop("length of 'names' should equal 'nspec'") Bnd <- c(0,0,0) # cyclicBnd not included if (! is.null(cyclicBnd)) { if (max(cyclicBnd) > 3 ) stop ("cannot run ode.3D: cyclicBnd should be a vector or number not exceeding 3") Bnd[cyclicBnd[cyclicBnd>0]]<-1 } # use lsodes - note:expects rev(dimens)... if (is.character(func) || method=="lsodes") { if ( method != "lsodes") warning("ode.3D: R-function specified in a DLL-> integrating with lsodes") # if (bandwidth != 1) # try to use sparsetype also for bandwidth != 1 # out <- lsodes(y=y,times=times,func=func,parms,...) # else bandwidth<-1 out <- lsodes(y=y, times=times, func=func, parms, sparsetype="3D", nnz=c(nspec,rev(dimens), rev(Bnd), bandwidth), ...) # a runge-kutta } else if (is.list(method)) { if (!inherits(method, "rkMethod")) stop("'method' should be given as string or as a list of class 'rkMethod'") out <- rk(y, times, func, parms, method = method, ...) # another function } else if (is.function(method)) out <- method(y, times, func, parms,...) # an explicit method else if (method %in% c("euler", "rk4", "ode23", "ode45", "adams","iteration")) { if (method == "euler") out <- rk(y, times, func, parms, method="euler", ...) else if (method == "rk4") out <- rk(y, times, func, parms, method = "rk4", ...) else if (method == "ode23") out <- rk(y, times, func, parms, method = "ode23", ...) else if (method == "ode45") out <- rk(y, times, func, parms, method = "ode45", ...) else if (method == "adams") out <- lsode(y, times, func, parms, mf = 10, ...) else if (method == "iteration") out <- iteration(y, times, func, parms, ...) } else { stop ("cannot run ode.3D: not a valid 'method'") } attr (out,"dimens") <- dimens attr (out,"nspec") <- nspec attr (out,"ynames") <- names return(out) } ### ============================================================================ ode.band <- function (y, times, func, parms, nspec = NULL, dimens = NULL, bandup = nspec, banddown = nspec, method = "lsode", names = NULL, ...) { if (is.null(bandup) ) stop ("cannot run ode.band: bandup is not specified") if (is.null(banddown)) stop ("cannot run ode.band: banddown is not specified") if (is.null(nspec) && is.null(dimens)) stop ("cannot run ode.band: nspec OR dimens should be specified") N <- length(y) if (is.null(nspec) ) nspec <- N/dimens if (N %% nspec != 0 ) stop ("cannot run ode.band: nspec is not an integer fraction of number of state variables") if (! is.null(names) && length(names) != nspec) stop("length of 'names' should equal 'nspec'") if (is.null(method)) method <- "lsode" if (method == "vode") out <- vode(y, times, func, parms=parms, bandup=bandup, banddown=banddown, jactype="bandint", ...) else if (method == "lsode") out <- lsode(y, times, func, parms=parms, bandup=bandup, banddown=banddown, jactype="bandint", ...) else if (method == "lsoda") out <- lsoda(y, times, func, parms=parms, bandup=bandup, banddown=banddown, jactype="bandint", ...) else if (method == "lsodar") out <- lsodar(y, times, func, parms=parms, bandup=bandup, banddown=banddown, jactype="bandint", ...) else if (method == "daspk") out <- daspk(y, times, func, parms=parms, bandup=bandup, banddown=banddown, jactype="bandint", ...) else if (method == "radau") out <- radau(y, times, func, parms=parms, bandup=bandup, banddown=banddown, jactype="bandint", ...) else stop ("cannot run ode.band: method should be one of vode, lsoda, lsodar or lsode") N <- length(y) attr (out,"dimens") <- N/nspec attr (out,"nspec") <- nspec attr (out, "ynames") <- names return(out) } deSolve/R/zvode.R0000644000176000001440000002543213572677236013406 0ustar ripleyusers ### ============================================================================ ### zvode -- solves ordinary differential equation systems ### ### This is vode for complex numbers ### ============================================================================ zvode <- function(y, times, func, parms, rtol=1e-6, atol=1e-6, jacfunc=NULL, jactype = "fullint", mf = NULL, verbose=FALSE, tcrit = NULL, hmin=0, hmax=NULL, hini=0, ynames=TRUE, maxord=NULL, bandup=NULL, banddown=NULL, maxsteps=5000, dllname=NULL, initfunc=dllname, initpar=parms, rpar=NULL, ipar=NULL, nout=0, outnames=NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, ...) { ### check input n <- length(y) if (! is.null(times) && !is.numeric(times)) stop("`times' must be NULL or numeric") if (!is.function(func) && !is.character(func)) stop("`func' must be a function or character vector") if (is.character(func) && (is.null(dllname) || !is.character(dllname))) stop("specify the name of the dll or shared library where func can be found (without extension)") if (!is.numeric(rtol)) stop("`rtol' must be numeric") if (!is.numeric(atol)) stop("`atol' must be numeric") if (!is.null(tcrit) & !is.numeric(tcrit)) stop("`tcrit' must be numeric") if (!is.null(jacfunc) && !(is.function(jacfunc) || is.character(jacfunc))) stop(paste(jacfunc," must be a function or character vector")) if (length(atol) > 1 && length(atol) != n) stop("`atol' must either be a scalar, or as long as `y'") if (length(rtol) > 1 && length(rtol) != n) stop("`rtol' must either be a scalar, or as long as `y'") if (!is.numeric(hmin)) stop("`hmin' must be numeric") if (hmin < 0) stop("`hmin' must be a non-negative value") if (is.null(hmax)) hmax <- if (is.null(times)) 0 else max(abs(diff(times))) if (!is.numeric(hmax)) stop("`hmax' must be numeric") if (hmax < 0) stop("`hmax' must be a non-negative value") if (hmax == Inf) hmax <- 0 if (!is.null(hini)) if(hini < 0) stop("`hini' must be a non-negative value") if (!is.null(maxord)) if (maxord < 1) stop("`maxord' must be >1") ### Jacobian, method flag if (is.null(mf)) { if (jactype == "fullint" ) imp <- 22 # full, calculated internally else if (jactype == "fullusr" ) imp <- 21 # full, specified by user function else if (jactype == "bandusr" ) imp <- 24 # banded, specified by user function else if (jactype == "bandint" ) imp <- 25 # banded, calculated internally else stop("'jactype' must be one of 'fullint', 'fullusr', 'bandusr' or 'bandint' if 'mf' not specified") } else imp <- mf if (! imp %in% c(10:17, 20:27, -11,-12,-14,-15,-21, -22, -24: -27)) stop ("method flag 'mf' not allowed") # check other specifications depending on Jacobian miter <- abs(imp)%%10 if (miter %in% c(1,4) & is.null(jacfunc)) stop ("'jacfunc' NOT specified; either specify 'jacfunc' or change 'jactype' or 'mf'") meth <- abs(imp)%/%10 # basic linear multistep method jsv <- sign(imp) if (is.null (maxord)) maxord <- ifelse(meth==1,12,5) if (meth==1 && maxord > 12) stop ("'maxord' too large: should be <= 12") if (meth==2 && maxord > 5 ) stop ("'maxord' too large: should be <= 5") if (miter %in% c(4,5) && is.null(bandup)) stop("'bandup' must be specified if banded Jacobian") if (miter %in% c(4,5) && is.null(banddown)) stop("'banddown' must be specified if banded Jacobian") if (is.null(banddown)) banddown <-1 if (is.null(bandup )) bandup <-1 ### model and Jacobian function Func <- NULL JacFunc <- NULL ## if (miter == 4) Jacobian should have banddown empty rows-vode only! if (miter == 4 && banddown>0) erow<-matrix(data=0, ncol=n, nrow=banddown) else erow<-NULL Ynames <- attr(y,"names") flist<-list(fmat=0,tmat=0,imat=0,ModelForc=NULL) ModelInit <- NULL if (is.character(func) | inherits(func, "CFunc")) { # function specified in a DLL or inline compiled DLL <- checkDLL(func,jacfunc,dllname, initfunc,verbose,nout, outnames) ModelInit <- DLL$ModelInit Func <- DLL$Func JacFunc <- DLL$JacFunc Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,verbose,fcontrol) rho <- NULL if (is.null(ipar)) ipar<-0 if (is.null(rpar)) rpar<-0 if (!is.null(jacfunc)) { # if (miter == 4) Jacobian should have empty banddown empty rows # This is so for vode only; other solvers do not need this # As this is not compatible with other solvers, this option has been # toggled off (otherwise DLL function might crash) if (miter == 4&& banddown>0) stop("The combination of user-supplied banded Jacobian in a dll is NOT allowed") } } else { if(is.null(initfunc)) initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) # func and jac are overruled, either including ynames, or not # This allows to pass the "..." arguments and the parameters if(ynames) { Func <- function(time,state) { attr(state,"names") <- Ynames func (time,state,parms,...)[1] } Func2 <- function(time,state){ attr(state,"names") <- Ynames func (time,state,parms,...) } JacFunc <- function(time,state){ attr(state,"names") <- Ynames rbind(jacfunc(time,state,parms,...),erow) } } else { # no ynames... Func <- function(time,state) func (time,state,parms,...)[1] Func2 <- function(time,state) func (time,state,parms,...) JacFunc <- function(time,state) rbind(jacfunc(time,state,parms,...),erow) } ## Check function and return the number of output variables +name FF <- checkFuncComplex(Func2,times,y,rho) Nglobal<-FF$Nglobal Nmtot <- FF$Nmtot if (miter %in% c(1,4)) { tmp <- eval(JacFunc(times[1], y), rho) if (!is.matrix(tmp)) stop("Jacobian function must return a matrix\n") dd <- dim(tmp) if((miter ==4 && any(dd != c(bandup+banddown+banddown+1,n))) || (miter ==1 && any(dd != c(n,n)))) stop("Jacobian dimension not ok") } } ### work arrays iwork, rwork # length of rwork, zwork and iwork lzw <- n*(maxord+1)+2*n if(miter %in% c(1,2) && imp>0) lzw <- lzw + 2*n*n+2 if(miter %in% c(1,2) && imp<0) lzw <- lzw + n*n if(miter ==3) lzw <- lzw + n if(miter %in% c(4,5) && imp>0) lzw <- lzw + (3*banddown+2*bandup+2)*n if(miter %in% c(4,5) && imp<0) lzw <- lzw + (2*banddown+bandup+1)*n lrw <- 20 +n liw <- ifelse(miter %in% c(0,3),30,30+n) # only first 20 or 30 elements passed; other will be allocated in C-code iwork <- vector("integer",30) rwork <- vector("double",20) rwork[] <- 0. iwork[] <- 0 iwork[1] <- banddown iwork[2] <- bandup iwork[5] <- maxord iwork[6] <- maxsteps if(! is.null(tcrit)) rwork[1] <- tcrit rwork[5] <- hini rwork[6] <- hmax rwork[7] <- hmin ### the task to be performed. if (! is.null(times)) itask <- ifelse (is.null (tcrit), 1,4) else # times specified itask <- ifelse (is.null (tcrit), 2,5) # only one step if(is.null(times)) times<-c(0,1e8) ### print to screen... if (verbose) { printtask(itask,func,jacfunc) printM("\n--------------------") printM("Integration method") printM("--------------------") df <- c("method flag, =", "jsv =", "meth =", "miter =") vals <- c(imp, jsv, meth, miter) txt <- "; (note: mf = jsv * (10 * meth + miter))" if (jsv==1) txt<-c(txt, "; a copy of the Jacobian is saved for reuse in the corrector iteration algorithm" ) else if (jsv==-1)txt<-c(txt, "; a copy of the Jacobian is not saved") if (meth==1)txt<-c(txt, "; the basic linear multistep method: the implicit Adams method") else if (meth==2)txt<-c(txt,"; the basic linear multistep method: based on backward differentiation formulas") if (miter==0)txt<-c(txt, "; functional iteration (no Jacobian matrix is involved") else if (miter==1)txt<-c(txt, "; chord iteration with a user-supplied full (NEQ by NEQ) Jacobian") else if (miter==2)txt<-c(txt, "; chord iteration with an internally generated full Jacobian, (NEQ extra calls to F per df/dy value)") else if (miter==3)txt<-c(txt, "; chord iteration with an internally generated diagonal Jacobian (1 extra call to F per df/dy evaluation)") else if (miter==4)txt<-c(txt, "; chord iteration with a user-supplied banded Jacobian") else if (miter==5)txt<-c(txt, "; chord iteration with an internally generated banded Jacobian (using ML+MU+1 extra calls to F per df/dy evaluation)") printmessage(df, vals, txt) } ### calling solver storage.mode(y) <- "complex" storage.mode(times) <- "double" on.exit(.C("unlock_solver")) out <- .Call("call_zvode", y, times, Func, initpar, rtol, atol, rho, tcrit, JacFunc, ModelInit, as.integer(itask), as.double(rwork),as.integer(iwork), as.integer(imp),as.integer(Nglobal), as.integer(lzw),as.integer(lrw),as.integer(liw), as.complex (rpar), as.integer(ipar),flist,PACKAGE = "deSolve") ### saving results nR <- ncol(out) out [1,] <- as.complex(times[1:nR]) # times not set here... out <- saveOut(out, y, n, Nglobal, Nmtot, func, Func2, iin=c(1,12:23), iout=1:13) attr(out, "type") <- "cvode" if (verbose) diagnostics(out) out } checkFuncComplex<- function (Func2, times, y, rho) { ## Call func once to figure out whether and how many "global" ## results it wants to return and some other safety checks if (! is.complex(y)) stop("'y' should be complex, not real") tmp <- eval(Func2(times[1], y), rho) if (!is.list(tmp)) stop("Model function must return a list\n") if (length(tmp[[1]]) != length(y)) stop(paste("The number of derivatives returned by func() (", length(tmp[[1]]), ") must equal the length of the initial conditions vector (", length(y),")",sep="")) if (! is.complex(tmp[[1]])) stop("derivatives (first element returned by 'func') should be complex, not real") # use "unlist" here because some output variables are vectors/arrays Nglobal <- if (length(tmp) > 1) length(unlist(tmp[-1])) else 0 Nmtot <- attr(unlist(tmp[-1]),"names") return(list(Nglobal = Nglobal, Nmtot=Nmtot)) } deSolve/R/rkMethod.R0000644000176000001440000003612413214571302014010 0ustar ripleyusers### ============================================================================ ### Butcher tables for selected explicit ODE solvers of Runge-Kutta type ### Note that for fixed step methods A is a vector (the subdiagonal of matrix A) ### For variable time step methods, A must be strictly lower triangular. ### The underlying rk codes support explicit methods ### and (still experimentally) some implicit methods. ### ============================================================================ rkMethod <- function(method = NULL, ...) { methods <- list( euler = list(ID = "euler", varstep = FALSE, A = c(0), b1 = c(1), c = c(0), stage = 1, Qerr = 1 ), ## Heun's method rk2 = list(ID = "rk2", varstep = FALSE, A = c(0, 1), b1 = c(0.5, 0.5), c = c(0, 1), stage = 2, Qerr = 1 ), ## classical Runge-Kutta 4th order method rk4 = list(ID = "rk4", varstep = FALSE, A = c(0, .5, .5, 1), b1 = c(1/6, 1/3, 1/3, 1/6), c = c(0, .5, .5, 1), stage = 4, Qerr = 4 ), ## One of the numerous RK23 formulae rk23 = list(ID = "rk23", varstep = TRUE, FSAL = FALSE, A = matrix(c(0, 0, 0, 1/2, 0, 0, -1, 2, 0), 3, 3, byrow = TRUE), b1 = c(0, 1, 0), b2 = c(1/6, 2/3, 1/6), c = c(0, 1/2, 2), stage = 3, Qerr = 2 ), ## Bogacki & Shampine rk23bs = list(ID = "rk23bs", varstep = TRUE, FSAL = TRUE, A = matrix(c(0, 0, 0, 0, 1/2, 0, 0, 0, 0, 3/4, 0, 0, 2/9, 1/3, 4/9, 0), 4, 4, byrow = TRUE), b1 = c(7/24, 1/4, 1/3, 1/8), b2 = c(2/9, 1/3, 4/9, 0), c = c(0, 1/2, 3/4, 1), stage = 4, Qerr = 2 ), ## RK-Fehlberg 34 rk34f = list(ID = "rk34f", varstep = TRUE, A = matrix(c(0, 0, 0, 0, 2/7, 0, 0, 0, 77/900, 343/900, 0, 0, 805/1444, -77175/54872, 97125/54872, 0, 79/490, 0, 2175/3626, 2166/9065), 5, 4, byrow = TRUE), b1 = c(79/490, 0, 2175/3626, 2166/9065, 0), b2 = c(229/1470, 0, 1125/1813, 13718/81585, 1/18), c = c(0, 2/7, 7/15, 35/38, 1), stage = 5, Qerr = 3 ), ## RK-Fehlberg Method 45 rk45f = list(ID = "rk45f", varstep = TRUE, A = matrix(c(0, 0, 0, 0, 0, 1/4, 0, 0, 0, 0, 3/32, 9/32, 0, 0, 0, 1932/2197, -7200/2197, 7296/2197, 0, 0, 439/216, -8, 3680/513, -845/4104, 0, -8/27, 2, -3544/2565, 1859/4104, -11/40), 6, 5, byrow = TRUE), b1 = c(25/216, 0, 1408/2565, 2197/4104, -1/5, 0), b2 = c(16/135, 0, 6656/12825, 28561/56430, -9/50, 2/55), c = c(0, 1/4, 3/8, 12/13, 1, 1/2), stage = 6, Qerr = 4 ), ## Cash-Karp method rk45ck = list(ID = "rk45ck", varstep = TRUE, FSAL = TRUE, A = matrix(c(0, 0, 0, 0, 0, 1/5, 0, 0, 0, 0, 3/40, 9/40, 0, 0, 0, 3/10, -9/10, 6/5, 0, 0, -11/54, 5/2, -70/27, 35/27, 0, 1631/55296, 175/512, 575/13824, 44275/110592, 253/4096), 6, 5, byrow = TRUE), b1 = c(2825/27648, 0, 18575/48384, 13525/55296, 277/14336, 1/4), b2 = c(37/378, 0, 250/621, 125/594, 0, 512/1771), c = c(0, 1/5, 3/10, 3/5, 1, 7/8), densetype = 2, # special dense output type 2 stage = 6, Qerr = 4), ## England Method rk45e = list(ID = "rk45e", varstep = TRUE, A = matrix(c(0, 0, 0, 0, 0, 1/2, 0, 0, 0, 0, 1/4, 1/4, 0, 0, 0, 0, -1, 2, 0, 0, 7/27, 10/27, 0, 1/27, 0, 28/625, -125/625, 546/625, 54/625, -378/625), 6, 5, byrow = TRUE), b1 = c(1/6, 0, 4/6, 1/6, 0, 0), b2 = c(14/336, 0, 0, 35/336, 162/336, 125/336), c = c(0, 1/2, 1/2, 1, 2/3, 1/5), stage = 6, Qerr = 4 ), ## Prince-Dormand 5(4)6m rk45dp6 = list(ID = "rk45dp6", varstep = TRUE, A = matrix(c(0, 0, 0, 0, 0, 1/5, 0, 0, 0, 0, 3/40, 9/40, 0, 0, 0, 3/10, -9/10, 6/5, 0, 0, 226/729, -25/27, 880/729, 55/729, 0, -181/270, 5/2, -266/297, -91/27, 189/55), 6, 5, byrow = TRUE), b1 = c(31/540, 0, 190/297, -145/108, 351/220, 1/20), b2 = c(19/216, 0, 1000/2079, -125/216, 81/88, 5/56), c = c(0, 1/5, 3/10, 3/5, 2/3, 1), stage = 6, Qerr = 4 ), ## Prince-Dormand 5(4)7m -- recommended by the Octave developers rk45dp7 = list(ID = "rk45dp7", varstep = TRUE, FSAL = TRUE, A = matrix(c(0, 0, 0, 0, 0, 0, 1/5, 0, 0, 0, 0, 0, 3/40, 9/40, 0, 0, 0, 0, 44/45, -56/15, 32/9, 0, 0, 0, 19372/6561, -25360/2187, 64448/6561, -212/729, 0, 0, 9017/3168, -355/33, 46732/5247, 49/176, -5103/18656, 0, 35/384, 0, 500/1113, 125/192, -2187/6784, 11/84), 7, 6, byrow = TRUE), b1 = c(5179/57600, 0, 7571/16695, 393/640, -92097/339200, 187/2100, 1/40), b2 = c(35/384, 0, 500/1113, 125/192, -2187/6784, 11/84, 0), c = c(0, 1/5, 3/10, 4/5, 8/9, 1, 1), d = c(-12715105075.0/11282082432.0, 0, 87487479700.0/32700410799.0, -10690763975.0/1880347072.0, 701980252875.0/199316789632.0, -1453857185.0/822651844.0, 69997945.0/29380423.0), densetype = 1, # default type of dense output formula, if available stage = 7, Qerr = 4 ), ## Prince-Dormand 78 method rk78dp = list(ID = "rk78dp", varstep = TRUE, FSAL = FALSE, A = matrix(c( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1/18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1/48, 1/16, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1/32, 0, 3/32, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5/16, 0, -75/64, 75/64, 0, 0, 0, 0, 0, 0, 0, 0, 3/80, 0, 0, 3/16, 3/20, 0, 0, 0, 0, 0, 0, 0, 29443841/614563906, 0, 0, 77736538/692538347, -28693883/1125000000, 23124283/1800000000, 0, 0, 0, 0, 0, 0, 16016141/946692911, 0, 0, 61564180/158732637, 22789713/633445777, 545815736/2771057229, -180193667/1043307555, 0, 0, 0, 0, 0, 39632708/573591083, 0, 0, -433636366/683701615, -421739975/2616292301, 100302831/723423059, 790204164/839813087, 800635310/3783071287, 0, 0, 0, 0, 246121993/1340847787, 0, 0, -37695042795/15268766246, -309121744/1061227803, -12992083/490766935, 6005943493/2108947869, 393006217/1396673457, 123872331/1001029789, 0, 0, 0, -1028468189/846180014, 0, 0, 8478235783/508512852, 1311729495/1432422823, -10304129995/1701304382, -48777925059/3047939560, 15336726248/1032824649, -45442868181/3398467696, 3065993473/597172653, 0, 0, 185892177/718116043, 0, 0, -3185094517/667107341, -477755414/1098053517, -703635378/230739211, 5731566787/1027545527, 5232866602/850066563, -4093664535/808688257, 3962137247/1805957418, 65686358/487910083, 0, 403863854/491063109, 0, 0, -5068492393/434740067, -411421997/543043805, 652783627/914296604, 11173962825/925320556, -13158990841/6184727034, 3936647629/1978049680, -160528059/685178525, 248638103/1413531060, 0), nrow = 13, ncol = 12 , byrow = TRUE), b1 = c(13451932/455176623, 0, 0, 0, 0, -808719846/976000145, 1757004468/5645159321, 656045339/265891186, -3867574721/1518517206, 465885868/322736535, 53011238/667516719, 2/45, 0), b2 = c(14005451/335480064, 0, 0, 0, 0, -59238493/1068277825, 181606767/758867731, 561292985/797845732, -1041891430/1371343529, 760417239/1151165299, 118820643/751138087, -528747749/2220607170, 1/4), c = c(0, 1/18, 1/12, 1/8, 5/16, 3/8, 59/400, 93/200, 5490023248/9719169821, 13/20, 1201146811/1299019798, 1, 1), stage = 13, Qerr = 7 ), ## Runge-Kutta-Fehlberg 78 method rk78f = list(ID = "rk78f", varstep = TRUE, FSAL = FALSE, A = matrix( c(rep(0,12), 2/27, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1/36, 1/12, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1/24, 0, 1/8, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5/12, 0, -25/16, 25/16, 0, 0, 0, 0, 0, 0, 0, 0, 0.05, 0, 0, 0.25, 0.2, 0, 0, 0, 0, 0, 0, 0, -25/108, 0, 0, 125/108, -65/27, 125/54, 0, 0, 0, 0, 0, 0, 31/300, 0, 0, 0, 61/225, -2/9, 13/900, 0, 0, 0, 0, 0, 2, 0, 0, -53/6, 704/45, -107/9, 67/90, 3, 0, 0, 0, 0, -91/108, 0, 0, 23/108, -976/135, 311/54, -19/60, 17/6, -1/12, 0, 0, 0, 2383/4100, 0, 0, -341/164, 4496/1025, -301/82, 2133/4100, 45/82, 45/164, 18/41, 0, 0, 3/205, 0, 0, 0, 0, -6/41, -3/205, -3/41, 3/41, 6/41, 0, 0, -1777/4100, 0, 0, -341/164, 4496/1025, -289/82, 2193/4100, 51/82, 33/164, 12/41, 0, 1 ), nrow=13, ncol=12, byrow = TRUE), b1 = c(41/840, 0,0,0,0, 34/105, 9/35, 9/35, 9/280, 9/280, 41/840, 0, 0), b2 = c(0, 0, 0, 0, 0, 34/105, 9/35, 9/35, 9/280, 9/280, 0, 41/840, 41/840), c = c(0, 2./27., 1/9, 1/6, 5/12, 0.5, 5/6, 1/6, 2/3, 1/3, 1, 0, 1), stage = 13, Qerr = 7 ), ## ------------------------------------------------------------------------- ## Implicit methods; experimental! ## ------------------------------------------------------------------------- ## Radau order 3 irk3r = list(ID = "irk3r", varstep = FALSE, implicit = TRUE, A = matrix( c(5/12, -1/12, 3/4, 1/4), nrow = 2, ncol = 2, byrow = TRUE), b1 = c(3/4, 1/4) , c = c(1/3, 1/4), stage = 2, Qerr = 3 ), ## Radau IIA order 5 irk5r = list(ID = "irk5r", varstep = FALSE, implicit = TRUE, A = matrix( c((88-7*sqrt(6))/360, (296-169*sqrt(6))/1800, (-2+3*sqrt(6))/225, (296+169*sqrt(6))/1800, (88+7*sqrt(6))/360, (-2-3*sqrt(6))/225, (16-sqrt(6))/36, (16+sqrt(6))/36, 1/9), nrow = 3, ncol = 3, byrow = TRUE), b1 = c((16-sqrt(6))/36, (16+sqrt(6))/36, 1/9), c = c(0.4-sqrt(6)/10, 0.4+sqrt(6)/10, 1), stage = 3, Qerr = 5 ), ## Hammer - Hollingsworth coefficients , order 4 irk4hh = list(ID = "irk4hh", varstep = FALSE, implicit = TRUE, A = matrix( c(1/4, 1/4-sqrt(3)/6, 1/4+sqrt(3)/6, 1/4), nrow = 2, ncol = 2, byrow = TRUE), b1 = c(1/2, 1/2), c = c(0.5-sqrt(3)/6, 0.5+sqrt(3)/6), stage = 2, Qerr = 4 ), ## Kuntzmann and Butcher order 6 irk6kb = list(ID = "irk6kb", varstep = FALSE, implicit = TRUE, A = matrix(c(5/36, 2/9-sqrt(15)/15, 5/36 - sqrt(15)/30, 5/36+sqrt(15)/24, 2/9, 5/36-sqrt(15)/24, 5/36+sqrt(15)/30, 2/9+sqrt(15)/15, 5/36), nrow = 3, ncol = 3, byrow = TRUE), b1 = c(5/18, 4/9, 5/18), c = c(1/2-sqrt(15)/10, 1/2, 1/2+sqrt(15)/10), stage = 3, Qerr = 6 ), ## Lobatto order 4 irk4l = list(ID = "irk4l", varstep = FALSE, implicit = TRUE, A = matrix(c(0, 0, 0, 1/4,1/4,0, 0, 1, 0), nrow=3, ncol=3, byrow = TRUE), b1 = c(1/6, 2/3, 1/6) , c = c(0, 1/2, 1), stage = 3, Qerr = 4 ), ## Lobatto order 6 irk6l = list(ID = "irk6l", varstep = FALSE, implicit = TRUE, A = matrix( c(0, 0, 0, 0, (5+sqrt(5))/60, 1/6, (15-7*sqrt(5))/60, 0, (5-sqrt(5))/60, (15+7*sqrt(5))/60, 1/6, 0, 1/6, (5-sqrt(5))/12, (5+sqrt(5))/12, 0), nrow = 4, ncol = 4, byrow = TRUE), b1 = c(1/12, 5/12, 5/12, 1/12) , c = c(0,(5-sqrt(5))/10, (5+sqrt(5))/10, 1), stage = 4, Qerr = 6 ) ) ## --------------------------------------------------------------------------- ## look if the method is known; ode23 and ode45 are used as synonyms ## --------------------------------------------------------------------------- knownMethods <- c(lapply(methods,"[[", "ID"), "ode23", "ode45") if (!is.null(method)) { method <- unlist(match.arg(method, knownMethods)) if (method == "ode23") method <- "rk23bs" else if (method == "ode45") method <- "rk45dp7" out <- methods[[method]] } else { out <- vector("list", 0) } ## modify a known or add a completely new method) ldots <- list(...) out[names(ldots)] <- ldots ## return the IDs of the methods if called with an empty argument list if (is.null(method) & length(ldots) == 0) { out <- as.vector(unlist(knownMethods)) } else { ## check size consistency of parameter sets sl <- lapply(out, length) stage <- out$stage if (is.matrix(out$A)) { if (nrow(out$A) != stage | ncol(out$A) < stage -1 | ncol(out$A) > stage) stop("Size of matrix A does not match stage") } else { if (length(out$A) != stage) stop("Size of matrix A does not match stage") } if (stage != sl$b1 | stage != sl$c) stop("Wrong rkMethod, length of parameters do not match") if (out$varstep & is.null(out$b2)) stop("Variable stepsize method needs non-empty b2") if (!is.null(out$b2)) if (sl$b2 != stage) stop("Wrong rkMethod, length of b2 must be empty or equal to stage") if (!is.null(out[["d"]])) # exact argument matching! if (sl[["d"]] != stage) stop("Wrong rkMethod, length of d must be empty or equal to stage") ## check densetype if (!is.null(out$densetype)) { if (out$densetype == 1) if (!(out$ID %in% c("rk45dp7", "ode45"))) stop("densetype = 1 not implemented for this method") if (out$densetype == 2) if (!(out$ID %in% c("rk45ck"))) stop("densetype = 2 not implemented for this method") } class(out) <- c("list", "rkMethod") } out } deSolve/R/checkevents.R0000644000176000001440000001775213572677236014567 0ustar ripleyusers### ============================================================================ ### Check events data set ### Changes version 1.11: event can be an R-function, even if DLL model ### continueeroot: to continue even if a root is found ### ============================================================================ checkevents <- function (events, times, vars, dllname, root = FALSE) { if (is.null(events)) return(list()) if (is.null(events$data) && is.null(events$func) && is.null(events$terminalroot)) return(list()) funevent <- events$func if (root) { # check if root should trigger an event... Root <- events$root if (is.null(Root)) Root <- 0 Root <- as.integer(Root) } else Root <- 0L maxroot <- events$maxroot if (is.null(maxroot)) maxroot <- 100 # number of roots to save. if (maxroot < 0) stop("events$maxroot should be > 0 in events") Terminalroot <- events$terminalroot if (! is.null(Terminalroot) && is.null(funevent)) funevent <- function(t,y,p) return(y) # dummy event function if (is.null(Terminalroot)) Terminalroot <- 0 # at which roots simulation should continue ## ---------------------- ## event in a function ## ---------------------- if (!is.null(funevent)) { if (inherits (funevent, "CFunc")) { funevent <- body(funevent)[[2]] Type <- 3 } else if (is.character(funevent)){ if (is.null(dllname)) stop("'dllname' should be given if 'events$func' is a string") if (is.loaded(funevent, PACKAGE = dllname, type = "") || is.loaded(funevent, PACKAGE = dllname, type = "Fortran")) { funevent <- getNativeSymbolInfo(funevent, PACKAGE = dllname)$address } else stop(paste("'events$func' should be loaded ",funevent)) Type <- 3 } else { Type <- 2 # SHOULD ALSO CHECK THE FUNCTION if R-function.... # if (!is.null(dllname)) KARLINE: removed that 02/07/2011 # stop("'events$func' should be a string, events specified in compiled code if 'dllname' is not NULL") } if (Root == 0) { if (is.null(events$time)) stop("either 'events$time' should be given and contain the times of the events, if 'events$func' is specified and no root function or your solver does not support root functions") eventtime <- sort(as.double(events$time)) # Karline: sorted that 4-01-2016 if (any(!(eventtime %in% times))) { warning("Not all event times 'events$time' are in output 'times' so they are automatically included.") uniqueTimes <- cleanEventTimes(times, eventtime) if (length(uniqueTimes) < length(times)) warning("Some time steps were very close to events - only the event times are used in these cases.") times <- sort(c(uniqueTimes, eventtime)) } } else eventtime <- min(times) - 1 # never reached.... return (list (Time = eventtime, SVar = NULL, Value = NULL, Method = NULL, Type = as.integer(Type), func = funevent, Rootsave = as.integer(maxroot), Root = Root, Terminalroot = as.integer(Terminalroot), newTimes = times)) # added newTimes - Karline 4-01-2016 } ## ---------------------- ## event as a data series ## ---------------------- eventdata <- events$data if (is.matrix(eventdata)) eventdata <- as.data.frame(eventdata) if (ncol(eventdata) < 3) stop("'event' should have at least 3 columns: state variable, time, value") if (!is.data.frame(eventdata)) stop("'event' should be a data.frame with 3(4) columns: state variable, time, value, (method)") ## this should make check < 3 columns obsolete evtcols <- c("var", "time", "value", "method") if (!all(evtcols %in% names(eventdata))) stop("structure of events does not match specification, see help('events')") ## make sure that event data frame has correct order eventdata <- eventdata[evtcols] ## variables, 1st column should be present if (is.factor(eventdata[,1])) eventdata[,1] <- as.character(eventdata[,1]) if (is.character(eventdata[,1])) { vv <- match(eventdata[,1], vars) if (is.character(eventdata[,1])) { vv <- match(eventdata[,1],vars) if (any(is.na(vv))) stop("unknown state variable in 'event': ", paste(eventdata[,1][which(is.na(vv))], ",")) eventdata[,1] <- vv } else if (max(eventdata[,1]) > length(vars)) stop("unknown state variable in 'event': ", paste(eventdata[,1][which(is.na(vv))],",")) eventdata[,1] <- vv } else if (max(eventdata[,1])>length(vars)) stop("too many state variables in 'event'; should be < ", paste(length(vars))) ## 2nd and 3rd columns should be numeric if (!is.numeric(eventdata[,2])) stop("times in 'event', 2nd column should be numeric") if (!is.numeric(eventdata[,3])) stop("values in 'event', 3rd column should be numeric") ## Times in 'event' should be embraced by 'times' rt <- range(times) ii <- c(which(eventdata[,2] < rt[1]), which(eventdata[,2] > rt[2])) if (length(ii) > 0) eventdata <- eventdata [-ii,] if (any(!(eventdata[,2] %in% times))) { warning("Not all event times 'events$times' were in output 'times' so they are automatically included.") uniqueTimes <- cleanEventTimes(times, eventdata[,2]) if (length(uniqueTimes) < length(times)) warning("Some time steps were very close to events - only the event times are used in these cases.") times <- sort(c(uniqueTimes, eventdata[,2])) } if (any(!(eventdata[,2] %in% times))) { warning("Not all event times 'events$times' where in output 'times' so they are automatically included.") uniqueTimes <- cleanEventTimes(times, eventdata[,2]) if (length(uniqueTimes) < length(times)) warning("Some time steps were very close to events - only the event times are used in these cases.") times <- sort(c(uniqueTimes, eventdata[,2])) } ## check if times are ordered and if not, fix it if (any(diff(eventdata[,2]) < 0)) { warning("Time of events ('time' column of 'events') was not ordered.") ord <- order(eventdata[,2]) eventdata <- eventdata[ord,] } ## 4th column: method; if not available: "replace" = method 1 - to date: 3 methods if (ncol(eventdata) ==3) eventdata$method <- rep(1,nrow(eventdata)) else if (is.numeric(eventdata[,4])) { if (max(eventdata[,4]) > 3 | min(eventdata[,4]) < 1) stop("unknown method in 'event': should be >0 and < 4") } else { vv <- charmatch(eventdata[,4],c("replace","add","multiply")) if (any(is.na(vv))) stop("unknown method in 'event': ", paste(eventdata[,3][which(is.na(vv))],","), " should be one of 'replace', 'add', 'multiply'") eventdata$method <- vv } ## Check the other events elements (see optim code) con <- list(ties = "notordered", time = NULL, data = NULL, func = NULL, root = NULL) nmsC <- names(con) con[(namc <- names(events))] <- events if (length(noNms <- namc[!namc %in% nmsC]) > 0) warning("unknown names in events: ", paste(noNms, collapse = ", ")) ## Check what needs to be done in case the time series is not "ordered" if (!identical(con$ties, "ordered")) { # see approx code ## first order with respect to time (2nd col), then to variable (1st col) if(length(x <- unique(eventdata[,1:2])) < nrow(eventdata)){ ties <- mean if (missing(ties)) warning("collapsing to unique 'x' values") eventdata <- aggregate(eventdata[,c(3, 4)], eventdata[,c(1, 2)], ties) ties <- mean if (missing(ties)) warning("collapsing to unique 'x' values") eventdata <- aggregate(eventdata[,c(3,4)], eventdata[,c(1,2)], ties) } } return (list (Time = as.double(eventdata[,2]), SVar = as.integer(eventdata[,1]), Value = as.double(eventdata[,3]), Method = as.integer(eventdata[,4]), Rootsave = as.integer(maxroot), Type = 1L, Root = Root, Terminalroot = as.integer(Terminalroot), newTimes = times)) } deSolve/R/cleanEventTimes.R0000644000176000001440000000221013214571302015306 0ustar ripleyusers## find nearest event for each time step nearestEvent <- function(times, eventtimes) { eventtimes <- unique(eventtimes) # remove double events first ## sorting does not cost much if already sorted times <- sort(times) eventtimes <- sort(eventtimes) ## find index of events where time is between inearest <- findInterval(times, eventtimes) ## special care for smallest and biggest element lower <- eventtimes[pmax(inearest, 1)] upper <- eventtimes[pmin(inearest + 1, length(eventtimes))] nearest <- ifelse(times - lower < upper - times, lower, upper) return(nearest) } ## remove times that are numerically "too close" to an event cleanEventTimes <- function(times, eventtimes, eps = .Machine$double.eps * 10) { ## sorting does not cost much if already sorted ## sort times to ensure match of returned "nearest" value times <- sort(times) nearest <- nearestEvent(times, eventtimes) ## use bigger of the two numbers div <- pmax(times, nearest) ## special handling of zero div <- ifelse(div == 0, 1, div) reldiff <- abs(times - nearest) / div tooClose <- reldiff < eps times[!tooClose] } deSolve/R/vode.R0000644000176000001440000002550013572677236013210 0ustar ripleyusers### ============================================================================ ### vode -- solves ordinary differential equation systems ### The user has to specify whether or not ### the problem is stiff and choose the appropriate method. ### It is very similar to lsode, except for some implementation details. ### More specifically, ### 1. there are more methods (mf) available in vode compared to lsode. ### 2. the memory management is more flexible in vode: ### when a method flag (mf) is positive, vode will save ### a copy of the Jacobian for reuse in the corrector iteration algorithm; ### for negative method flags a copy of the Jacobian is not saved. ### Thus negative flags need less memory, but positive flags ### may be (slightly) faster ### nb. this reduced memory strategy is the only option of lsode - a mf=21 ### in lsode is then equivalent to a mf = -21 in vode. ### ============================================================================ vode <- function(y, times, func, parms, rtol=1e-6, atol=1e-6, jacfunc=NULL, jactype = "fullint", mf = NULL, verbose=FALSE, tcrit = NULL, hmin=0, hmax=NULL, hini=0, ynames=TRUE, maxord=NULL, bandup=NULL, banddown=NULL, maxsteps=5000, dllname=NULL, initfunc=dllname, initpar=parms, rpar=NULL, ipar=NULL, nout=0, outnames=NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, events=NULL, lags = NULL, ...) { ### check input if (is.list(func)) { # a list of compiled function specification if (!is.null(jacfunc) & "jacfunc" %in% names(func)) stop("If 'func' is a list that contains jacfunc, argument 'jacfunc' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(func)) stop("If 'func' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(func)) { if (! is.null(events)) events$func <- func$eventfunc else events <- list(func = func$eventfunc) } if (!is.null(func$jacfunc)) jacfunc <- func$jacfunc if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$dllname)) dllname <- func$dllname if (!is.null(func$initforc)) initforc <- func$initforc func <- func$func } hmax <- checkInput (y, times, func, rtol, atol, jacfunc, tcrit, hmin, hmax, hini, dllname) n <- length(y) if (!is.null(maxord)) if (maxord < 1) stop("`maxord' must be >1") ### Jacobian, method flag if (is.null(mf)) { if (jactype == "fullint" ) imp <- 22 # full, calculated internally else if (jactype == "fullusr" ) imp <- 21 # full, specified by user function else if (jactype == "bandusr" ) imp <- 24 # banded, specified by user function else if (jactype == "bandint" ) imp <- 25 # banded, calculated internally else stop("'jactype' must be one of 'fullint', 'fullusr', 'bandusr' or 'bandint' if 'mf' not specified") } else imp <- mf if (! imp %in% c(10:17, 20:27, -11,-12,-14,-15,-21, -22, -24: -27)) stop ("method flag 'mf' not allowed") # check other specifications depending on Jacobian miter <- abs(imp)%%10 if (miter %in% c(1,4) & is.null(jacfunc)) stop ("'jacfunc' NOT specified; either specify 'jacfunc' or change 'jactype' or 'mf'") meth <- abs(imp)%/%10 # basic linear multistep method jsv <- sign(imp) if (is.null (maxord)) maxord <- ifelse(meth==1,12,5) if (meth==1 && maxord > 12) stop ("'maxord' too large: should be <= 12") if (meth==2 && maxord > 5 ) stop ("'maxord' too large: should be <= 5") if (miter %in% c(4,5) && is.null(bandup)) stop("'bandup' must be specified if banded Jacobian") if (miter %in% c(4,5) && is.null(banddown)) stop("'banddown' must be specified if banded Jacobian") if (is.null(banddown)) banddown <-1 if (is.null(bandup )) bandup <-1 ### model and Jacobian function Func <- NULL JacFunc <- NULL ## if (miter == 4) Jacobian should have banddown empty rows! if (miter == 4 && banddown>0) erow<-matrix(data=0, ncol=n, nrow=banddown) else erow<-NULL Ynames <- attr(y,"names") flist<-list(fmat=0,tmat=0,imat=0,ModelForc=NULL) ModelInit <- NULL Eventfunc <- NULL events <- checkevents(events, times, Ynames, dllname) if (! is.null(events$newTimes)) times <- events$newTimes if (is.character(func) | inherits(func, "CFunc")) { # function specified in a DLL or inline compiled DLL <- checkDLL(func,jacfunc,dllname, initfunc,verbose,nout, outnames) ModelInit <- DLL$ModelInit Func <- DLL$Func JacFunc <- DLL$JacFunc Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,verbose,fcontrol) if (is.null(ipar)) ipar<-0 if (is.null(rpar)) rpar<-0 Eventfunc <- events$func if (is.function(Eventfunc)) rho <- environment(Eventfunc) else rho <- NULL } else { if(is.null(initfunc)) initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) # func and jac are overruled, either including ynames, or not # This allows to pass the "..." arguments and the parameters if(ynames) { Func <- function(time,state) { attr(state,"names") <- Ynames unlist(func (time,state,parms,...)) } Func2 <- function(time,state){ attr(state,"names") <- Ynames func (time,state,parms,...) } JacFunc <- function(time,state){ attr(state,"names") <- Ynames rbind(jacfunc(time,state,parms,...),erow) } if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) { attr(state,"names") <- Ynames events$func(time,state,parms,...) } } else { # no ynames... Func <- function(time,state) unlist(func (time,state,parms,...)) Func2 <- function(time,state) func (time,state,parms,...) JacFunc <- function(time,state) rbind(jacfunc(time,state,parms,...),erow) if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) events$func(time,state,parms,...) } ## Check function and return the number of output variables +name FF <- checkFunc(Func2,times,y,rho) Nglobal<-FF$Nglobal Nmtot <- FF$Nmtot if (! is.null(events$Type)) if (events$Type == 2) checkEventFunc(Eventfunc,times,y,rho) if (miter %in% c(1,4)) { tmp <- eval(JacFunc(times[1], y), rho) if (!is.matrix(tmp)) stop("Jacobian function must return a matrix\n") dd <- dim(tmp) if((miter ==4 && any(dd != c(bandup+banddown+banddown+1,n))) || (miter ==1 && any(dd != c(n,n)))) stop("Jacobian dimension not ok") } } ### work arrays iwork, rwork # length of rwork and iwork lrw <- 20+n*(maxord+1)+3*n if(miter %in% c(1,2) && imp>0) lrw <- lrw + 2*n*n+2 if(miter %in% c(1,2) && imp<0) lrw <- lrw + n*n+2 if(miter ==3) lrw <- lrw + n+2 if(miter %in% c(4,5) && imp>0) lrw <- lrw + (3*banddown+2*bandup+2)*n+2 if(miter %in% c(4,5) && imp<0) lrw <- lrw + (2*banddown+bandup+1)*n+2 liw <- ifelse(miter %in% c(0,3),30,30+n) # only first 20 or 30 elements passed; other will be allocated in C-code iwork <- vector("integer",30) rwork <- vector("double",20) rwork[] <- 0. iwork[] <- 0 iwork[1] <- banddown iwork[2] <- bandup iwork[5] <- maxord iwork[6] <- maxsteps if(! is.null(tcrit)) rwork[1] <- tcrit rwork[5] <- hini rwork[6] <- hmax rwork[7] <- hmin ### the task to be performed. if (! is.null(times)) itask <- ifelse (is.null (tcrit), 1,4) else # times specified itask <- ifelse (is.null (tcrit), 2,5) # only one step if(is.null(times)) times<-c(0,1e8) ### print to screen... if (verbose) { printtask(itask,func,jacfunc) printM("\n--------------------") printM("Integration method") printM("--------------------") df <- c("method flag, =", "jsv =", "meth =", "miter =") vals <- c(imp, jsv, meth, miter) txt <- "; (note: mf = jsv * (10 * meth + miter))" if (jsv==1) txt<-c(txt, "; a copy of the Jacobian is saved for reuse in the corrector iteration algorithm" ) else if (jsv==-1)txt<-c(txt, "; a copy of the Jacobian is not saved") if (meth==1)txt<-c(txt, "; the basic linear multistep method: the implicit Adams method") else if (meth==2)txt<-c(txt,"; the basic linear multistep method: based on backward differentiation formulas") if (miter==0)txt<-c(txt, "; functional iteration (no Jacobian matrix is involved") else if (miter==1)txt<-c(txt, "; chord iteration with a user-supplied full (NEQ by NEQ) Jacobian") else if (miter==2)txt<-c(txt, "; chord iteration with an internally generated full Jacobian, (NEQ extra calls to F per df/dy value)") else if (miter==3)txt<-c(txt, "; chord iteration with an internally generated diagonal Jacobian (1 extra call to F per df/dy evaluation)") else if (miter==4)txt<-c(txt, "; chord iteration with a user-supplied banded Jacobian") else if (miter==5)txt<-c(txt, "; chord iteration with an internally generated banded Jacobian (using ML+MU+1 extra calls to F per df/dy evaluation)") printmessage(df, vals, txt) } ### calling solver storage.mode(y) <- storage.mode(times) <- "double" IN <- 5 # vode is livermore solver type 5 lags <- checklags(lags,dllname) on.exit(.C("unlock_solver")) out <- .Call("call_lsoda", y, times, Func, initpar, rtol, atol, rho, tcrit, JacFunc, ModelInit, Eventfunc, as.integer(verbose),as.integer(itask), as.double(rwork),as.integer(iwork), as.integer(imp),as.integer(Nglobal), as.integer(lrw),as.integer(liw),as.integer(IN),NULL, 0L, as.double (rpar), as.integer(ipar), 0L, flist, events, lags, PACKAGE = "deSolve") ### saving results out [1,1] <- times[1] # t=0 may be altered by dvode! out <- saveOut(out, y, n, Nglobal, Nmtot, func, Func2, iin=c(1,12:23), iout=1:13) attr(out, "type") <- "vode" if (verbose) diagnostics(out) out } deSolve/R/SCOC.R0000644000176000001440000000107313136461011012753 0ustar ripleyusersSCOC <- function(times, y=NULL, parms, Flux, ...) { if (is.null(y)){ meanDepo <- mean(approx(Flux[,1],Flux[,2], xout=seq(1,365,by=1))$y) y <- meanDepo/parms } else if (length(y) != 1) stop ("length of state variable vector should be 1") if (length(parms) != 1) stop ("length of parameter vector should be 1") names(y) <- c("C") out <- vode(y, times, func = "scocder", parms = parms, dllname = "deSolve", initforc="scocforc", forcings=Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation","Depo"),...) out } deSolve/R/ccl4model.R0000644000176000001440000000064213136461011014073 0ustar ripleyusersccl4model <- function(times, y, parms, ...) { if (length(y) != 7) stop ("length of state variable vector should be 7") if (length(parms) != 21) stop ("length of parameter vector should be 21") names(y) <- c("AI","AAM","AT","AF","AL","CLT","AM") ode(y=y,dllname="deSolve",func="derivsccl4", initfunc = "initccl4",parms=parms, times=times,nout=3,outnames=c("DOSE","MASS","CP"),...) } deSolve/R/euler.R0000644000176000001440000001443713572677236013376 0ustar ripleyusers### ============================================================================ ### Interface to C code for Euler's ODE solver ### with fixed step size and without interpolation, see helpfile for details. ### ============================================================================ euler <- function(y, times, func, parms, verbose = FALSE, ynames = TRUE, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, ...) { if (is.list(func)) { ### IF a list if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$dllname)) dllname <- func$dllname if (!is.null(func$initforc)) initforc <- func$initforc func <- func$func } ## check for unsupported solver options dots <- list(...); nmdots <- names(dots) if(any(c("hmin", "hmax") %in% nmdots)) cat("hmin and hmax cannot be used in 'euler' (fixed steps).") if("hini" %in% nmdots) { cat("'hini' is not supported by this version of 'euler',\n") cat("but you can use ode(......, method = 'euler', hini= .....)\n") cat("to set internal time steps smaller than external steps.\n") } if(any(c("events", "rootfunc") %in% nmdots)) { warning("events and roots are not supported by this version of euler,\n", " but you can use ode(......, method = 'euler', .....)\n") } if(any(c("jacfunc", "jactype", "mf", "bandup", "banddown") %in% nmdots)) { warning("Euler and Runge-Kutta solvers make no use of a Jacobian,\n", " ('jacfunc', 'jactype', 'mf', 'bandup' and 'banddown' are ignored).\n") } if(any(c("lags") %in% nmdots)) { warning("lags are not yet implemented for Euler and Runge-Kutta solvers,\n", " (argument 'lags' is ignored).\n") } ## check input checkInputEuler(y, times, func, dllname) n <- length(y) ## Model as shared object (DLL)? Ynames <- attr(y, "names") Initfunc <- NULL flist <-list(fmat = 0, tmat = 0, imat = 0, ModelForc = NULL) Nstates <- length(y) # assume length of states is correct if (is.character(func) | inherits(func, "CFunc")) { # function specified in a DLL or inline compiled DLL <- checkDLL(func, NULL, dllname, initfunc, verbose, nout, outnames) Initfunc <- DLL$ModelInit Func <- DLL$Func Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings, times, dllname, initforc, verbose, fcontrol) rho <- NULL if (is.null(ipar)) ipar <- 0 if (is.null(rpar)) rpar <- 0 } else { initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) ## func and jac are overruled, either including ynames, or not ## This allows to pass the "..." arguments and the parameters if(ynames) { Func <- function(time, state, parms) { attr(state, "names") <- Ynames func (time, state, parms, ...) } } else { # no ynames ... Func <- function(time, state, parms) func (time, state, parms, ...) } ## Call func once to figure out whether and how many "global" ## results it wants to return and some other safety checks FF <- checkFuncEuler(Func, times, y, parms, rho, Nstates) Nglobal <- FF$Nglobal Nmtot <- FF$Nmtot } ## the CALL to the integrator on.exit(.C("unlock_solver")) out <- .Call("call_euler", as.double(y), as.double(times), Func, Initfunc, parms, as.integer(Nglobal), rho, as.integer(verbose), as.double(rpar), as.integer(ipar), flist, PACKAGE = "deSolve") ## saving results out <- saveOutrk(out, y, n, Nglobal, Nmtot, iin = c(1, 12, 13, 15), iout = c(1:3, 18)) ## === testing code === ## 'call_euler_t' is a version with transposed data structure in memory ## for checking a potential influence of memory layout and memory locality ## # out <- .Call("call_euler_t", as.double(y), as.double(times), # Func, Initfunc, parms, as.integer(Nglobal), rho, as.integer(verbose), # as.double(rpar), as.integer(ipar), flist, PACKAGE = "deSolve") # out <- saveOutrk(out, y, n, Nglobal, Nmtot, # iin = c(1, 12, 13, 15), iout = c(1:3, 18), transpose = TRUE) ## === end testing code === attr(out, "type") <- "rk" if (verbose) diagnostics(out) out } ## 1D version that is compatible with ode.1D ## possible inconsistencies and problems: ## - names, outnames, ynames ## - what happens if both nspec and dimens are specified ? euler.1D <- function(y, times, func, parms, nspec = NULL, dimens = NULL, names = NULL, verbose = FALSE, ynames = TRUE, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, ...) { if (is.null(nspec) && is.null(dimens)) stop ("cannot run euler.1D: nspec OR dimens should be specified") N <- length(y) if (is.null(dimens)) dimens <- N/nspec if (is.null(nspec)) nspec = N/dimens if (N %% nspec != 0 ) stop ("cannot run ode.1D: nspec is not an integer fraction of number of state variables") if (! is.null(names) && length(names) != nspec) stop("length of 'names' should equal 'nspec'") out <- euler(y, times, func, parms, verbose, ynames, dllname, initfunc, initpar, rpar, ipar, nout, outnames, forcings, initforc, fcontrol) attr (out, "dimens") <- dimens attr (out, "nspec") <- nspec attr(out, "ynames") <- names return(out) } deSolve/R/rk.R0000644000176000001440000002344613572677236012676 0ustar ripleyusers### ============================================================================ ### Interface to a generalized code for solving explicit variable and fixed ### step ODE solvers of the Runge-Kutta family, see helpfile for details. ### ============================================================================ rk <- function(y, times, func, parms, rtol = 1e-6, atol = 1e-6, verbose = FALSE, tcrit = NULL, hmin = 0, hmax = NULL, hini = hmax, ynames = TRUE, method = rkMethod("rk45dp7", ... ), maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, events = NULL, ...) { ## check for unsupported solver options dots <- list(...); nmdots <- names(dots) if(any(c("jacfunc", "jactype", "mf", "bandup", "banddown") %in% nmdots)) { warning("Euler and Runge-Kutta solvers make no use of a Jacobian,\n", " ('jacfunc', 'jactype', 'mf', 'bandup' and 'banddown' are ignored).\n") } if(any(c("lags") %in% nmdots)) { warning("lags are not yet implemented for Euler and Runge-Kutta solvers,\n", " (argument 'lags' is ignored).\n") } if (is.list(func)) { # a list of compiled functions if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(func)) stop("If 'func' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(func)) { if (! is.null(events)) events$func <- func$eventfunc else events <- list(func = func$eventfunc) } if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$dllname)) dllname <- func$dllname if (!is.null(func$initforc)) initforc <- func$initforc func <- func$func } if (is.character(method)) method <- rkMethod(method) varstep <- method$varstep if (!varstep & (hmin != 0 | !is.null(hmax))) cat("'hmin' and 'hmax' are ignored (fixed step Runge-Kutta method).\n") ## Check inputs hmax <- checkInput(y, times, func, rtol, atol, jacfunc = NULL, tcrit, hmin, hmax, hini, dllname) if (hmax == 0) hmax <- .Machine$double.xmax # i.e. practically unlimited n <- length(y) if (maxsteps < 0) stop("maxsteps must be positive") if (!is.finite(maxsteps)) maxsteps <- .Machine$integer.max - 1 if (is.null(tcrit)) tcrit <- max(times) ## ToDo: check for nonsense-combinations of densetype and d if (!is.null(method$densetype)) { ## make this an integer to avoid errors on the C level method$densetype <- as.integer(method$densetype) if (!(method$densetype %in% c(1L, 2L))) { warning("Unknown value of densetype; set to NULL") method$densetype <- NULL } } ## Checks and ajustments for Neville-Aitken interpolation ## - starting from deSolve >= 1.7 this interpolation method ## is disabled by default. ## - Dense output for special RK methods is enabled and ## all others adjust internal time steps to hit external time steps if (is.null(method$nknots)) { method$nknots <- 0L } else { method$nknots <- as.integer(ceiling(method$nknots)) } nknots <- method$nknots if (nknots > 8L) { warning("Large number of nknots does not make sense.") } else if (nknots < 2L) { ## method without or with disabled interpolation method$nknots <- 0L } else { trange <- diff(range(times)) ## ensure that we have at least nknots + 2 data points; + 0.5 for safety) ## to allow 3rd order polynomial interpolation ## for methods without built-in dense output if ((is.null(method$d) & # has no "dense output"? is.null(method$densetype) & # or no dense output type (hmax > 1.0/(nknots + 2.5) * trange))) { # or time steps too large? ## in interpolation mode: automatic adjustment of step size arguments ## to ensure the required minimum of knots hini <- hmax <- 1.0/(nknots + 2.5) * trange if (hmin < hini) hmin <- hini cat("\nNote: Method ", method$ID, " needs intermediate steps for interpolation\n") cat("hmax decreased to", hmax, "\n") } } ## Model as shared object (DLL)? Ynames <- attr(y, "names") Initfunc <- NULL Eventfunc <- NULL events <- checkevents(events, times, Ynames, dllname) if (! is.null(events$newTimes)) times <- events$newTimes ## dummy forcings flist <-list(fmat = 0, tmat = 0, imat = 0, ModelForc = NULL) Nstates <- length(y) # assume length of states is correct ## function specified in a DLL or inline compiled if (is.character(func) | inherits(func, "CFunc")) { DLL <- checkDLL(func, NULL, dllname, initfunc, verbose, nout, outnames) Initfunc <- DLL$ModelInit Func <- DLL$Func Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot Eventfunc <- events$func if (! is.null(forcings)) flist <- checkforcings(forcings, times, dllname, initforc, verbose, fcontrol) if (is.null(ipar)) ipar <- 0 if (is.null(rpar)) rpar <- 0 ## preparation for events in R if function is a DLL (added by KS) if (is.function(Eventfunc)) rho <- environment(Eventfunc) else rho <- NULL } else { ## parameter initialisation not needed if function is not a DLL initpar <- NULL rho <- environment(func) ## func is overruled, either including ynames, or not ## This allows to pass the "..." arguments and the parameters if(ynames) { Func <- function(time, state, parms){ attr(state, "names") <- Ynames func(time, state, parms, ...)} if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time, state) { attr(state, "names") <- Ynames events$func(time, state, parms, ...) } } else { # no ynames... Func <- function(time, state, parms) func(time, state, parms, ...) if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time, state) events$func(time, state, parms, ...) } ## Call func once to figure out whether and how many "global" ## results it wants to return and some other safety checks FF <- checkFuncEuler(Func, times, y, parms, rho, Nstates) Nglobal <- FF$Nglobal Nmtot <- FF$Nmtot if (! is.null(events$Type)) if (events$Type == 2) checkEventFunc(Eventfunc, times, y, rho) } ## handle length of atol and rtol if (Nstates %% length(atol)) warning("length of atol does not match number of states") if (Nstates %% length(rtol)) warning("length of rtol does not match number of states") atol <- rep(atol, length.out = Nstates) rtol <- rep(rtol, length.out = Nstates) ## Number of steps until the solver gives up # nsteps <- min(.Machine$integer.max -1, maxsteps * length(times)) ## total number of time steps is set to ## average number per time step * number of time steps ## but not less than required for the largest time step with given hini nsteps <- min(.Machine$integer.max - 1, max(maxsteps * length(times), # max. total number of steps max(diff(times))/hini + 1) # but not less than required ) vrb <- FALSE # TRUE forces some internal debugging output of the C code ## Implicit methods on.exit(.C("unlock_solver")) implicit <- method$implicit if (is.null(implicit)) implicit <- 0 if (implicit) { if (is.null(hini)) hini <- 0 out <- .Call("call_rkImplicit", as.double(y), as.double(times), Func, Initfunc, parms, Eventfunc, events, as.integer(Nglobal), rho, as.double(tcrit), as.integer(vrb), as.double(hini), as.double(rpar), as.integer(ipar), method, as.integer(nsteps), flist) } else if (varstep) { # Methods with variable step size if (is.null(hini)) hini <- hmax out <- .Call("call_rkAuto", as.double(y), as.double(times), Func, Initfunc, parms, Eventfunc, events, as.integer(Nglobal), rho, as.double(atol), as.double(rtol), as.double(tcrit), as.integer(vrb), as.double(hmin), as.double(hmax), as.double(hini), as.double(rpar), as.integer(ipar), method, as.integer(nsteps), flist) } else { # Fixed step methods ## hini = 0 for fixed step methods means ## that steps in "times" are used as they are if (is.null(hini)) hini <- 0 out <- .Call("call_rkFixed", as.double(y), as.double(times), Func, Initfunc, parms, Eventfunc, events, as.integer(Nglobal), rho, as.double(tcrit), as.integer(vrb), as.double(hini), as.double(rpar), as.integer(ipar), method, as.integer(nsteps), flist) } ## output cleanup out <- saveOutrk(out, y, n, Nglobal, Nmtot, iin = c(1, 12:15), iout = c(1:3, 13, 18)) attr(out, "type") <- "rk" if (verbose) diagnostics(out) return(out) } deSolve/R/lsode.R0000644000176000001440000003025013572677236013357 0ustar ripleyusers### ============================================================================ ### lsode -- solves ordinary differential equation systems ### The user has to specify whether or not ### the problem is stiff and choose the appropriate method. ### It is very similar to vode, except for some implementation details. ### More specifically, in vode it is possible to choose whether or not a copy ### of the Jacobian is saved for reuse in the corrector iteration algorithm; ### In lsode, a copy is not kept; this requires less memory but may be slightly ### slower. ### ### as from deSolve 1.7, lsode finds the root of at least one of a set ### of constraint functions g(i) of the independent and dependent variables. ### It finds only those roots for which some g(i), as a function ### of t, changes sign in the interval of integration. ### It then returns the solution at the root, if that occurs ### sooner than the specified stop condition, and otherwise returns ### the solution according the specified stop condition. ### ============================================================================ lsode <- function(y, times, func, parms, rtol=1e-6, atol=1e-6, jacfunc=NULL, jactype = "fullint", mf = NULL, rootfunc=NULL, verbose=FALSE, nroot = 0, tcrit = NULL, hmin=0, hmax=NULL, hini=0, ynames=TRUE, maxord=NULL, bandup=NULL, banddown=NULL, maxsteps=5000, dllname=NULL,initfunc=dllname, initpar=parms, rpar=NULL, ipar=NULL, nout=0, outnames=NULL,forcings=NULL, initforc = NULL, fcontrol=NULL, events=NULL, lags = NULL, ...) { if (is.list(func)) { ### IF a list if (!is.null(jacfunc) & "jacfunc" %in% names(func)) stop("If 'func' is a list that contains jacfunc, argument 'jacfunc' should be NULL") if (!is.null(rootfunc) & "rootfunc" %in% names(func)) stop("If 'func' is a list that contains rootfunc, argument 'rootfunc' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(func)) stop("If 'func' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(func)) { if (! is.null(events)) events$func <- func$eventfunc else events <- list(func = func$eventfunc) } if (!is.null(func$jacfunc)) jacfunc <- func$jacfunc if (!is.null(func$rootfunc)) rootfunc <- func$rootfunc if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$dllname)) dllname <- func$dllname if (!is.null(func$initforc)) initforc <- func$initforc func <- func$func } ### check input hmax <- checkInput (y, times, func, rtol, atol, jacfunc, tcrit, hmin, hmax, hini, dllname) n <- length(y) if (!is.null(maxord)) if(maxord < 1) stop("`maxord' must be >1") ### Jacobian, method flag if (is.null(mf)){ if (jactype == "fullint" ) imp <- 22 # full, calculated internally else if (jactype == "fullusr" ) imp <- 21 # full, specified by user function else if (jactype == "bandusr" ) imp <- 24 # banded, specified by user function else if (jactype == "bandint" ) imp <- 25 # banded, calculated internally else stop("'jactype' must be one of 'fullint', 'fullusr', 'bandusr' or 'bandint' if 'mf' not specified") } else imp <- mf if (! imp %in% c(10:15, 20:25)) stop ("method flag 'mf' not allowed") # check other specifications depending on Jacobian miter <- imp%%10 if (miter %in% c(1,4) & is.null(jacfunc)) stop ("'jacfunc' NOT specified; either specify 'jacfunc' or change 'jactype' or 'mf'") meth <- abs(imp)%/%10 # basic linear multistep method if (is.null (maxord)) maxord <- if (meth==1) 12 else 5 if (meth==1 && maxord > 12) stop ("'maxord' too large: should be <= 12") if (meth==2 && maxord > 5 ) stop ("'maxord' too large: should be <= 5") if (miter %in% c(4,5) && is.null(bandup)) stop("'bandup' must be specified if banded Jacobian") if (miter %in% c(4,5) && is.null(banddown)) stop("'banddown' must be specified if banded Jacobian") if (is.null(banddown)) banddown <-1 if (is.null(bandup )) bandup <-1 ### model and Jacobian function JacFunc <- NULL Ynames <- attr(y,"names") RootFunc <- NULL flist <- list(fmat=0,tmat=0,imat=0,ModelForc=NULL) ModelInit <- NULL Eventfunc <- NULL events <- checkevents(events, times, Ynames, dllname,TRUE) if (! is.null(events$newTimes)) times <- events$newTimes ## if (miter == 4) Jacobian should have banddown empty rows if (miter == 4 && banddown>0) erow<-matrix(data=0, ncol=n, nrow=banddown) else erow<-NULL if (is.character(func) | inherits(func, "CFunc")) { # function specified in a DLL or inline compiled DLL <- checkDLL(func,jacfunc,dllname, initfunc,verbose,nout, outnames) ## Is there a root function? if (!is.null(rootfunc)) { if (!is.character(rootfunc) & !inherits(rootfunc, "CFunc")) stop("If 'func' is dynloaded, so must 'rootfunc' be") rootfuncname <- rootfunc if (inherits(rootfunc, "CFunc")) RootFunc <- body(rootfunc)[[2]] else if (is.loaded(rootfuncname, PACKAGE = dllname)) { RootFunc <- getNativeSymbolInfo(rootfuncname, PACKAGE = dllname)$address } else stop(paste("root function not loaded in DLL",rootfunc)) if (nroot == 0) stop("if 'rootfunc' is specified in a DLL, then 'nroot' should be > 0") } ModelInit <- DLL$ModelInit Func <- DLL$Func JacFunc <- DLL$JacFunc Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,verbose,fcontrol) if (is.null(ipar)) ipar<-0 if (is.null(rpar)) rpar<-0 Eventfunc <- events$func if (is.function(Eventfunc)) rho <- environment(Eventfunc) else rho <- NULL } else { if (is.null(initfunc)) initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) # func and jac are overruled, either including ynames, or not # This allows to pass the "..." arguments and the parameters if (ynames) { Func <- function(time,state) { attr(state,"names") <- Ynames unlist(func (time,state,parms,...)) } Func2 <- function(time,state) { attr(state,"names") <- Ynames func (time,state,parms,...) } JacFunc <- function(time,state) { attr(state,"names") <- Ynames rbind(jacfunc(time,state,parms,...),erow) } RootFunc <- function(time,state) { attr(state,"names") <- Ynames rootfunc(time,state,parms,...) } if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) { attr(state,"names") <- Ynames events$func(time,state,parms,...) } } else { # no ynames... Func <- function(time,state) unlist(func (time,state,parms,...)) Func2 <- function(time,state) func (time,state,parms,...) JacFunc <- function(time,state) rbind(jacfunc(time,state,parms,...),erow) RootFunc <- function(time,state) rootfunc(time,state,parms,...) if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) events$func(time,state,parms,...) } ## Check function and return the number of output variables +name FF <- checkFunc(Func2,times,y,rho) Nglobal<-FF$Nglobal Nmtot <- FF$Nmtot ## Check event function if (! is.null(events$Type)) if (events$Type == 2) checkEventFunc(Eventfunc,times,y,rho) ## and for rootfunc if (! is.null(rootfunc)) { tmp2 <- eval(rootfunc(times[1],y,parms,...), rho) if (!is.vector(tmp2)) stop("root function 'rootfunc' must return a vector\n") nroot <- length(tmp2) } else nroot = 0 if (miter %in% c(1,4)) { tmp <- eval(JacFunc(times[1], y), rho) if (!is.matrix(tmp)) stop("Jacobian function 'jacfunc' must return a matrix\n") dd <- dim(tmp) if ((miter == 4 && any(dd != c(bandup+banddown+banddown+1,n))) || (miter == 1 && any(dd != c(n,n)))) # thpe add 'any' (2 times) stop("Jacobian dimension not ok") } } ### work arrays iwork, rwork # length of rwork and iwork lrw <- 20+n*(maxord+1)+3*n +3*nroot if(miter %in% c(1,2) ) lrw <- lrw + 2*n*n+2 if(miter ==3) lrw <- lrw + n+2 if(miter %in% c(4,5) ) lrw <- lrw + (2*banddown+ bandup+1)*n+2 liw <- if (miter %in% c(0,3)) 20 else 20+n # only first 20 elements passed; other will be allocated in C-code iwork <- vector("integer",20) rwork <- vector("double",20) rwork[] <- 0. iwork[] <- 0 iwork[1] <- banddown iwork[2] <- bandup iwork[5] <- maxord iwork[6] <- maxsteps if(!is.null(tcrit)) rwork[1] <- tcrit rwork[5] <- hini rwork[6] <- hmax rwork[7] <- hmin ### the task to be performed. itask <- if (! is.null(times)) { if (is.null (tcrit)) 1 else 4 } else { # times specified if (is.null (tcrit)) 2 else 5 # only one step } if(is.null(times)) times<-c(0,1e8) ### print to screen... if (verbose) { printtask(itask,func,jacfunc) printM("\n--------------------") printM("Integration method") printM("--------------------") df <- c("method flag, =", "meth =", "miter =") vals <- c(imp, meth, miter) txt <- "; (note: mf = (10 * meth + miter))" if (meth==1) txt <- c(txt, "; the basic linear multistep method: the implicit Adams method") else if (meth==2) txt <- c(txt, "; the basic linear multistep method: based on backward differentiation formulas") if (miter==0) txt <- c(txt, "; functional iteration (no Jacobian matrix is involved") else if (miter==1) txt <- c(txt, "; chord iteration with a user-supplied full (NEQ by NEQ) Jacobian") else if (miter==2) txt <- c(txt, "; chord iteration with an internally generated full Jacobian, (NEQ extra calls to F per df/dy value)") else if (miter==3) txt <- c(txt, "; chord iteration with an internally generated diagonal Jacobian (1 extra call to F per df/dy evaluation)") else if (miter==4) txt <- c(txt, "; chord iteration with a user-supplied banded Jacobian") else if (miter==5) txt <- c(txt, "; chord iteration with an internally generated banded Jacobian (using ML+MU+1 extra calls to F per df/dy evaluation)") printmessage(df, vals, txt) } ### calling solver storage.mode(y) <- storage.mode(times) <- "double" IN <-2 if (!is.null(rootfunc)) IN <- 6 lags <- checklags(lags, dllname) ## end time lags... on.exit(.C("unlock_solver")) out <- .Call("call_lsoda",y,times,Func,initpar, rtol, atol, rho, tcrit, JacFunc, ModelInit, Eventfunc, as.integer(verbose), as.integer(itask), as.double(rwork), as.integer(iwork), as.integer(imp),as.integer(Nglobal), as.integer(lrw),as.integer(liw),as.integer(IN), RootFunc, as.integer(nroot), as.double (rpar), as.integer(ipar), 0L, flist, events, lags, PACKAGE="deSolve") ### saving results if (nroot>0) iroot <- attr(out, "iroot") out <- saveOut(out, y, n, Nglobal, Nmtot, func, Func2, iin=c(1,12:19), iout=c(1:3,14,5:9)) if (nroot>0) attr(out, "iroot") <- iroot attr(out, "type") <- "lsode" if (verbose) diagnostics(out) return(out) } deSolve/R/dede.R0000644000176000001440000000426213136461011013130 0ustar ripleyusers### ============================================================================ ### ### timelags and delay differential equations ### ### ============================================================================ ## ============================================================================= ## lagged values and derivates are obtained in the R-code via functions ## lagvalue and lagderiv ## ============================================================================= lagvalue <- function (t, nr=NULL) { if (is.null(nr)) nr <- 0 out <- .Call("getLagValue", t = t, PACKAGE = "deSolve", as.integer(nr)) return(out) } lagderiv <- function (t, nr=NULL) { if (is.null(nr)) nr <- 0 out <- .Call("getLagDeriv", t = t, PACKAGE = "deSolve", as.integer(nr)) return(out) } ### ============================================================================ ### solving Delay Differential Equations ### ============================================================================ dede <- function(y, times, func=NULL, parms, method = c( "lsoda", "lsode", "lsodes", "lsodar", "vode", "daspk", "bdf", "adams", "impAdams", "radau"), control=NULL, ...) { if (is.null(control)) control <- list(mxhist = 1e4) if (is.null(method)) method <- "lsoda" else if (is.function(method)) res <- method(y, times, func, parms, lags = control, ...) else if (is.complex(y)) stop ("cannot run dede with complex y") else res <- switch(match.arg(method), lsoda = lsoda(y, times, func, parms, lags = control, ...), vode = vode(y, times, func, parms, lags = control, ...), lsode = lsode(y, times, func, parms, lags = control, ...), lsodes = lsodes(y, times, func, parms, lags = control, ...), lsodar = lsodar(y, times, func, parms, lags = control, ...), daspk = daspk(y, times, func, parms, lags = control, ...), bdf = lsode(y, times, func, parms, mf = 22, lags = control, ...), adams = lsode(y, times, func, parms, mf = 10, lags = control, ...), radau = radau(y, times, func, parms, lags = control, ...), impAdams = lsode(y, times, func, parms, mf = 12, lags = control, ...) ) return(res) } deSolve/R/daspk.R0000644000176000001440000005344713572677236013370 0ustar ripleyusers ### ============================================================================ ### daspk -- solves differential algebraic and ordinary differential equation ### systems defined in res (DAE) or func (ODE) ### and outputs values for the times in `times' ### on input, y and dy contains the initial values of the state ### variables and rates of changes for times[1] ### parms is a vector of parameters for func. They should not ### change during the integration. ### ============================================================================ daspk <- function(y, times, func=NULL, parms, nind = c(length(y), 0, 0), dy = NULL, res = NULL, nalg=0, rtol=1e-6, atol=1e-6, jacfunc=NULL, jacres=NULL, jactype = "fullint", mass = NULL, estini = NULL, verbose=FALSE, tcrit = NULL, hmin=0, hmax=NULL, hini=0, ynames=TRUE, maxord =5, bandup=NULL, banddown=NULL, maxsteps=5000, dllname=NULL, initfunc=dllname, initpar=parms, rpar=NULL, ipar=NULL, nout=0, outnames=NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, events = NULL, lags = NULL, ...) { ### check input if (is.null(res) && is.null(func)) stop("either `func' or 'res' must be specified") if (!is.null(res) && !is.null(func)) stop("either `func' OR 'res' must be specified, not both") if (is.list(func)) { # a list of compiled codes if (!is.null(jacfunc) & "jacfunc" %in% names(func)) stop("If 'func' is a list that contains jacfunc, argument 'jacfunc' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(func)) stop("If 'func' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(func)) { if (! is.null(events)) events$func <- func$eventfunc else events <- list(func = func$eventfunc) } if (!is.null(func$jacfunc)) jacfunc <- func$jacfunc if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$initforc)) initforc <- func$initforc if (!is.null(func$dllname)) dllname <- func$dllname func <- func$func } if (is.list(res)) { # if (!is.null(jacres) & "jacres" %in% names(res)) stop("If 'res' is a list that contains jacres, argument 'jacres' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(res)) stop("If 'res' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(res)) stop("If 'res' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(res)) stop("If 'res' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(res)) stop("If 'res' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(res)) { if (! is.null(events)) events$func <- res$eventfunc else events <- list(func = res$eventfunc) } if (!is.null(res$jacres)) jacres <- res$jacres if (!is.null(res$initfunc)) initfunc <- res$initfunc if (!is.null(res$initforc)) initforc <- res$initforc if (!is.null(res$dllname)) dllname <- res$dllname res <- res$res } if (!is.numeric(y)) stop("`y' must be numeric") n <- length(y) if (! is.null(times)&&!is.numeric(times)) stop("`times' must be NULL or numeric") if (!is.null(jacres) && !is.null(jacfunc)) stop("either `jacfunc' OR 'jacres' must be specified, not both") if (!is.null(func) && !is.function(func) && !is.character(func) && ! inherits(func, "CFunc")) stop("`func' must be a function, a character vector, of class 'CFunc' or NULL") if (!is.null(res) && !is.function(res) && !is.character(res) && ! inherits(res, "CFunc")) stop("`res' must be NULL, a function or character vector or of class 'CFunc'") if (is.character(res) && (is.null(dllname) || !is.character(dllname))) stop("You need to specify the name of the dll or shared library where res can be found (without extension)") if (!is.numeric(rtol)) stop("`rtol' must be numeric") if (!is.numeric(atol)) stop("`atol' must be numeric") if (!is.null(tcrit) & !is.numeric(tcrit)) stop("`tcrit' must be numeric") if (!is.null(jacfunc) && !(is.function(jacfunc) )) stop("`jacfunc' must be a function or NULL") if (!is.null(jacres) && !(is.function(jacres) || is.character(jacres))) stop("`jacres' must be a function or character vector or of class 'CFunc'") if (length(atol) > 1 && length(atol) != n) stop("`atol' must either be a scalar, or as long as `y'") if (length(rtol) > 1 && length(rtol) != n) stop("`rtol' must either be a scalar, or as long as `y'") if (!is.numeric(hmin)) stop("`hmin' must be numeric") if (hmin < 0) stop("`hmin' must be a non-negative value") if (is.null(hmax)) hmax <- ifelse (is.null(times), 0, max(abs(diff(times)))) if (!is.numeric(hmax)) stop("`hmax' must be numeric") if (hmax < 0) stop("`hmax' must be a non-negative value") if (hini < 0) stop("`hini' must be a non-negative value") if (!is.numeric(maxord)) stop("`maxord' must be numeric") if(maxord < 1 || maxord > 5) stop("`maxord' must be >1 and <=5") if (!is.null(func) && !(is.null(res) )) stop("either `func' OR 'res' must be specified, not both") if (!is.null(mass) && !(is.null(res) )) stop("cannot combine `res' with 'mass' - use 'func' instead, or set 'mass' = NULL") ## max number of iterations ~ maxstep; a multiple of 500 maxIt <- max(1,(maxsteps+499)%/%500) ### Jacobian, method flag if (jactype == "fullint" ) imp <- 22 # full, calculated internally else if (jactype == "fullusr" ) imp <- 21 # full, specified by user function else if (jactype == "bandusr" ) imp <- 24 # banded, specified by user function else if (jactype == "bandint" ) imp <- 25 # banded, calculated internally else stop("'jactype' must be one of 'fullint', 'fullusr', 'bandusr' or 'bandint'") if (imp %in% c(24,25) && is.null(bandup)) stop("'bandup' must be specified if banded Jacobian") if (imp %in% c(24,25) && is.null(banddown)) stop("'banddown' must be specified if banded Jacobian") # if (miter == 4) Jacobian should have banddown empty rows-vode+daspk only! if (imp == 24) erow<-matrix(data=0,ncol=n,nrow=banddown) else erow<-NULL if (is.null(banddown)) banddown <-1 if (is.null(bandup )) bandup <-1 if (is.null(dy)) dy <- rep(0,n) if (!is.numeric(dy)) stop("`dy' must be numeric") ### model and Jacobian function Ynames <- attr(y,"names") dYnames <- attr(dy,"names") Res <- NULL JacRes <- NULL PsolFunc <- NULL funtype <- 1 ModelInit <- NULL flist<-list(fmat=0,tmat=0,imat=0,ModelForc=NULL) Eventfunc <- NULL events <- checkevents(events, times, Ynames, dllname) if (! is.null(events$newTimes)) times <- events$newTimes if (!is.null(dllname)) # Karline.... to avoid wrong address to initfunc ... added 24/7/2014 if (sum(duplicated (c(func, initfunc, jacfunc, res, jacres))) > 0) stop("func, initfunc, jacfunc, res, jacres cannot share the same name") if (!is.null(dllname) | inherits(func, "CFunc") | inherits(res, "CFunc")) { if (inherits(initfunc, "CFunc")) ModelInit <- body(initfunc)[[2]] else if (is.character(initfunc)) # to allow absence of initfunc if (is.loaded(initfunc, PACKAGE = dllname, type = "") || is.loaded(initfunc, PACKAGE = dllname, type = "Fortran")) { ModelInit <- getNativeSymbolInfo(initfunc, PACKAGE = dllname)$address } else if (initfunc != dllname) stop(paste("cannot integrate: initfunc not loaded ",initfunc)) if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,verbose,fcontrol) # Easier to deal with NA in C-code if (is.null(initfunc)) ModelInit <- NA } psolfunc <- NULL # not yet supported ## If res or func is a character vector, make sure it describes ## a function in a loaded dll if (is.character(res) || is.character(func) || inherits(res, "CFunc") || inherits(func, "CFunc")) { if (is.character(res)){ resname <- res if (is.loaded(resname, PACKAGE = dllname)) { Res <- getNativeSymbolInfo(resname, PACKAGE = dllname)$address } else stop(paste("cannot integrate: res function not loaded",resname)) } else if (inherits(res, "CFunc")) { Res <- body(res)[[2]] } else if (is.character(func)) { funtype <- 2 resname <- func if (is.loaded(resname, PACKAGE = dllname)) { Res <- getNativeSymbolInfo(resname, PACKAGE = dllname)$address } else stop(paste("cannot integrate: derivs function not loaded",resname)) if (!is.null(mass)) funtype <- 3 } else if (inherits(func, "CFunc")) { funtype <- 2 Res <- body(func)[[2]] if (!is.null(mass)) funtype <- 3 } # if (is.null(kryltype)) # { if (!is.null(jacres) ) { if (!is.character(jacres) & !inherits(jacres, "CFunc" )) stop("If 'res' is dynloaded, so must 'jacres' be") jacname <- jacres if (inherits(jacres, "CFunc")) JacRes <- body(jacres)[[2]] else if (is.loaded(jacname, PACKAGE = dllname)) { JacRes <- getNativeSymbolInfo(jacname, PACKAGE = dllname)$address } else stop(paste("cannot integrate: Jacobian function jacres not loaded ",jacres)) } if (!is.null(psolfunc)) { if (!is.character(psolfunc)& !inherits(psolfunc, "CFunc" )) stop("If 'res' is dynloaded, so must 'psolfunc' be") if (inherits(psolfunc, "CFunc")) PsolFunc <- body(psolfunc)[[2]] if (is.loaded(psolfunc, PACKAGE = dllname)) { PsolFunc <- getNativeSymbolInfo(psolfunc, PACKAGE = dllname)$address } else stop(paste("cannot integrate: psolfunc not loaded ",psolfunc)) } # } else if (kryltype =="banded") ### NOT YET IMPLEMENTED # { # lenpd <- (2*banddown + bandup +1) * n # mband <- banddown + bandup +1 # msave <- (n/mband) + 1 # lwp <- lenpd + 2 * msave # lip <- n # if(is.loaded("dbanja",PACKAGE="deSolve")) # JacRes <- getNativeSymbolInfo("dbanja",PACKAGE="deSolve")$address # if(is.loaded("dbanps",PACKAGE="deSolve")) # PsolFunc <- getNativeSymbolInfo("dbanps",PACKAGE="deSolve")$address # ipar <- c(ipar,banddown,bandup) # } else stop(paste("cannot integrate: kryltype not known ",kryltype)) ## If we go this route, the number of "global" results is in nout ## and output variable names are in outnames Nglobal <- nout if (is.null(outnames)) { Nmtot <- NULL} else if (length(outnames) == nout) { Nmtot <- outnames} else if (length(outnames) > nout) Nmtot <- outnames[1:nout] else Nmtot <- c(outnames,(length(outnames)+1):nout) if (is.null(ipar)) ipar<-0 if (is.null(rpar)) rpar<-0 Eventfunc <- events$func if (is.function(Eventfunc)) rho <- environment(Eventfunc) else rho <- NULL } else { if (is.null(initfunc)) initpar <- NULL # parameter initialisation not needed if function is not a DLL ## func or res and jac are overruled, either including ynames, or not ## This allows to pass the "..." arguments and the parameters if (is.null(res) && is.null(mass)) { # res is NOT specified, func is rho <- environment(func) Res <- function(time,y,dy) { if (ynames) attr(y,"names") <- Ynames FF <-func (time,y,parms,...) c(dy-unlist(FF[1]), unlist(FF[-1])) } Res2 <- function(time,y,dy) { if (ynames) attr(y,"names") <- Ynames func (time,y,parms,...) } } else if (is.null(res)) { # func with mass rho <- environment(func) Res <- function(time,y,dy) { if (ynames) attr(y,"names") <- Ynames FF <-func (time,y,parms,...) c(mass %*% dy-unlist(FF[1]), unlist(FF[-1])) } Res2 <- function(time,y,dy) { # just for testing if (ynames) attr(y,"names") <- Ynames func (time,y,parms,...) } } else { # res is specified rho <- environment(res) Res <- function(time,y,dy){ if (ynames) { attr(y,"names") <- Ynames attr(dy,"names") <- dYnames } unlist(res (time,y,dy,parms,...)) } Res2 <- function(time,y,dy) { if(ynames) { attr(y,"names") <- Ynames attr(dy,"names") <- dYnames } res (time,y,dy,parms,...) } } ## the Jacobian if (! is.null(jacfunc)) { # Jacobian associated with func tmp <- eval(jacfunc(times[1], y, parms, ...), rho) if (! is.matrix(tmp)) stop("jacfunc must return a matrix\n") if (is.null(mass)) JacRes <- function(Rin,y,dy) { if(ynames) { attr(y,"names") <- Ynames attr(dy,"names") <- dYnames } JF <- -1* jacfunc(Rin[1],y,parms,...) if (imp %in% c(24,25)) { JF[bandup+1,]<-JF[bandup+1,]+Rin[2] JF <- rbind(erow,JF ) } else JF <-JF + diag(ncol=n,nrow=n,x=Rin[2]) return(JF) } else { if (imp %in% c(24,25)) stop("cannot combine banded jacobian with mass") JacRes <- function(Rin,y,dy) { if(ynames) { attr(y,"names") <- Ynames attr(dy,"names") <- dYnames } JF <- -1* jacfunc(Rin[1],y,parms,...) JF <- JF + Rin[2]*mass return(JF) } } } else if (! is.null(jacres)) { # Jacobian given tmp <- eval(jacres(times[1], y, dy, parms, 1, ...), rho) if (! is.matrix(tmp)) stop("jacres must return a matrix\n") dd <- dim(tmp) if ((imp ==24 && any(dd != c(bandup+banddown+1,n))) || (imp ==21 && any(dd != c(n,n)))) # thpe add 'any' (two times) stop("Jacobian dimension not ok") JacRes <- function(Rin,y,dy) { if (ynames) { attr(y,"names") <- Ynames attr(dy,"names") <- dYnames } rbind(erow,jacres(Rin[1],y,dy,parms,Rin[2],...)) } } else JacRes <- NULL if (! is.null(events$Type)) { if (events$Type == 2) Eventfunc <- function(time,state) { if (ynames) { attr(state,"names") <- Ynames attr(dy,"names") <- dYnames } events$func(time,state,parms,...) } if (events$Type == 2) checkEventFunc(Eventfunc,times,y,rho) } ## Call res once to figure out whether and how many "global" ## results it wants to return and some other safety checks tmp <- eval(Res2(times[1], y, dy), rho) if (!is.list(tmp)) stop("Model function must return a list\n") if (length(tmp[[1]]) != length(y)) stop(paste("The number of derivatives returned by func() (", length(tmp[[1]]), ") must equal the length of the initial conditions vector (", length(y), ")", sep = "")) Nglobal <- if (length(tmp) > 1) length(unlist(tmp[-1])) else 0 ## check for NULL? stop("Problem interpreting model output - check for NULL values") Nmtot <- attr(unlist(tmp[-1]),"names") } # is.character(res) ### work arrays INFO, iwork, rwork ## the INFO vector info <- vector("integer", 25) # Changed to account for the index of variables info[] <- 0 info[20] <- funtype # 1 for a res in DLL, 2 for func in DLL if (length(atol)==n) { if (length(rtol) != n) rtol <- rep(rtol,len=n) } else if (length(rtol)==n) atol <- rep(atol,len=n) info[2] <- length(atol)==n if (is.null(times)) { info[3]<-1 times<-c(0,1e8) } # if (krylov == TRUE) # NOT YET IMPLEMENTED # {if (is.null(kryltype) && is.null(psolfunc)) # stop ("daspk: cannot perform integration: *psolfunc* NOT specified and krylov method chosen..") # if (is.null(kryltype) && ! is.character (psolfunc)) # stop ("daspk: krylov method in R-functions not yet implemented") # if (is.null(kryltype) && is.null(lwp)) stop("daspk: krylov method chosen, but lwp not defined") # if (is.null(kryltype) && is.null(lip)) stop("daspk: krylov method chosen, but lip not defined") # info[12] <- 1 # if (is.null(krylpar )) { # krylpar <- c(min(5,n),min(5,n),5,0.05) # } else { # if (!is.numeric(krylpar)) stop("daspk: krylpar is not numeric") # if (length(krylpar)!=4) stop("daspk: krylpar should contain 4 elements") # if (krylpar[1] <1 || krylpar[1]>n) stop("daspk: krylpar[1] MAXL not valid") # if (krylpar[2] <1 || krylpar[2]>krylpar[1]) stop("daspk: krylpar[2] KMP not valid") # if (krylpar[3] <0 ) stop("daspk: krylpar[3] NRMAX not valid") # if (krylpar[4] <0 || krylpar[4]>1) stop("daspk: krylpar[4] EPLI not valid") # info[13] =1 # } # if (! is.null(JacRes)) info[15] <- 1 # } # info[14], [16], [17], [18] not implemented if (imp %in% c(22,25)) info[5] <- 0 # internal generation Jacobian if (imp %in% c(21,24)) info[5] <- 1 # user-defined generation Jacobian if (imp %in% c(22,21)) info[6] <- 0 # full Jacobian if (imp %in% c(25,24)) info[6] <- 1 # sparse Jacobian info[7] <- hmax != Inf info[8] <- hini != 0 nrowpd <- ifelse(info[6]==0, n, 2*banddown+bandup+1) if (info[5]==1 && is.null(jacfunc) && is.null(jacres)) stop ("daspk: cannot perform integration: *jacfunc* or *jacres* NOT specified; either specify *jacfunc* or *jacres* or change *jactype*") info[9] <- maxord!=5 if (! is.null (estini)) info[11] <- estini # daspk will estimate dy and algebraic equ. if (info[11] > 2 || info[11]< 0 ) stop("daspk: illegal value for estini") # length of rwork and iwork # if (info[12]==0) { lrw <- 50+max(maxord+4,7)*n if (info[6]==0) {lrw <- lrw+ n*n} else { if (info[5]==0) lrw <- lrw+ (2*banddown+bandup+1)*n + 2*(n/(bandup+banddown+1)+1) else lrw <- lrw+ (2*banddown+bandup+1)*n } liw <- 40+n ### index if (length(nind) != 3) stop("length of `nind' must be = 3") if (sum(nind) != n) stop("sum of of `nind' must equal n, the number of equations") info[21:23] <- nind # } else { # maxl <- krylpar[1] # kmp <- krylpar[2] # lrw <- 50+(maxord+5)*n+max(maxl+3+min(1,maxl-kmp))*n + (maxl+3)*maxl+1+lwp # liw <- 40+lip # } if (info[10] %in% c(1,3)) liw <- liw+n if (info[11] ==1) liw <- liw+n if (info[16] ==1) liw <- liw+n if (info[16] ==1) lrw <- lrw+n iwork <- vector("integer",liw) rwork <- vector("double",lrw) if(! is.null(tcrit)) {info[4]<-1;rwork[1] <- tcrit} if(info[6] == 1) {iwork[1]<-banddown; iwork[2]<-bandup} if(info[7] == 1) rwork[2] <- hmax if(info[8] == 1) rwork[3] <- hini if(info[9] == 1) iwork[3] <- maxord # info[10] not implemented if (info[11]>0) { lid <- ifelse(info[10] %in% c(0,2), 40, 40+n) iwork[lid+(1:n) ]<- - 1 iwork[lid+(1:(n-nalg))]<- 1 } # if (info[12]==1) # {iwork[27]<-lwp # iwork[28]<-lip} # if (info[13]==1) # {iwork[24:26]<- krylov[1:3] # rwork[10]<-krylov[4]} # print to screen... # if (verbose) # { # if (info[12] == 0) # {print("uses standard direct method") # }else print("uses Krylov iterative method") # } lags <- checklags(lags,dllname) if (lags$islag == 1) { info[3] = 1 # one step and return maxIt <- maxsteps # maxsteps per iteration... } ### calling solver storage.mode(y) <- storage.mode(dy) <- storage.mode(times) <- "double" storage.mode(rtol) <- storage.mode(atol) <- "double" on.exit(.C("unlock_solver")) out <- .Call("call_daspk", y, dy, times, Res, initpar, rtol, atol,rho, tcrit, JacRes, ModelInit, PsolFunc, as.integer(verbose),as.integer(info), as.integer(iwork),as.double(rwork), as.integer(Nglobal),as.integer(maxIt), as.integer(bandup),as.integer(banddown),as.integer(nrowpd), as.double (rpar), as.integer(ipar), flist, lags, Eventfunc, events, as.double(mass), PACKAGE = "deSolve") ### saving results out [1,1] <- times[1] istate <- attr(out, "istate") istate <- setIstate(istate,iin=c(1,8:9,12:20), iout=c(1,6,5,2:4,13,12,19,9,8,11)) rstate <- attr(out, "rstate") ## ordinary output variables already estimated nm <- c("time", if (!is.null(attr(y, "names"))) names(y) else as.character(1:n)) if (Nglobal > 0) nm <- c(nm, if (!is.null(Nmtot)) Nmtot else as.character((n + 1):(n + Nglobal))) attr(out, "istate") <- istate attr(out, "rstate") <- rstate attr(out, "type") <- "daspk" class(out) <- c("deSolve","matrix") # a differential equation dimnames(out) <- list(nm, NULL) if (verbose) diagnostics(out) t(out) } deSolve/MD50000644000176000001440000002357613603425023012226 0ustar ripleyusers7e98da0103838e1271ce3c3b5e1a7b54 *DESCRIPTION 316262d3be55a7fcb10ac5ceebfd7658 *NAMESPACE 5709d46332e63c4f51709cbd5d0576e3 *NEWS 4df6c896706646b5793cc6357b15574a *R/Aquaphy.R 75b53acdcea2f0de92203a153b956f89 *R/DLLfunc.R 31be22a79645487f5441d15c21de881d *R/SCOC.R 7463c8dee212ca070fbb4ea2a1eeaaec *R/Utilities.R 0b7bc04c247655f2319113eb0670bbf1 *R/ccl4model.R 8b035cac2e32f57be01321f603ddc602 *R/checkevents.R 2c1a330582489191b8d093cfa227dd69 *R/cleanEventTimes.R 750edb1d9557021bd7053db2df86855b *R/daspk.R b2f54ca36a32a9fe245d2a736205f600 *R/dede.R 947bcfadb19abe4513e2ae3b04e74a44 *R/diagnostics.R 86747fed16ebaa46641c2d03f57f54ac *R/euler.R 2a7237f8c7f7004712923da261b65541 *R/forcings.R f0e99c46b41ef72899610e6fa5f5c4ca *R/functions.R 3ea7be2c0f49df21d0df6fff1f25d9b0 *R/iteration.R 7444ec6190b971b5902f5328485df95a *R/lsoda.R 8aa2ad9b2248d2a16a9705b03ad45b2c *R/lsodar.R 73ed62e0a8ae78ffe767335d5b9cada7 *R/lsode.R b38770dbdf5427f991aff49e5b4f5592 *R/lsodes.R 0ac90b23e1552b5f6dbc8626eea5eec1 *R/matplot.R 71e89984b344347dd0579d2c1c59803a *R/ode.R 6b16f3c6ea8b7944df6a389398e5443f *R/printmessage.R 44d7effe23da5a534c323b82967bcacf *R/radau.R 7dcbc50a2df227f4bf84fb894d4bbaf1 *R/rk.R 724214ae0536cc1a69304d0a9c38c365 *R/rk4.R d3bcd9e29d24a57f2db46c635351814d *R/rkMethod.R 00a93dc2aa00eb62b90e9db0182c8883 *R/vode.R 1fd4fa28ad703b00b7e788b3440d04c1 *R/zvode.R c0a191c6ca9886e02b9c05bbfcb028e5 *build/vignette.rds dabe93829ba05ad25c0d274189d13f56 *data/ccl4data.rda be157a942988018a45e577923b2b66e6 *demo/00Index c0c0293b16490375a893937ef11f398b *demo/CCL4model.R 5b936a490bc9ea9aebc3f80cb6ce1fa5 *demo/odedim.R 2750ed85b474836a29ebb6f41eeb5496 *inst/CITATION 442b7618dc28d5eb9d58ac06de00516a *inst/doc/compiledCode.R a7f37878e8888219d66d4f40a700279c *inst/doc/compiledCode.Rnw 151625504122d4cfdb6202b15da8d060 *inst/doc/compiledCode.pdf f3b9458fc662add393afdc8faccffe7c *inst/doc/deSolve.R 86ed9ab9c5415bb141eb2cc78b03db66 *inst/doc/deSolve.Rnw 397466175a70addb5630896ccb4a990f *inst/doc/deSolve.pdf 90cff72b5d4f433507d4a3194ac2b4c5 *inst/doc/dynload-dede/dedeUtils.c 32adc37ff9cfdae64133e2f0905ca68c *inst/doc/dynload-dede/dede_lv.R 0554dd66581cbd412e50455977167143 *inst/doc/dynload-dede/dede_lv.c 89bbf4e7bd58ec8521eca8525aed7050 *inst/doc/dynload-dede/dede_lv2.R f4e78a288c93aebcfc376833f39c800f *inst/doc/dynload-dede/dede_lv2.c affb61cc1870a00a1d0ddc56f766d78b *inst/doc/dynload-dede/dede_lv2F.f a0b51ca0d9b0fac4f7355bd042f3d429 *inst/doc/dynload-dede/dede_lvF.f d668bba347fcaa35b995880b0db64da3 *inst/doc/dynload-dede/dedesimple.R d092893bb9fe7ca3b808bec33ac43529 *inst/doc/dynload-dede/dedesimple.c 1e029ca10ea268a0b1ca1d4c48139dfe *inst/doc/dynload-dede/dedesimpleF.f aeb199875bb906ce80643d6acf778ff1 *inst/doc/dynload/Aquaphy.f b632619a9e6d2b730166eb52790c764a *inst/doc/dynload/AquaphyEvent.R d80a2a93e0f374238d7f45dc1bb69e6d *inst/doc/dynload/AquaphyForcing.R e4932f80fc03ab8cb99d033fb5587e2d *inst/doc/dynload/AquaphyForcing.f 426a4eca780fd364caac828ae81a6271 *inst/doc/dynload/CCL4model.f 9ffdf0d254e2caaf4376a5d01b3e35eb *inst/doc/dynload/ChemicalDAE.f 44cdb71dbf64ae9a354a5763cac53b3b *inst/doc/dynload/Forcing_lv.R a901f436c5cde25ac2f98748ae82551d *inst/doc/dynload/Forcing_lv.c 6156420e54af94bcf492794ed0231a29 *inst/doc/dynload/SCOC.f 0ec7c970e20e2ec5d915c8c065b64b8d *inst/doc/dynload/daspkdll.R a0e55bab3e7204f12aff54721da68c64 *inst/doc/dynload/daspkfor.f 10a5fda2ed498a58743c1886a13d61da *inst/doc/dynload/ex_Aquaphy.c 2d7ed3de13a976a1ebe75b226c73caa5 *inst/doc/dynload/ex_Aquaphy.f 586850d15e2be94fbe27eb7df0898ce8 *inst/doc/dynload/ex_CCL4model.c 2f532562e77cb2f88f36eedb9b82b5c4 *inst/doc/dynload/ex_CCL4model.f 71834ca5cfe3ee50638bf7164762e5aa *inst/doc/dynload/ex_SCOC.c 6156420e54af94bcf492794ed0231a29 *inst/doc/dynload/ex_SCOC.f dc0d6dc950a608126a445bc0a1988ba5 *inst/doc/dynload/intakes.RData 160b990493dd04c26f6b21e5e5f47d21 *inst/doc/dynload/lsodardll.R 038f0e37a271b702a268535f31c942c7 *inst/doc/dynload/lsodarfor.f 13a693adb572d5cb5ca2f51595bcb960 *inst/doc/dynload/odeband.R c29aa9f32b22e1a0879f05bff7a18c0a *inst/doc/dynload/odeband.f 6542f040003a093e51246e97e12f2190 *inst/doc/dynload/odec.c d9e3836229433daa8c0163fd3f3a18ea *inst/doc/dynload/odedll.R 250379b382326971010171cbfd9a92f8 *inst/doc/dynload/odefor.f bb4065405df9826a5919a7cbcb747f13 *inst/doc/dynload/odefor2.f 051973c89ab6f678e344cdbc3c5899c2 *inst/doc/dynload/radaudae.f 8e62923bc1506ec6fba0a25857fbbb99 *inst/doc/dynload/radaudaedll.R ae2afb02d57ea57ba6b8f42c5704f692 *inst/doc/dynload/satres.R eee7aca79ecb69f57ee392eebf4f0a38 *inst/doc/dynload/satres.f 4c102965c6d6a5355820c815683007f4 *inst/doc/dynload/satresC.c 82b67b1d71f66383bf1a02acdcc150e9 *inst/doc/dynload/zvodedll.R a81a79508e8cb535304b2b6c6d5fac77 *inst/doc/dynload/zvodedll.f 7718208c0fbdd96910c3a50c27f9cdd3 *inst/doc/examples/Arenstorf.R f0d26285a7e36f4ef674de9b66aa0d35 *inst/doc/examples/Daphnia_event.R 1e5f4cec90318c21a6db9efd822f5f5e *inst/doc/examples/Nand.R 6e933b690074cbe308a4905b5794fbd2 *inst/doc/examples/Pollution.R 92a131ab774a97d56c67bc5072c29260 *inst/doc/examples/Schelde_DSA.R b7c081a867ece141eb6d68fb1508b947 *inst/doc/examples/Schelde_FKA.R c80a3fa263db0324b3dc52209c4bf74a *inst/doc/examples/Schelde_FNA.R efd81b32bba7723155958e8574af3ff1 *inst/doc/examples/Schelde_OSA.R 6f1a3c93875c210cc5c2a7b672fab8b3 *inst/doc/examples/Schelde_pars.R d27eba5367c556dd9ea5c90cb10e30d0 *inst/doc/examples/ballode.R b77c6dc0186bc97451484713ed33a678 *inst/doc/examples/examples_paper.R fb0b7672fcb11c004b740aed5fd3781a *inst/doc/mymod.c 49500c40ef108d5529ed7c8755689b18 *inst/doc/mymod.f 423cbcdb18179550331254b13cdd5bd0 *inst/doc/source/ddaspkcomments.txt.gz dced93270fdf192134620a73a6bcf075 *inst/doc/source/opkdmain.f.gz 7bec5627ba9d5af8d93c9129f73e31c4 *inst/doc/source/opkdmaincomments.txt.gz 5d85b7d76ff0b9ecc7cc474cceda51c7 *inst/doc/source/sourcefiles.txt 279975bba4f882e38557aaf07f89036a *inst/doc/source/vodecomments.txt.gz 1f0b35342f6f2d9f7c4b567bb56f6644 *man/DLLfunc.Rd 625c20713467f4686365ee9fcb72221a *man/DLLres.Rd 45853fbddcafe6a39c7f9943dc1e652b *man/SCOC.Rd 42cf2317d8e450688ac73db803e6709e *man/aquaphy.Rd a079d71b38857de60b0b33c87b5ba5d3 *man/ccl4data.Rd 6040dc07121c92d3fa1bc86332b07d55 *man/ccl4model.Rd 6ea0ea45545acf07498f337fcdef75b3 *man/cleanEventTimes.Rd 2463ffe7896a04edb4639a867e00b83a *man/daspk.Rd 9f4d51956e88cadb78088e438eaa3ba7 *man/deSolve-internal.Rd 8ce79136ba6ece3750b02c2585407c0d *man/deSolve.Rd 7efa38b374dd3bc47661ad9e34aed899 *man/dede.Rd 96ce499ae3f2afa326764086c3cf4919 *man/diagnostics.Rd c9cbad59d0970aeb3fbdd0ee5b02d5d6 *man/diagnostics.deSolve.Rd c1a2635c37d832b339c67ffbff33f1ed *man/events.Rd e41906e4c2bcc40fcebab691945e5922 *man/forcings.Rd e775338c94905c15439b013493c899b6 *man/lsoda.Rd c13ff67d2897f29a0824af4774e1d6ee *man/lsodar.Rd 82bfa9ee34e0dbd063542a22b7d34a87 *man/lsode.Rd 8ac5d007d816f7acbf70b1cca65a33b9 *man/lsodes.Rd 8d4d38aeb64a534a58c7704c35b95574 *man/ode.1D.Rd c2ccea13dd2e55b4d27ab39b2ffe7343 *man/ode.2D.Rd b46540d7d6cb410f7697f99af40ae14f *man/ode.3D.Rd f863cf063f6f70a2d09063bfe7cb9d6b *man/ode.Rd 7810777a35173629cfd08b2c1b17a0aa *man/ode.band.Rd 2536c33ba48e035b3078c9b69a4f677c *man/plot.deSolve.Rd ea0ab68f69725505316965b6924865b9 *man/radau.Rd 22be16f0f36f7ba20bebc3826caefcf8 *man/rk.Rd 4be167bbf27a629c53e7b9b224672e5e *man/rk4.Rd c613fdac13889bfeb433678d2d529aa8 *man/rkMethod.Rd 6418431865799b3674dd0730affa8818 *man/timelags.Rd 66651449cbde8908e758e4aa061be702 *man/vode.Rd 88ecf456ed7f62f4d09e5afd5489d5a2 *man/zvode.Rd 5e046dd1f7cc192a6c3d5d1a47b2dbec *src/DLLutil.c 8290d2e9740414e315237f0d5d4024bb *src/Makevars 6e94483efda3b51ad773e5cc0502cfc7 *src/R_init_deSolve.c cf4b58246d69335dd7eb21173b338752 *src/brent.c c17cd63fb084095b6d9740d9c9e3db04 *src/call_daspk.c 4f1f107d001710fad9bf5d435b1dab4b *src/call_euler.c 6bf3f1b2a85624383e1cd27262702306 *src/call_iteration.c 9c186e2b95ac9b509bacd302011b97b0 *src/call_lsoda.c 2989d85afc6213b91dcc49a92649d2fa *src/call_radau.c 430804884cf13e2ff884f907aaec681e *src/call_rk4.c c234d4f8a8ed83a9e78cfbfb646ce9d0 *src/call_rkAuto.c d163f6788f89785e9c626035c43005dc *src/call_rkFixed.c c537d39ee2fd1deab5062aa9acf8328e *src/call_rkImplicit.c 0cb257a7af87c36ab4ce3177b5140768 *src/call_zvode.c aa27f87ba8e60746a8d2f0219479dc41 *src/daux.f f035a7d513f35deaafb690b97586c741 *src/ddaspk.f 67a1a5027bfe48de42fc67b93a7d35e9 *src/deSolve.h 617d987035b061e8b74b2d2aeae873ae *src/deSolve_utils.c 8dd1bab6bbe783797bb34b492be08942 *src/dintdy2.f d184e0c347d70040ea832e3420fbce70 *src/dlinpk.f 54dc7b4c506e38769b3e52a590e0ec4b *src/dlsoder.f 01aef38d310a1625a318a50160a7dbce *src/dsparsk.f d7898e4c512f38a4dffdcee1bb2e6992 *src/dvode.f fea673018039be0a99061d756ba9a7a5 *src/errmsg.f 10a5fda2ed498a58743c1886a13d61da *src/ex_Aquaphy.c 586850d15e2be94fbe27eb7df0898ce8 *src/ex_CCL4model.c ce974c6cfe3334a319ff9ff519d599dd *src/ex_ChemicalDAE.c 1815d64fc1a6e9032baeadcfc0d4da01 *src/ex_SCOC.c 5841fc95b46e14b4b8f6ef69f255d496 *src/externalptr.h 51b50c2ae9c3324738830f0e52246e5e *src/forcings.c 42cfb695406fb104233b284b6cda0c42 *src/lags.c aaa2710faa0ad4b7432281b544644377 *src/opkda1.f 46e3dbe75e4112e58ca660c77022d449 *src/opkdmain.f f6c3c5141eba327ae959e9044168045e *src/radau5.f 52a2b5511cc5bd47d5141a59c9747de0 *src/radau5a.f 476e682c316d6fe0e48026c342dbd5a8 *src/rk_auto.c ae76af78b7033fdddab7a46de04f827a *src/rk_fixed.c 3e2b2e9255308415aad542f82d654538 *src/rk_implicit.c d4fea0e3d3d1c70ccae18270ef6d73b0 *src/rk_util.c 06245a83dd68eb332301f756f9afd420 *src/rk_util.h a89e76d3229e6feb282b99dbe9fb390c *src/rprintf.c fa1db7b8006e5a4a0c397af62d5b80d0 *src/twoDmap.c 318dc80f3f172530a950453ceadafa30 *src/zvode.f d0f36e39e8f68d89df2a00cd0e0a144d *src/zvode.h 0b5c5eb86441a7b7a33c354493935d8d *vignettes/aphid.png 7c57b9128fc34e219eab6021eeda8a6b *vignettes/comp-event.pdf a7f37878e8888219d66d4f40a700279c *vignettes/compiledCode.Rnw 86ed9ab9c5415bb141eb2cc78b03db66 *vignettes/deSolve.Rnw bca3923230381ce0300918005f438b52 *vignettes/image1D.png 21b31a8ef56f0caba294e8feb3a72ebc *vignettes/integration.bib fb0b7672fcb11c004b740aed5fd3781a *vignettes/mymod.c 49500c40ef108d5529ed7c8755689b18 *vignettes/mymod.f deSolve/inst/0000755000176000001440000000000013503434211012654 5ustar ripleyusersdeSolve/inst/doc/0000755000176000001440000000000013576731645013446 5ustar ripleyusersdeSolve/inst/doc/examples/0000755000176000001440000000000013136461015015243 5ustar ripleyusersdeSolve/inst/doc/examples/Schelde_FKA.R0000644000176000001440000001551313136461015017423 0ustar ripleyusers################################################################################ # pH model of the Scheldt estuary # # Hofmann AF, Meysman FJR, Soetaert K, Middelburg J, 2008. # # A step-by-step procedure for pH model construction in aquatic systems # # Biogeosciences 5, 227-251 # # # # STEP 1 - FKA # # Full kinetic approach - pH model written as a set of stiff # # ordinary differential equations, solved with ODE solver vode # # Implementation: Andreas Hofmann, Karline Soetaert - NIOZ # ################################################################################ # load parameters, dissociation constants, initial conditions, # the model transport function and function TA_estimate, to estimate alkalinity # Do make sure that this file is in the working directory (or use setwd("")) source('Schelde_pars.R') ################################################################################ # MODEL EQUATIONS # ################################################################################ FKAmodel <- function (tt, state, parms, scenario="B1") { with (as.list(c(state, parms)), { #-------------------------- # PHYSICAL PROCESSES #-------------------------- # air-water exchange ECO2 <- KL * (CO2sat - CO2) EO2 <- KL * (O2sat - O2) ENH3 <- KL * (NH3sat - NH3) # Transport TO2 <- Transport(O2, O2_up, O2_down) TNO3 <- Transport(NO3, NO3_up, NO3_down) TH <- Transport(H, H_up, H_down) TCO2 <- Transport(CO2, CO2_up, CO2_down) THCO3 <- Transport(HCO3, HCO3_up, HCO3_down) TCO3 <- Transport(CO3, CO3_up, CO3_down) TNH3 <- Transport(NH3, NH3_up, NH3_down) TNH4 <- Transport(NH4, NH4_up, NH4_down) # Wastewater treatment plant in Brussels scenario if (scenario == "A" && tt > 365) { TOM <- Transport(OM, OM_up_A, OM_down) } else TOM <- Transport(OM, OM_up , OM_down) # Spills if (scenario == "B1" && (tt > 360 && tt < 370)) { AddNH4NO3 <- SpillNH4NO3 # NH4+NO3- - tanker addition } else AddNH4NO3 <- 0 if (scenario == "C" && (tt > 360 && tt < 370)) { AddNH3 <- SpillNH3 # NH3 - tanker input } else AddNH3 <- 0 #-------------------------- # BIOGEOCHEMICAL PROCESSES: #-------------------------- # Oxic mineralisation ROx <- rOM * OM * (O2/(O2 + ksO2)) ROxCarbon <- ROx * C_Nratio # Nitrification RNit <- rNitri * NH4 * (O2/(O2 + ksO2)) # "equilibrium reactions": k1 arbitrarily high RCO2 <- k1*CO2 - k1/K1CO2* H * HCO3 RHCO3 <- k1*HCO3 - k1/K2CO2* H * CO3 RNH4 <- k1*NH4 - k1/KNH4 * H * NH3 #-------------------------- # RATE OF CHANGE #-------------------------- dOM <- TOM - ROx dO2 <- TO2 + EO2 - ROxCarbon - 2*RNit dNO3 <- TNO3 + RNit + AddNH4NO3 dCO2 <- TCO2 + ECO2 + ROxCarbon - RCO2 dHCO3 <- THCO3 + RCO2 - RHCO3 dCO3 <- TCO3 + RHCO3 dNH3 <- TNH3 + ENH3 + ROx + RNH4 + AddNH3 dNH4 <- TNH4 - RNit - RNH4 + AddNH4NO3 dH <- TH + 2*RNit + RCO2 + RHCO3 + RNH4 #-------------------------- # Output variables: The pH, alkalinity and other summed quantities #-------------------------- pH <- -log10(H*1e-6) TA <- HCO3 + 2*CO3 + NH3 - H SumCO2 <- CO2 + HCO3 + CO3 SumNH4 <- NH4 + NH3 return(list(c(dOM, dO2, dNO3, dH, dNH4, dNH3, dCO2, dHCO3, dCO3), c(pH=pH, TA=TA, SumCO2=SumCO2, SumNH4=SumNH4))) }) } ################################################################################ # MODEL APPLICATIONS # ################################################################################ #--------------------- # Extra Boundary conditions #--------------------- # The speciation of DIC and sum(ammonium), calculated consistently with pH_up H_up <- 10^-pH_up * 1e6 # umol/kg solution H <- H_up NH3_up <- KNH4/(KNH4+H)*SumNH4_up NH4_up <- SumNH4_up - NH3_up CO2_up <- H*H/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_up HCO3_up <- H*K1CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_up CO3_up <- K1CO2*K2CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_up # calculated consistently with pH_down: H_down <- 10^-pH_down * 1e6 # umol/kg solution H <- H_down NH3_down <- KNH4/(KNH4+H)*SumNH4_down NH4_down <- SumNH4_down - NH3_down CO2_down <- H*H/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_down HCO3_down <- H*K1CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_down CO3_down <- K1CO2*K2CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_down #--------------------- # initial conditions #--------------------- H_ini <- 10^-pH_ini * 1e6 H <- H_ini NH3_ini <- KNH4/(KNH4+H)*SumNH4_ini NH4_ini <- SumNH4_ini - NH3_ini CO2_ini <- H*H/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_ini HCO3_ini <- H*K1CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_ini CO3_ini <- K1CO2*K2CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_ini state <- c(OM=OM_ini, O2=O2_ini, NO3=NO3_ini, H=H_ini, NH4=NH4_ini, NH3=NH3_ini, CO2=CO2_ini, HCO3=HCO3_ini, CO3=CO3_ini) #--------------------- # run model #--------------------- times <- c(0, 350:405) outA <- vode(state, times, FKAmodel, phPars, scenario = "A" , hmax = 1) outB <- vode(state, times, FKAmodel, phPars, scenario = "B1", hmax = 1) outC <- vode(state, times, FKAmodel, phPars, scenario = "C" , hmax = 1) #--------------------- # plot model output #--------------------- par(mfrow = c(3, 4), mar = c(1, 2, 2, 1), oma = c(3, 3, 3, 0)) Selection <- c("pH","TA","SumCO2","O2") plot(outA, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) plot(outB, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) plot(outC, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) mtext(side = 1, outer = TRUE, "time, d", line = 2, cex = 1.2) mtext(side = 2, at = 0.2, outer = TRUE, "Scenario C", line = 1.5, cex = 1.2) mtext(side = 2, at = 0.5, outer = TRUE, "Scenario B", line = 1.5, cex = 1.2) mtext(side = 2, at = 0.8, outer = TRUE, "Scenario A", line = 1.5, cex = 1.2) mtext(side = 3, at = 0.125, outer = TRUE, "pH, -", line = 1, cex = 1.2) mtext(side = 3, at = 0.375, outer = TRUE, "TA, mol/kg", line = 1, cex = 1.2) mtext(side = 3, at = 1-0.375, outer = TRUE, "CO2, mol/kg", line = 1, cex = 1.2) mtext(side = 3, at = 1-0.125, outer = TRUE, "O2, mol/kg", line = 1, cex = 1.2) deSolve/inst/doc/examples/Arenstorf.R0000644000176000001440000000641413136461015017336 0ustar ripleyusers## ============================================================================= ## ## Arenstorf orbit ## Standard test problem for nonstiff solvers. ## ## closed trajectory for 3-body problem; two of mass mu and (1-mu) ## and a third body of negligible mass, moving in the same plane ## Hairer et al., 2000 ## ## compared with DOPRI.f ## ## ============================================================================= library(deSolve) #----------------------------- # the model function #----------------------------- Arenstorf <- function(t, y, parms) { D1 <- ((y[1] + mu)^2 + y[2]^2)^(3/2) D2 <- ((y[1] - (1 - mu))^2 + y[2]^2)^(3/2) dy1 <- y[3] dy2 <- y[4] dy3 <- y[1] + 2*y[4] - (1 - mu)*(y[1] + mu)/D1 - mu*(y[1] - (1 - mu))/D2 dy4 <- y[2] - 2*y[3] - (1 - mu)*y[2]/D1 - mu*y[2]/D2 list(c(dy1, dy2, dy3, dy4)) } #----------------------------- # parameters, initial values and times #----------------------------- mu <- 0.012277471 yini <- c(x = 0.994, y = 0, dx = 0, dy = -2.00158510637908252240537862224) times <- c(seq(from = 0, to = 17, by = 2), 17.0652165601579625588917206249) #----------------------------- # solve the model #----------------------------- # first for making a graph system.time({ out <- ode(times = seq(0, 50, 0.1), y = yini, func = Arenstorf, parms = NULL, method = rkMethod("ode45"), rtol = 1e-10, atol = 1e-10) }) plot(out[, c("x", "y")], type = "l", lwd = 2, main = "Arenstorf") # then for comparison with DOPRI # (smaller tol than 1e-16 result in numerical problems and very long time) out <- rk(times = times, y = yini, func = Arenstorf, parms = NULL, method = rkMethod("ode45"), rtol = 1e-16, atol = 1e-16) diagnostics(out) options(digits = 10) out[, c("time", "x", "y")] # this is what DOPRI5 generates with atol=rtol=1e-7: # X = 0.00 Y = 0.9940000000E+00 0.0000000000E+00 NSTEP = 0 # X = 2.00 Y = -0.5798781411E+00 0.6090775251E+00 NSTEP = 60 # X = 4.00 Y = -0.1983335270E+00 0.1137638086E+01 NSTEP = 73 # X = 6.00 Y = -0.4735743943E+00 0.2239068118E+00 NSTEP = 91 # X = 8.00 Y = -0.1174553350E+01 -0.2759466982E+00 NSTEP = 110 # X = 10.00 Y = -0.8398073466E+00 0.4468302268E+00 NSTEP = 122 # X = 12.00 Y = 0.1314712468E-01 -0.8385751499E+00 NSTEP = 145 # X = 14.00 Y = -0.6031129504E+00 -0.9912598031E+00 NSTEP = 159 # X = 16.00 Y = 0.2427110999E+00 -0.3899948833E+00 NSTEP = 177 # X = XEND Y = 0.9940021016E+00 0.8911185692E-05 # tol=0.10D-06 fcn= 1442 step= 240 accpt= 216 rejct= 22 # and this for atol=rtol=1e-17 # X = 0.00 Y = 0.9940000000E+00 0.0000000000E+00 NSTEP = 0 # X = 2.00 Y = -0.5798767232E+00 0.6090783555E+00 NSTEP = 5281 # X = 4.00 Y = -0.1983328832E+00 0.1137637824E+01 NSTEP = 6555 # X = 6.00 Y = -0.4735743108E+00 0.2239077929E+00 NSTEP = 8462 # X = 8.00 Y = -0.1174553507E+01 -0.2759450770E+00 NSTEP = 10272 # X = 10.00 Y = -0.8398071663E+00 0.4468314171E+00 NSTEP = 11505 # X = 12.00 Y = 0.1314377269E-01 -0.8385747019E+00 NSTEP = 13847 # X = 14.00 Y = -0.6031162761E+00 -0.9912585277E+00 NSTEP = 15126 # X = 16.00 Y = 0.2427044376E+00 -0.3899991215E+00 NSTEP = 17184 # X = XEND Y = 0.9940000000E+00 -0.1966670302E-11 # tol=0.10D-16 fcn=126836 step=21139 accpt=21137 rejct= 0 deSolve/inst/doc/examples/Schelde_FNA.R0000644000176000001440000001472113136461015017426 0ustar ripleyusers################################################################################ # pH model of the Scheldt estuary # # Hofmann AF, Meysman FJR, Soetaert K, Middelburg J, 2008. # # A step-by-step procedure for pH model construction in aquatic systems # # Biogeosciences 5, 227-251 # # # # STEP 2 - FNA # # Full numerical approach - pH model written as a set of # # differential algebraic equations, solved with DAE solver daspk # # Implementation: Andreas Hofmann, Karline Soetaert - NIOZ # ################################################################################ # load parameters, dissociation constants, initial conditions, # the model transport function and function TA_estimate, to estimate alkalinity # Do make sure that this file is in the working directory (or use setwd("")) source('Schelde_pars.R') ################################################################################ # DIFFERENTIAL ALGEBRAIC EQUATIONS # ################################################################################ FNAResidual <- function (tt, state, dy, parms, scenario = "B1") { with (as.list(c(state, dy, parms)), { pH <- -log10(H*1e-6) TA <- HCO3 + 2*CO3 + NH3 - H SumCO2 <- CO2 + HCO3 + CO3 SumNH4 <- NH4 + NH3 #-------------------------- # PHYSICAL PROCESSES #-------------------------- # air-water exchange ECO2 <- KL * (CO2sat - CO2) EO2 <- KL * (O2sat - O2) ENH3 <- KL * (NH3sat - NH3) # Transport TO2 <- Transport(O2, O2_up, O2_down) TNO3 <- Transport(NO3, NO3_up, NO3_down) TTA <- Transport(TA, TA_up, TA_down) TSumCO2 <- Transport(SumCO2, SumCO2_up, SumCO2_down) TSumNH4 <- Transport(SumNH4, SumNH4_up, SumNH4_down) # Wastewater treatment plant in Brussels scenario if (scenario == "A" && tt > 365) { TOM <- Transport(OM, OM_up_A, OM_down) } else TOM <- Transport(OM, OM_up , OM_down) # Spills if (scenario == "B1" && (tt > 360 && tt < 370)) { AddNH4NO3 <- SpillNH4NO3 # NH4+NO3- - tanker addition } else AddNH4NO3 <- 0 if (scenario == "C" && (tt > 360 && tt < 370)) { AddNH3 <- SpillNH3 # NH3 - tanker input: } else AddNH3 <- 0 #-------------------------- # BIOGEOCHEMICAL PROCESSES: #-------------------------- # Oxic mineralisation ROx <- rOM * OM * (O2/(O2 + ksO2)) ROxCarbon <- ROx * C_Nratio # Nitrification RNit <- rNitri * NH4 * (O2/(O2 + ksO2)) #-------------------------- # RESIDUALS OF RATE OF CHANGES #-------------------------- # 9 unknowns (dOM,dO2,dNO3,dCO2,dHCO3,dCO3,dNH4,dNH3,dH) - 9 equations # of simple state variables ROM <- - dOM + TOM - ROx RO2 <- - dO2 + TO2 + EO2 - ROxCarbon - 2*RNit RNO3 <- - dNO3 + TNO3 + RNit + AddNH4NO3 # of summed quantities RSumCO2 <- -dCO2 -dHCO3 -dCO3 + TSumCO2 + ECO2 + ROxCarbon RSumNH4 <- -dNH3 -dNH4 + TSumNH4 + ENH3 + ROx - RNit + AddNH3 + AddNH4NO3 RTA <- -dHCO3-2*dCO3-dNH3 +dH + TTA + ENH3 + ROx - 2*RNit + AddNH3 # algebraic equations: equilibrium equations EquiCO2 <- H * HCO3 - K1CO2 * CO2 EquiHCO3<- H * CO3 - K2CO2 * HCO3 EquiNH4 <- H * NH3 - KNH4 * NH4 #-------------------------- # Output variables: The pH, alkalinity and other summed quantities #-------------------------- return(list(c(ROM, RO2, RNO3, RSumCO2, RSumNH4, RTA, EquiCO2, EquiHCO3, EquiNH4), c(pH = pH, TA = TA, SumCO2 = SumCO2, SumNH4 = SumNH4))) }) } ################################################################################ # MODEL APPLICATIONS # ################################################################################ #--------------------- # alkalinity at the boundaries #--------------------- TA_up <- TA_estimate(pH_up, SumCO2_up, SumNH4_up) TA_down <- TA_estimate(pH_down, SumCO2_down, SumNH4_down) #--------------------- # initial conditions #--------------------- H_ini <- 10^-pH_ini * 1e6 H <- H_ini NH3_ini <- KNH4/(KNH4+H)*SumNH4_ini NH4_ini <- SumNH4_ini - NH3_ini CO2_ini <- H*H/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_ini HCO3_ini <- H*K1CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_ini CO3_ini <- K1CO2*K2CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_ini TA_ini <- HCO3_ini + 2*CO3_ini + NH3_ini - H_ini # Initial conditions for the state variables AND their rates of change y <- c(OM = OM_ini, O2 = O2_ini, NO3 = NO3_ini, H = H_ini, NH4 = NH4_ini, NH3 = NH3_ini, CO2 = CO2_ini, HCO3 = HCO3_ini, CO3 = CO3_ini) dy <- c(dOM = 0, dO2 = 0, dNO3 = 0, dH = 0, dNH4 = 0, dNH3 = 0, dCO2 = 0, dHCO3 = 0, dCO3 = 0) #--------------------- # run the model #--------------------- times <- c(0, 350:405) outA <- daspk(y = y, times, res = FNAResidual, dy = dy, nalg = 3, parms = phPars, scenario = "A", hmax = 1) outB <- daspk(y = y, times, res = FNAResidual, dy = dy, nalg = 3, parms = phPars, scenario = "B1", hmax = 1) outC <- daspk(y = y, times, res = FNAResidual, dy = dy, nalg = 3, parms = phPars, scenario = "C", hmax = 1) #--------------------- # plot model output #--------------------- par(mfrow = c(3, 4), mar = c(1, 2, 2, 1), oma = c(3, 3, 3, 0)) Selection <- c("pH","TA","SumCO2","O2") plot(outA, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) plot(outB, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) plot(outC, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) mtext(side = 1, outer = TRUE, "time, d", line = 2, cex = 1.2) mtext(side = 2, at = 0.2, outer = TRUE, "Scenario C", line = 1.5, cex = 1.2) mtext(side = 2, at = 0.5, outer = TRUE, "Scenario B", line = 1.5, cex = 1.2) mtext(side = 2, at = 0.8, outer = TRUE, "Scenario A", line = 1.5, cex = 1.2) mtext(side = 3, at = 0.125, outer = TRUE, "pH, -", line = 1, cex = 1.2) mtext(side = 3, at = 0.375, outer = TRUE, "TA, mol/kg", line = 1, cex = 1.2) mtext(side = 3, at = 1-0.375, outer = TRUE, "CO2, mol/kg", line = 1, cex = 1.2) mtext(side = 3, at = 1-0.125, outer = TRUE, "O2, mol/kg", line = 1, cex = 1.2) deSolve/inst/doc/examples/Schelde_pars.R0000644000176000001440000001350613136461015017767 0ustar ripleyusers################################################################################ # pH model of the Scheldt estuary # # Hofmann AF, Meysman FJR, Soetaert K, Middelburg J, 2008. # # A step-by-step procedure for pH model construction in aquatic systems # # Biogeosciences # # # # MODEL PARAMETERS, INITIAL CONDITIONS, COMMON MODEL ROUTINES # # Implementation: Andreas Hofmann, Karline Soetaert - NIOZ # ################################################################################ require(deSolve) ################################################################################ # Global Physical parameters ## ################################################################################ Q <- 8640000 # m3/d discharge V <- 108798000 # m3 volume Eprime <- 13824000 # m3/d averaged bulk-dispersion coefficient, 160 m3/s) ################################################################################ # boundary conditions ################################################################################ # upper boundary OM_up <- 50 # umol/kg-soln NO3_up <- 350 # umol/kg-soln O2_up <- 70 # umol/kg-soln pH_up <- 7.6 SumNH4_up <- 80 # umol/kg-soln SumCO2_up <- 7100 # umol/kg-soln # lower boundary - pH and alkalinity are consistent OM_down <- 25 # umol/kg-soln NO3_down <- 260 # umol/kg-soln O2_down <- 240 # umol/kg-soln pH_down <- 7.92 SumNH4_down <- 7 # umol/kg-soln SumCO2_down <- 4400 # umol/kg-soln ################################################################################ # initial conditions: as derived from steady state run; pH and alkinity consistent ################################################################################ OM_ini <- 31.9688 # umol/kg-soln NO3_ini <- 340.235 # umol/kg-soln O2_ini <- 157.922 # umol/kg-soln pH_ini <- 7.7 # SumNH4_ini <- 35.8406 # umol/kg-soln SumCO2_ini <- 6017.28 # umol/kg-soln ################################################################################ # MODEL PARAMETERS # ################################################################################ phPars <- c( KL = 0.28 , # 1/d proportionality factor for air-water exchange rOM = 0.1 , # 1/d first-order oxic mineralisation rate of organic matter rNitri = 0.26 , # 1/d first order nitrification rate (with resp. to Ammonium) ksO2 = 20.0 , # umol-O2/kg-soln monod half-saturation constant Oxygen (ox min & nit) k1 = 1e3 , # 1/d "instantaneous" rate for forward equilibrium reactions C_Nratio = 8 , # mol C/mol N C:N ratio oforganic matter rDenit = 0.2 , # 1/d first order mineralisation due to denit rate (w.r.t. OM) ksNO3 = 45 , # umol-NO3/kg monod half-saturation constant nitrate denitrification ksO2inhib = 22 , # umol-02/kg monod inhibition term oxygen # saturated concentrations - calculated for T=12 and S=5 # CO2sat = 19 , # umol/kg-soln O2sat = 325 , # umol/kg-soln NH3sat = 0.0001 , # umol/kg-soln ################################################################################ ## DIFFERENT SCENARIOS: # @ A decreased waste load due to a sewage treatement plant in Brussels # @ B1 a 10000 ton fertilizer (NH4+/NO3-) ship sinks: different modelling approach (extra NH4NO3 addition) # @ C a 10000 ton NH3 ship sinks: modelling approach 1 (extra NH3 addition) ################################################################################ # Scenario A: Brussels wastewater treatment plant scenario reduces upstream conc of OM # OM_up_A = 25 , # umol/kg-soln # Scenario B1: Ammonium-Nitrate (fertilizer) tank ship scenario: # # model it as extra NH4+ and NO3 - addition of 10000 tpms# SpillNH4NO3 = ((10000 * 1000000)/(18 + 62)) * # Total substance in mol over 10 days 1000000 / (V * 1000) / 10, # Conc in umol/kg per day # Scenario C: NH3 (Ammonia) tank ship scenario (10000 tons NH3 input) # SpillNH3 = ((10000 * 1000000) / 17) * # Total substance in mol/10 days 1000000 / (V * 1000) / 10 # Conc in umol/kg per day ) ################################################################################ # Dissociation constants ################################################################################ require(seacarb) # Temperature, salinity settings Temp <- 12 # dg C Sal <- 5 # K1CO2 <- K1(S = Sal, T = Temp, P = 0)*1e6 # umol/kg-soln K2CO2 <- K2(S = Sal, T = Temp, P = 0)*1e6 # umol/kg-soln KNH4 <- Kn(S = Sal, T = Temp, P = 0)*1e6 # umol/kg-soln KW <- Kw(S = Sal, T = Temp, P = 0)*1e12 # (mol/kg-soln)^2 ################################################################################ # COMMON MODEL FUNCTIONS # ################################################################################ # Advective-dispersive transport Transport <- function (y, y.up, y.down) { # Q: discharge, m3/d; Eprime: bulk dispersion coefficient, V: Volume Input <- Q * c(y.up, y) - Eprime * diff(c(y.up, y, y.down)) dy <- -diff(Input)/V return(dy) } # Estimate alkalinity based on pH, sum CO2, sum NH4 TA_estimate <- function(pH, DIC, SumNH4) { H <- 10^(-pH)*1e6 HCO3 <- H*K1CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*DIC CO3 <- K1CO2*K2CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*DIC NH3 <- KNH4/(KNH4+H)*SumNH4 return(as.double(HCO3 + 2*CO3 + NH3 - H)) # Total alkalinity } deSolve/inst/doc/examples/Pollution.R0000644000176000001440000001764213136461015017365 0ustar ripleyusers################################################################################ # This is a stiff system of 20 non-linear Ordinary Differential Equations. # It describes a chemical reaction part of the air pollution model developed at # The Dutch National Institute of Public Health and Environmental Protection (RIVM), # and consists of 25 reaction and 20 reacting compounds. # The reaction rates vary from e-3 to e+12, making the model extremely stiff ################################################################################ # # A FORTRAN implementation (and reference output) can be found at # http://pitagora.dm.uniba.it//~testset # F. Mazzia and F. Iavernaro. Test Set for Initial Value Problem Solvers. # Department of Mathematics, University of Bari, August 2003. # Available at http://www.dm.uniba.it/~testset. # The model is described in Verwer (1994) # J.G. Verwer, 1994. Gauss-Seidel iteration for stiff ODEs from chemical kinetics. # SIAM J. Sci. Comput., 15(5):1243-1259. # 20 chemical species are described: NO2, NO, O3P, O3, HO2, OH, # HCHO, CO, ALD, MEO2, C2O3, CO2, PAN, CH3O, HNO3, O1D, SO2, SO4, NO3, N2O5 # The model describes the following reactions: # r1: NO2 -> NO + O3P # r2: NO + O3 -> NO2 # r3: HO2+NO -> NO2 # r4: HCHO -> 2 HO2 + CO # r5: HCHO -> CO # r6: HCHO + OH -> HO2+CO # r7: ALD + OH -> C2O3 # r8: ALD -> MEO2+HO2+C) # r9: C2O3 + NO -> NO2 + MEO2 + CO2 # r10: C2O3 + NO2 -> PAN # r11: PAN -> C2O3 + NO2 # r12: MEO2 + NO -> CH3O + NO2 # r13: CH3O -> HCHO + HO2 # r14: NO2+OH -> HNO3 # r15: O3P -> O3 # r16: O3 -> O1D # r17: O3 -> O3P # r18: O1D -> 2 OH # r19: O1D -> O3P # r20: SO2 + Oh -> SO4 + HO2 # r21: NO3 -> NO # r22: NO3 -> NO2 + O3P # r23: NO2 + O3 -> NO3 # r24: NO3 + NO2 -> N2O5 # r25: N2O5 -> NO3 + NO2 #======================= # the model definition #======================= Pollution <- function (t, y, pars) { r <- vector(length = 25) dy <- vector(length = length(y)) r[ 1] <- k1 * y[ 1] r[ 2] <- k2 * y[ 2]*y[4] r[ 3] <- k3 * y[ 5]*y[2] r[ 4] <- k4 * y[ 7] r[ 5] <- k5 * y[ 7] r[ 6] <- k6 * y[ 7]*y[6] r[ 7] <- k7 * y[ 9] r[ 8] <- k8 * y[ 9]*y[6] r[ 9] <- k9 * y[11]*y[2] r[10] <- k10 * y[11]*y[1] r[11] <- k11 * y[13] r[12] <- k12 * y[10]*y[2] r[13] <- k13 * y[14] r[14] <- k14 * y[ 1]*y[6] r[15] <- k15 * y[ 3] r[16] <- k16 * y[ 4] r[17] <- k17 * y[ 4] r[18] <- k18 * y[16] r[19] <- k19 * y[16] r[20] <- k20 * y[17]*y[6] r[21] <- k21 * y[19] r[22] <- k22 * y[19] r[23] <- k23 * y[ 1]*y[4] r[24] <- k24 * y[19]*y[1] r[25] <- k25 * y[20] dy[1] <- dy[1] - r[1]-r[10]-r[14]-r[23]-r[24]+r[2]+r[3]+ r[9]+r[11]+r[12]+r[22]+r[25] dy[2] <- dy[2] - r[2]-r[3]-r[9]-r[12]+r[1]+r[21] dy[3] <- dy[3] - r[15]+r[1]+r[17]+r[19]+r[22] dy[4] <- dy[4] - r[2]-r[16]-r[17]-r[23]+r[15] dy[5] <- dy[5] - r[3]+r[4]+r[4]+r[6]+r[7]+r[13]+r[20] dy[6] <- dy[6] - r[6]-r[8]-r[14]-r[20]+r[3]+r[18]+r[18] dy[7] <- dy[7] - r[4]-r[5]-r[6]+r[13] dy[8] <- dy[8] + r[4]+r[5]+r[6]+r[7] dy[9] <- dy[9] - r[7]-r[8] dy[10] <- dy[10] - r[12]+r[7]+r[9] dy[11] <- dy[11] - r[9]-r[10]+r[8]+r[11] dy[12] <- dy[12] + r[9] dy[13] <- dy[13] - r[11]+r[10] dy[14] <- dy[14] - r[13]+r[12] dy[15] <- dy[15] + r[14] dy[16] <- dy[16] - r[18]-r[19]+r[16] dy[17] <- dy[17] - r[20] dy[18] <- dy[18] + r[20] dy[19] <- dy[19] - r[21]-r[22]-r[24]+r[23]+r[25] dy[20] <- dy[20] - r[25]+r[24] return(list(c(dy = dy), rate = r)) } #============================= # parameters, state variables #============================= # Parameters: rate coefficients k1 <- 0.35 k2 <- 0.266e2 k3 <- 0.123e5 k4 <- 0.86e-3 k5 <- 0.82e-3 k6 <- 0.15e5 k7 <- 0.13e-3 k8 <- 0.24e5 k9 <- 0.165e5 k10 <- 0.9e4 k11 <- 0.22e-1 k12 <- 0.12e5 k13 <- 0.188e1 k14 <- 0.163e5 k15 <- 0.48e7 k16 <- 0.35e-3 k17 <- 0.175e-1 k18 <- 0.1e9 k19 <- 0.444e12 k20 <- 0.124e4 k21 <- 0.21e1 k22 <- 0.578e1 k23 <- 0.474e-1 k24 <- 0.178e4 k25 <- 0.312e1 # State variable initial condition y <- rep(0, 20) y[2] <- 0.2 y[4] <- 0.04 y[7] <- 0.1 y[8] <- 0.3 y[9] <- 0.01 y[17] <- 0.007 # The species names: spnames <- c("NO2", "NO", "O3P", "O3", "HO2", "OH", "HCHO", "CO", "ALD", "MEO2", "C2O3", "CO2", "PAN", "CH3O", "HNO3", "O1D", "SO2", "SO4", "NO3", "N2O5") names (y) <- spnames #============================= # application 1. #============================= times <- seq(0, 10, 0.1) # run with default tolerances, short period of time out <- vode(y, times, Pollution, parms = NULL) # increasing tolerance out2 <- vode(y, times, Pollution, parms = NULL, atol = 1e-10, rtol = 1e-10) # run for longer period Times <- seq (0, 2000, 10) out3 <- vode(y, Times, Pollution, parms = NULL, atol = 1e-10, rtol = 1e-10) # plotting output; omit the first row to avoud zero in logarithmic plots mf <-par(mfrow = c(2, 2)) plot (times[-1], out[-1, 6], type = "l", log = "y", ylab = "log", main = colnames(out)[6]) lines(times[-1], out2[-1, 6], lty = 2, col = "red") legend("topright", c("tol = 1e-8", "tol = 1e-10"), col = c("black", "red"), lty = 1) plot(times[-1], out2[-1, 8], type = "l", main = colnames(out)[8]) plot(Times[-1], out3[-1, 6], type = "l", log = "y", ylab = "log", main = colnames(out)[6]) plot(Times[-1], out3[-1, 8], type = "l", main = colnames(out)[8]) mtext(side = 3, outer = TRUE, line = -1.5, cex = 1.5, "Pollution problem") par (mfrow = mf) #============================= # application 2 #============================= # Testing vode, lsode, lsoda, lsodes and daspk for precision and speed: # reference output at t = 60 (from http://www.dm.uniba.it/~testset) ytrue <- c(0.5646255480022769e-1, 0.1342484130422339, 0.4139734331099427e-8, 0.5523140207484359e-2, 0.2018977262302196e-6, 0.1464541863493966e-6, 0.7784249118997964e-1, 0.3245075353396018, 0.7494013383880406e-2, 0.1622293157301561e-7, 0.1135863833257075e-7, 0.2230505975721359e-2, 0.2087162882798630e-3, 0.1396921016840158e-4, 0.8964884856898295e-2, 0.4352846369330103e-17, 0.6899219696263405e-2, 0.1007803037365946e-3, 0.1772146513969984e-5, 0.5682943292316392e-4) # generate output at t = 60, and compare it with reference output # using the highest precision that does not provoke an error TT <- c(0, 60) s1<-system.time( Test1 <- vode(y, TT, Pollution, parms = NULL, atol = 1e-17, rtol = 1e-16, verbose = TRUE) )["elapsed"] s2<-system.time( Test2 <- lsode(y, TT, Pollution, parms = NULL, atol = 1e-17, rtol = 1e-16, verbose = TRUE) )["elapsed"] s3<-system.time( Test3 <- lsoda(y, TT, Pollution, parms = NULL, atol = 1e-14, rtol = 1e-17, verbose = TRUE) )["elapsed"] s4<-system.time( Test4 <- lsodes(y, TT, Pollution, parms = NULL, atol = 1e-17, rtol = 1e-16, verbose = TRUE) )["elapsed"] s5<-system.time( Test5 <- daspk(y, TT, Pollution, parms = NULL, atol = 1e-10, rtol = 1e-17, verbose = TRUE) )["elapsed"] print( cbind(vode = (Test1[2, 2:21] - ytrue), lsode = (Test2[2, 2:21] - ytrue), lsoda = (Test3[2, 2:21] - ytrue), lsodes= (Test4[2, 2:21] - ytrue), daspk = (Test5[2, 2:21] - ytrue)) ) DF <- data.frame( method = c("vode", "lsode", "lsoda", "lsodes", "daspk"), "maximal deviation" = c(max(abs(Test1[2, 2:21] - ytrue)), max(abs(Test2[2, 2:21] - ytrue)), max(abs(Test3[2, 2:21] - ytrue)), max(abs(Test4[2, 2:21] - ytrue)), max(abs(Test5[2, 2:21] - ytrue))), "timing" = c(s1, s2, s3, s4, s5) ) print(DF) deSolve/inst/doc/examples/Schelde_OSA.R0000644000176000001440000001372013136461015017442 0ustar ripleyusers################################################################################ # pH model of the Scheldt estuary # # Hofmann AF, Meysman FJR, Soetaert K, Middelburg J, 2008. # # A step-by-step procedure for pH model construction in aquatic systems # # Biogeosciences 5, 227-251 # # # # STEP 3 -OSA # # Operator splitter approach - pH model written as a set of # # ordinary differential equations, solved with ODE solver vode # # Each time step the pH is solved at equilibrium, using uniroot # # Implementation: Andreas Hofmann, Karline Soetaert - NIOZ # ################################################################################ # load parameters, dissociation constants, initial conditions, # the model transport function and function TA_estimate, to estimate alkalinity # Do make sure that this file is in the working directory (or use setwd("")) source('Schelde_pars.R') ################################################################################ # UTILITIES # ################################################################################ # Function that estimates discrepancy between estimated and true total alkalinity # Root of this function = solution of equilibrium pH pHfunction <- function(pH, DIC, TA, SumNH4) return(TA-TA_estimate(pH, DIC, SumNH4)) ################################################################################ # ORDINARY DIFFERENTIAL EQUATIONS # ################################################################################ OSAmodel <- function (tt, state, parms, scenario="B1") { with (as.list(c(state, parms)), { pH <- uniroot (pHfunction, interval = c(6, 10), tol=1e-20, DIC=SumCO2, TA=TA, SumNH4=SumNH4)$root #-------------------------- # PHYSICAL PROCESSES #-------------------------- H <- 10^(-pH) * 1e6 CO2 <- H*H/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2 NH3 <- KNH4/(KNH4+H)*SumNH4 NH4 <- SumNH4 - NH3 # air-water exchange ECO2 <- KL * (CO2sat - CO2) EO2 <- KL * (O2sat - O2) ENH3 <- KL * (NH3sat - NH3) # Transport TO2 <- Transport(O2, O2_up, O2_down) TNO3 <- Transport(NO3, NO3_up, NO3_down) TTA <- Transport(TA, TA_up, TA_down) TSumCO2 <- Transport(SumCO2, SumCO2_up, SumCO2_down) TSumNH4 <- Transport(SumNH4, SumNH4_up, SumNH4_down) # Wastewater treatment plant in Brussels scenario if (scenario == "A" && tt > 365) { TOM <- Transport(OM, OM_up_A, OM_down) } else TOM <- Transport(OM, OM_up , OM_down) # Spills if (scenario == "B1" && (tt > 360 && tt < 370)) { AddNH4NO3 <- SpillNH4NO3 # NH4+NO3- - tanker addition } else AddNH4NO3 <- 0 if (scenario == "C" && (tt > 360 && tt < 370)) { AddNH3 <- SpillNH3 # NH3 - tanker input } else AddNH3 <- 0 #-------------------------- # BIOGEOCHEMICAL PROCESSES: #-------------------------- # Oxic mineralisation ROx <- rOM * OM * (O2/(O2 + ksO2)) ROxCarbon <- ROx * C_Nratio # Nitrification RNit <- rNitri * NH4 * (O2/(O2 + ksO2)) #-------------------------- # RATE OF CHANGE #-------------------------- dOM <- TOM - ROx dO2 <- TO2 + EO2 - ROxCarbon - 2*RNit dNO3 <- TNO3 + RNit + AddNH4NO3 dSumCO2 <- TSumCO2 + ECO2 + ROxCarbon dSumNH4 <- TSumNH4 + ENH3 + ROx - RNit + AddNH3 + AddNH4NO3 dTA <- TTA + ENH3 + ROx-2*RNit + AddNH3 return(list(c(dOM, dO2, dNO3, dTA, dSumNH4, dSumCO2), c(pH=pH, CO2=CO2, NH3=NH3, NH4=SumNH4-NH3))) }) } ################################################################################ # MODEL APPLICATIONS # ################################################################################ #--------------------- # Akalinity at boundaries #--------------------- TA_down<- TA_estimate(pH_down, SumCO2_down, SumNH4_down) TA_up <- TA_estimate(pH_up , SumCO2_up , SumNH4_up) #--------------------- # initial conditions #--------------------- TA_ini <- TA_estimate(pH_ini , SumCO2_ini , SumNH4_ini) state <- c(OM=OM_ini, O2=O2_ini, NO3=NO3_ini, TA=TA_ini, SumNH4=SumNH4_ini, SumCO2=SumCO2_ini) #--------------------- # run model #--------------------- times <- c(0, 350:405) outA <- vode(state, times, OSAmodel, phPars, scenario = "A" , hmax = 1) outB <- vode(state, times, OSAmodel, phPars, scenario = "B1", hmax = 1) outC <- vode(state, times, OSAmodel, phPars, scenario = "C" , hmax = 1) #--------------------- # plot model output #--------------------- par(mfrow = c(3, 4), mar = c(1, 2, 2, 1), oma = c(3, 3, 3, 0)) Selection <- c("pH","TA","SumCO2","O2") plot(outA, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) plot(outB, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) plot(outC, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) mtext(side = 1, outer = TRUE, "time, d", line = 2, cex = 1.2) mtext(side = 2, at = 0.2, outer = TRUE, "Scenario C", line = 1.5, cex = 1.2) mtext(side = 2, at = 0.5, outer = TRUE, "Scenario B", line = 1.5, cex = 1.2) mtext(side = 2, at = 0.8, outer = TRUE, "Scenario A", line = 1.5, cex = 1.2) mtext(side = 3, at = 0.125, outer = TRUE, "pH, -", line = 1, cex = 1.2) mtext(side = 3, at = 0.375, outer = TRUE, "TA, mol/kg", line = 1, cex = 1.2) mtext(side = 3, at = 1-0.375, outer = TRUE, "CO2, mol/kg", line = 1, cex = 1.2) mtext(side = 3, at = 1-0.125, outer = TRUE, "O2, mol/kg", line = 1, cex = 1.2) deSolve/inst/doc/examples/examples_paper.R0000644000176000001440000002273113136461015020400 0ustar ripleyuserslibrary(deSolve) #=============================================================================== # R-examples from SECTION 3 # section 3.1 - the basic lotka-volterra predator-prey model. #=============================================================================== ## 1) model function LVmod0D <- function(Time, State, Pars) { with(as.list(c(State, Pars)), { IngestC <- rI * P * C GrowthP <- rG * P * (1 - P/K) MortC <- rM * C dP <- GrowthP - IngestC dC <- IngestC * AE - MortC return(list(c(dP, dC))) }) } ## 2) parameters, start values, times, simulation pars <- c(rI = 0.2, # /day, rate of ingestion rG = 1.0, # /day, growth rate of prey rM = 0.2 , # /day, mortality rate of consumer AE = 0.5, # -, assimilation efficiency K = 10) # mmol/m3, carrying capacity yini <- c(P = 1, C = 2) times <- seq(0, 200, by = 1) nrun <- 1 # set 10 for benchmark print(system.time( for (i in 1:nrun) out <- lsoda(func = LVmod0D, y = yini, parms = pars, times = times) )/nrun) print(system.time( for (i in 1:nrun) out <- lsode(func = LVmod0D, y = yini, parms = pars, times = times) )/nrun) print(system.time( for (i in 1:nrun) out <- vode(func = LVmod0D, y = yini, parms = pars, times = times) )/nrun) print(system.time( for (i in 1:nrun) out <- daspk(func = LVmod0D, y = yini, parms = pars, times = times) )/nrun) print(system.time( for (i in 1:nrun) out <- lsodes(func = LVmod0D, y = yini, parms = pars, times = times) )/nrun) matplot(out[,"time"], out[,2:3], type = "l", xlab = "time", ylab = "Conc", main = "Lotka-Volterra", lwd = 2) legend("topright", c("prey", "predator"), col =1:2, lty = 1:2) #=============================================================================== # section 3.2 - predator-prey model with stopping criterium. #=============================================================================== rootfun <- function(Time, State, Pars) { dstate <- unlist(LVmod0D(Time, State, Pars)) root <- sum(abs(dstate)) - 1e-4 } print(system.time( for (i in 1:nrun) out <- lsodar(func = LVmod0D, y = yini, parms = pars, times = times, rootfun = rootfun) )/nrun) matplot(out[,"time"],out[,2:3], type = "l", xlab = "time", ylab = "Conc", main = "Lotka-Volterra with root", lwd = 2) #=============================================================================== # section 3.3 - predator-prey model in 1-D. #=============================================================================== LVmod1D <- function (time, state, parms, N, Da, dx) { with (as.list(parms), { P <- state[1:N] C <- state[-(1:N)] ## Dispersive fluxes; zero-gradient boundaries FluxP <- -Da * diff(c(P[1], P, P[N]))/dx FluxC <- -Da * diff(c(C[1], C, C[N]))/dx ## Biology: Lotka-Volterra dynamics IngestC <- rI * P * C GrowthP <- rG * P * (1- P/K) MortC <- rM * C ## Rate of change = -Flux gradient + Biology dP <- -diff(FluxP)/dx + GrowthP - IngestC dC <- -diff(FluxC)/dx + IngestC * AE - MortC return(list(c(dP, dC))) }) } R <- 20 # total length of surface, m N <- 1000 # number of boxes dx <- R/N # size of box in x-direction Da <- 0.05 # m2/d, dispersion coefficient yini <- rep(0, 2*N) yini[500:501] <- yini[1500:1501] <- 10 times <-seq(0, 200, by = 1) # output wanted at these time intervals # based on lsode print(system.time( for (i in 1:nrun) out <- ode.1D(y = yini, times = times, func = LVmod1D, parms = pars, nspec = 2, N = N, dx = dx, Da = Da) )/nrun) print(system.time( for (i in 1:nrun) out <- ode.1D(y = yini, times = times, func = LVmod1D, parms = pars, nspec = 2, N = N, dx = dx, Da = Da, method = "vode") )/nrun) print(system.time( for (i in 1:nrun) out <- ode.1D(y = yini, times = times, func = LVmod1D, parms = pars, nspec = 2, N = N, dx = dx, Da = Da, method = "lsoda") )/nrun) print(system.time( for (i in 1:nrun) out <- ode.1D(y = yini, times = times, func = LVmod1D, parms = pars, nspec = 2, N = N, dx = dx, Da = Da, method = "lsodes") )/nrun) image(out, which = 1, grid = seq(0, R, length=N), xlab = "Time, days", ylab = "Distance, m", main = "Prey density") # more elaborate way: #P <- out[,2:(N + 1)] #filled.contour(x = times, z = P, y = seq(0, R, length=N), # color = topo.colors, # xlab = "Time, days", ylab= "Distance, m", # main = "Prey density") #=============================================================================== # section 3.4 - predator-prey model in 2-D. #=============================================================================== LVmod2D <- function (time, state, parms, N, Da, dx, dy) { P <- matrix(nr = N, nc = N, state[1:NN]) C <- matrix(nr = N, nc = N, state[-(1:NN)]) with (as.list(parms), { dP <- rG*P *(1 - P/K) - rI*P*C dC <- rI*P*C*AE - rM*C zero <- numeric(N) ## Fluxes in x-direction; zero fluxes near boundaries FluxP <- rbind(zero, -Da*(P[-1,] - P[-N,])/dx, zero) FluxC <- rbind(zero, -Da*(C[-1,] - C[-N,])/dx, zero) dP <- dP - (FluxP[-1,] - FluxP[-(N+1),])/dx dC <- dC - (FluxC[-1,] - FluxC[-(N+1),])/dx ## Fluxes in y-direction FluxP <- cbind(zero, -Da*(P[,-1] - P[,-N])/dy, zero) FluxC <- cbind(zero, -Da*(C[,-1] - C[,-N])/dy, zero) dP <- dP - (FluxP[,-1] - FluxP[,-(N+1)])/dy dC <- dC - (FluxC[,-1] - FluxC[,-(N+1)])/dy return(list(c(as.vector(dP), as.vector(dC)))) }) } R <- 20 # total length of surface, m N <- 50 # number of boxes dx <- R/N # size of box in x-direction dy <- R/N # size of box in y-direction Da <- 0.05 # m2/d, dispersion coefficient NN <- N*N yini <- rep(0, 2*N*N) cc <- c((NN/2):(NN/2+1)+N/2, (NN/2):(NN/2+1)-N/2) yini[cc] <- yini[NN+cc] <- 10 times <- seq(0, 200, by = 1) # output wanted at these time intervals print(system.time( for (i in 1:nrun) out <- ode.2D(y = yini, times = times, func = LVmod2D, parms = pars, ynames = FALSE, dimens = c(N, N), N = N, dx = dx, dy = dy, Da = Da, lrw = 440000) )/nrun) Col<- colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000")) # topo.colors #pdf("Fig3.pdf", width=7, height=8) par(mfrow=c(2,2)) par(oma=c(0,0,2,0)) xx <- seq(0, R, dx) yy <- seq(0, R, dy) image(x = xx, y = yy, z = matrix(nr = N, nc = N, out[1,-1]), zlim = c(0,10), col = Col(100), main = "initial", xlab = "x", ylab = "y") image(x = xx, y = yy, z = matrix(nr = N, nc = N, out[21,-1]), zlim = c(0,10), col = Col(100), main = "20 days", xlab = "x", ylab = "y") image(x = xx, y = yy, z = matrix(nr = N, nc = N, out[31,-1]), zlim = c(0,10), col = Col(100), main = "30 days", xlab = "x", ylab = "y") image(x = xx, y = yy, z = matrix(nr = N, nc = N, out[41,-1]), zlim = c(0,10), col = Col(100), main = "40 days", xlab = "x", ylab = "y") mtext(side = 3, outer = TRUE, cex = 1.25, "Lotka-Volterra Prey concentration on 2-D grid") #filled.contour(matrix(nr=N,nc=N,out[20,-1]), color.palette=topo.colors,main="2-D grid") #dev.off() #pdf("Fig3legend.pdf", width=5, height=14) #opar <- par(las=1, mar=c(4,4,1,1), cex=3.5) #image(matrix(nr=1,nc=100,seq(0,10,length=100)), # x=c(0,1), y=seq(0,10,length=100), zlim=c(0,10), # col=Col(100),main="",xlab="",ylab="", # axes = FALSE) #abline(h=0:10) #mtext("Prey concentration", side=2, line=2.1, las=0, cex=3.5) #axis(2) #par(opar) #dev.off() ## DAE example Res_DAE <- function (t, y, yprime, pars, K) { with (as.list(c(y, yprime, pars)), { ## residuals of lumped rates of changes res1 <- -dD - dA + prod res2 <- -dB + dA - r*B ## and the equilibrium equation eq <- K*D - A*B return(list(c(res1, res2, eq), CONC = A + B + D)) }) } times <- seq(0, 100, by = 2) pars <- c(r = 1, prod = 0.1) K <- 1 ## Initial conc; D is in equilibrium with A,B yini <- c(A = 2, B = 3, D = 2*3/K) ## Initial rate of change dyini <- c(dA = 0, dB = 0, dD = 0) ## DAE model solved with daspk DAE <- daspk(y = yini, dy = dyini, times = times, res = Res_DAE, parms = pars, atol = 1e-10, rtol = 1e-10, K = 1) plot(DAE, main = c(paste("[",colnames(DAE)[2:4],"]"),"total conc"), xlab = "time", lwd = 2, ylab = "conc", type = "l") mtext(outer=TRUE, side=3, "DAE chemical model",cex=1.25) #=============================================================================== # section 4 - Model implementation in a compiled language # # This example needs an installed toolset for compiling source code # see the "R Installation and Administration" manual #=============================================================================== #if (is.loaded("initmod")) # dyn.unload(paste("LVmod0D",.Platform$dynlib.ext,sep="")) #system("R CMD SHLIB LVmod0D.f") #system("R CMD SHLIB LVmod0D.c") # #dyn.load(paste("LVmod0D", .Platform$dynlib.ext, sep = "")) # #pars <- c(rI = 0.2, rG = 1.0, rM = 0.2, AE = 0.5, K = 10) #yini <- c(P = 1, C = 2) #times <- seq(0, 200, by = 1) # #print(system.time( # out <- ode(func = "derivs", y = yini, parms = pars, times = times, # dllname = "LVmod0D", initfunc = "initparms", nout = 1, # outnames = c("total")) #)) # #dyn.unload(paste("LVmod0D", .Platform$dynlib.ext, sep = "")) deSolve/inst/doc/examples/Schelde_DSA.R0000644000176000001440000001403113136461015017423 0ustar ripleyusers################################################################################ # pH model of the Scheldt estuary # # Hofmann AF, Meysman FJR, Soetaert K, Middelburg J, 2008. # # A step-by-step procedure for pH model construction in aquatic systems # # Biogeosciences 5, 227-251 # # # # STEP 4 -DSA # # Direct substitution approach - pH model written as a set of # # ordinary differential equations, solved with ODE solver vode # # Hplus is a state variable; the model is not stiff # # Implementation: Andreas Hofmann, Karline Soetaert - NIOZ # ################################################################################ # load parameters, dissociation constants, initial conditions, # the model transport function and function TA_estimate, to estimate alkalinity # Do make sure that this file is in the working directory (or use setwd("")) source('Schelde_pars.R') ################################################################################ # ORDINARY DIFFERENTIAL EQUATIONS # ################################################################################ DSAmodel <- function (tt, state, parms, scenario = "B1") { with (as.list(c(state, parms)), { pH <- -log10(H*1e-6) TA <- TA_estimate(pH, SumCO2, SumNH4) #-------------------------- # PHYSICAL PROCESSES #-------------------------- CO2 <- H*H/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2 NH3 <- KNH4/(KNH4+H)*SumNH4 NH4 <- SumNH4 - NH3 # air-water exchange ECO2 <- KL * (CO2sat - CO2) EO2 <- KL * (O2sat - O2) ENH3 <- KL * (NH3sat - NH3) # Transport TO2 <- Transport(O2, O2_up, O2_down) TNO3 <- Transport(NO3, NO3_up, NO3_down) TTA <- Transport(TA, TA_up, TA_down) TSumCO2 <- Transport(SumCO2, SumCO2_up, SumCO2_down) TSumNH4 <- Transport(SumNH4, SumNH4_up, SumNH4_down) # Wastewater treatment plant in Brussels scenario if (scenario == "A" && tt > 365) { TOM <- Transport(OM, OM_up_A, OM_down) } else TOM <- Transport(OM, OM_up , OM_down) # Spills if (scenario == "B1" && (tt > 360 && tt < 370)) { AddNH4NO3 <- SpillNH4NO3 # NH4+NO3- - tanker addition } else AddNH4NO3 <- 0 if (scenario == "C" && (tt > 360 && tt < 370)) { AddNH3 <- SpillNH3 # NH3 - tanker input: } else AddNH3 <- 0 #-------------------------- # BIOGEOCHEMICAL PROCESSES: #-------------------------- # Oxic mineralisation ROx <- rOM * OM * (O2/(O2 + ksO2)) ROxCarbon <- ROx * C_Nratio # Nitrification RNit <- rNitri * NH4 * (O2/(O2 + ksO2)) #-------------------------- # RATE OF CHANGE #-------------------------- dOM <- TOM - ROx dO2 <- TO2 + EO2 - ROxCarbon - 2*RNit dNO3 <- TNO3 + RNit + AddNH4NO3 dSumCO2 <- TSumCO2 + ECO2 + ROxCarbon dSumNH4 <- TSumNH4 + ENH3 + ROx - RNit + AddNH3 + AddNH4NO3 # rate of change of pH: dTAdSumCO2 <- (H*K1CO2 + (2*K1CO2*K2CO2))/((H*K1CO2) + (K1CO2*K2CO2) + (H*H)) dTAdSumNH4 <- KNH4 / (KNH4 + H) dHCO3dH <- ((K1CO2/((H*K1CO2) + (K1CO2*K2CO2) + (H*H))) - ((H*K1CO2*((2*H)+K1CO2))/(((H*K1CO2) + (K1CO2*K2CO2) + (H*H))^2)))* SumCO2 dCO3dH <- -((K1CO2*K2CO2*((2*H)+K1CO2))/ (((H*K1CO2) + (K1CO2*K2CO2) + (H*H))^2)) * SumCO2 dNH3dH <- -(KNH4 / ((H*H)+(2*H*KNH4)+(KNH4*KNH4))) * SumNH4 dHdH <- 1 dTAdH <- dHCO3dH + 2*dCO3dH + dNH3dH - dHdH dH <- ((ROx - 2*RNit + ENH3 + AddNH3 + TTA) - ((dTAdSumCO2*dSumCO2) + (dTAdSumNH4*dSumNH4)))/dTAdH return(list(c(dOM, dO2, dNO3, dH, dSumNH4, dSumCO2), c(TA=TA, pH=pH, CO2=CO2, NH3=NH3, NH4=SumNH4-NH3))) }) } ################################################################################ # MODEL APPLICATIONS # ################################################################################ #--------------------- # alkalinity at the boundaries #--------------------- TA_up <- TA_estimate(pH_up, SumCO2_up, SumNH4_up) TA_down <- TA_estimate(pH_down, SumCO2_down, SumNH4_down) #--------------------- # the initial conditions #--------------------- H_ini <- 10^(-pH_ini)*1e6 state <- c(OM=OM_ini, O2=O2_ini, NO3=NO3_ini, H=H_ini, SumNH4=SumNH4_ini, SumCO2=SumCO2_ini) #--------------------- # run model - three scenarios #--------------------- times <- c(0, 350:405) outA <- vode(state, times, DSAmodel, phPars, scenario = "A", hmax = 1) outB <- vode(state, times, DSAmodel, phPars, scenario = "B1", hmax = 1) outC <- vode(state, times, DSAmodel, phPars, scenario = "C" , hmax = 1) #--------------------- # plot model output #--------------------- par(mfrow = c(3, 4), mar = c(1, 2, 2, 1), oma = c(3, 3, 3, 0)) Selection <- c("pH","TA","SumCO2","O2") plot(outA, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) plot(outB, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) plot(outC, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) mtext(side = 1, outer = TRUE, "time, d", line = 2, cex = 1.2) mtext(side = 2, at = 0.2, outer = TRUE, "Scenario C", line = 1.5, cex = 1.2) mtext(side = 2, at = 0.5, outer = TRUE, "Scenario B", line = 1.5, cex = 1.2) mtext(side = 2, at = 0.8, outer = TRUE, "Scenario A", line = 1.5, cex = 1.2) mtext(side = 3, at = 0.125, outer = TRUE, "pH, -", line = 1, cex = 1.2) mtext(side = 3, at = 0.375, outer = TRUE, "TA, mol/kg", line = 1, cex = 1.2) mtext(side = 3, at = 1-0.375, outer = TRUE, "CO2, mol/kg", line = 1, cex = 1.2) mtext(side = 3, at = 1-0.125, outer = TRUE, "O2, mol/kg", line = 1, cex = 1.2) deSolve/inst/doc/examples/Nand.R0000644000176000001440000002700513136461015016252 0ustar ripleyusers#----------------------------------------------------------------------- # Note: This file was derived from the FORTRAN code nand.f # The file description of the original is: # " # This file is part of the Test Set for IVP solvers # http://www.dm.uniba.it/~testset/ # # NAND gate # index 0 IDE of dimension 14 # # DISCLAIMER: see # http://www.dm.uniba.it/~testset/disclaimer.php # # The most recent version of this source file can be found at # http://www.dm.uniba.it/~testset/src/problems/nand.f # # This is revision # $Id: nand.F,v 1.2 2006/10/02 10:29:14 testset Exp $ # " #----------------------------------------------------------------------- library(deSolve) #----------------------------------------------------------------------- # # The network equation describing the nand gate # C[Y] * Y' - f[Y,t] = 0 # # --------------------------------------------------------------------- Nand <- function(t, # time point t Y, # node potentials at time point t Yprime, pars) # rate of change of Y { #----------------------------------------------------------------------- # Voltage-dependent capacitance matrix C(Y) for the network equation # C(Y) * Y' - f(Y,t) = 0 #----------------------------------------------------------------------- CAP[1, 1] <- CGS CAP[1, 5] <- -CGS CAP[2, 2] <- CGD CAP[2, 5] <- -CGD CAP[3, 3] <- CBDBS(Y[3]-Y[5]) CAP[3, 5] <- -CBDBS(Y[3]-Y[5]) CAP[4, 4] <- CBDBS(Y[4]-VDD) CAP[5, 1] <- -CGS CAP[5, 2] <- -CGD CAP[5, 3] <- -CBDBS(Y[3]-Y[5]) CAP[5, 5] <- CGS+CGD-CAP[5, 3]+ CBDBS(Y[9]-Y[5])+C9 CAP[5, 9] <- -CBDBS(Y[9]-Y[5]) CAP[6, 6] <- CGS CAP[7, 7] <- CGD CAP[8, 8] <- CBDBS(Y[8]-Y[10]) CAP[8, 10] <- -CBDBS(Y[8]-Y[10]) CAP[9, 5] <- -CBDBS(Y[9]-Y[5]) CAP[9, 9] <- CBDBS(Y[9]-Y[5]) CAP[10, 8] <- -CBDBS(Y[8]-Y[10]) CAP[10, 10] <- -CAP[8, 10]+CBDBS(Y[14]-Y[10])+C9 CAP[10, 14] <- -CBDBS(Y[14]-Y[10]) CAP[11, 11] <- CGS CAP[12, 12] <- CGD CAP[13, 13] <- CBDBS(Y[13]) CAP[14, 10] <- -CBDBS(Y[14]-Y[10]) CAP[14, 14] <- CBDBS(Y[14]-Y[10]) # --------------------------------------------------------------------- # PULSE: Input signal in pulse form # --------------------------------------------------------------------- P1 <- PULSE(t, 0.0, 5.0, 5.0, 5.0, 5.0, 5.0, 20.0) V1 <- P1$VIN V1D <- P1$VIND P2 <- PULSE(t, 0.0, 5.0, 15.0, 5.0, 15.0, 5.0, 40.0) V2 <- P2$VIN V2D <- P2$VIND #----------------------------------------------------------------------- # Right-hand side f[X,t] for the network equation # C[Y] * Y' - f[Y,t] = 0 # External reference: # IDS: Drain-source current # IBS: Nonlinear current characteristic for diode between # bulk and source # IBD: Nonlinear current characteristic for diode between # bulk and drain #----------------------------------------------------------------------- F[1] <- -(Y[1]-Y[5])/RGS-IDS(1, Y[2]-Y[1], Y[5]-Y[1], Y[3]-Y[5], Y[5]-Y[2], Y[4]-VDD) F[2] <- -(Y[2]-VDD)/RGD+IDS(1, Y[2]-Y[1], Y[5]-Y[1], Y[3]-Y[5], Y[5]-Y[2], Y[4]-VDD) F[3] <- -(Y[3]-VBB)/RBS + IBS(Y[3]-Y[5]) F[4] <- -(Y[4]-VBB)/RBD + IBD(Y[4]-VDD) F[5] <- -(Y[5]-Y[1])/RGS-IBS(Y[3]-Y[5])-(Y[5]-Y[7])/RGD- IBD(Y[9]-Y[5]) F[6] <- CGS*V1D-(Y[6]-Y[10])/RGS - IDS(2, Y[7]-Y[6], V1-Y[6], Y[8]-Y[10], V1-Y[7], Y[9]-Y[5]) F[7] <- CGD*V1D-(Y[7]-Y[5])/RGD + IDS(2, Y[7]-Y[6], V1-Y[6], Y[8]-Y[10], V1-Y[7], Y[9]-Y[5]) F[8] <- -(Y[8]-VBB)/RBS + IBS(Y[8]-Y[10]) F[9] <- -(Y[9]-VBB)/RBD + IBD(Y[9]-Y[5]) F[10] <- -(Y[10]-Y[6])/RGS-IBS(Y[8]-Y[10]) - (Y[10]-Y[12])/RGD-IBD(Y[14]-Y[10]) F[11] <- CGS*V2D-Y[11]/RGS-IDS(2, Y[12]-Y[11], V2-Y[11], Y[13], V2-Y[12], Y[14]-Y[10]) F[12] <- CGD*V2D-(Y[12]-Y[10])/RGD + IDS(2, Y[12]-Y[11], V2-Y[11], Y[13], V2-Y[12], Y[14]-Y[10]) F[13] <- -(Y[13]-VBB)/RBS + IBS(Y[13]) F[14] <- -(Y[14]-VBB)/RBD + IBD(Y[14]-Y[10]) # C[Y] * Y' - f[Y,t] = 0 Delta <- colSums(t(CAP)*Yprime)-F return(list(c(Delta), pulse1 = P1$VIN, pulse2 = P2$VIN)) } # --------------------------------------------------------------------------- # # Function evaluating the drain-current due to the model of # Shichman and Hodges # # --------------------------------------------------------------------------- IDS <- function (NED, # NED Integer parameter for MOSFET-type VDS, # VDS Voltage between drain and source VGS, # VGS Voltage between gate and source VBS, # VBS Voltage between bulk and source VGD, # VGD Voltage between gate and drain VBD) # VBD Voltage between bulk and drain { if ( VDS == 0 ) return(0) if (NED== 1) { #--- Depletion-type VT0 <- -2.43 CGAMMA <- 0.2 PHI <- 1.28 BETA <- 5.35e-4 } else { # --- Enhancement-type VT0 <- 0.2 CGAMMA <- 0.035 PHI <- 1.01 BETA <- 1.748e-3 } if ( VDS > 0 ) # drain function for VDS>0 { SQRT1<-ifelse (PHI-VBS>0, sqrt(PHI-VBS), 0) VTE <- VT0 + CGAMMA * ( SQRT1 - sqrt(PHI) ) if ( VGS-VTE <= 0.0) IDS <- 0. else if ( 0.0 < VGS-VTE & VGS-VTE <= VDS ) IDS <- - BETA * (VGS - VTE)^ 2.0 * (1.0 + DELTA*VDS) else if ( 0.0 < VDS & VDS < VGS-VTE ) IDS <- - BETA * VDS * (2 *(VGS - VTE) - VDS) * (1.0 + DELTA*VDS) } else { SQRT2<-ifelse (PHI-VBD>0, sqrt(PHI-VBD), 0) VTE <- VT0 + CGAMMA * (SQRT2 - sqrt(PHI) ) if ( VGD-VTE <= 0.0) IDS <- 0.0 else if ( 0.0 < VGD-VTE & VGD-VTE <= -VDS ) IDS <- BETA * (VGD - VTE)^2.0 * (1.0 - DELTA*VDS) else if ( 0.0 < -VDS & -VDS < VGD-VTE ) IDS <- - BETA * VDS * (2 *(VGD - VTE) + VDS) *(1.0 - DELTA*VDS) } return(IDS) } # --------------------------------------------------------------------------- # # Function evaluating the current of the pn-junction between bulk and # source due to the model of Shichman and Hodges # # --------------------------------------------------------------------------- IBS <- function(VBS) # VBS Voltage between bulk and source ifelse (VBS <= 0.0, -CURIS * (exp(VBS/VTH) - 1.0), 0.0) # --------------------------------------------------------------------------- # # Function evaluating the current of the pn-junction between bulk and # drain due to the model of Shichman and Hodges # # --------------------------------------------------------------------------- IBD <- function(VBD) # VBD Voltage between bulk and drain ifelse(VBD <= 0.0, -CURIS * (exp(VBD/VTH) - 1.0), 0.0) # --------------------------------------------------------------------------- # # Evaluating input signal at time point X # # --------------------------------------------------------------------------- PULSE <- function (X, # Time-point at which input signal is evaluated LOW, # Low-level of input signal HIGH, # High-level of input signal DELAY, T1, T2, T3, PERIOD) # Parameters to specify signal structure # --------------------------------------------------------------------------- # Structure of input signal: # # ----------------------- HIGH # / \ # / \ # / \ # / \ # / \ # / \ # / \ # / \ # ------ --------- LOW # # |DELAY| T1 | T2 | T3 | # | P E R I O D | # # --------------------------------------------------------------------------- { TIME <- X %% PERIOD VIN <- LOW VIND <- 0.0 if (TIME > (DELAY+T1+T2)) { VIN <- ((HIGH-LOW)/T3)*(DELAY+T1+T2+T3-TIME) + LOW VIND <- -((HIGH-LOW)/T3) } else if (TIME > (DELAY+T1)) { VIN <- HIGH VIND <- 0.0 } else if (TIME > DELAY) { VIN <- ((HIGH-LOW)/T1)*(TIME-DELAY) + LOW VIND <- ((HIGH-LOW)/T1) } return (list(VIN = VIN, # Voltage of input signal at time point X VIND = VIND)) # Derivative of VIN at time point X } # --------------------------------------------------------------------------- # # Function evaluating the voltage-dependent capacitance between bulk and # drain gevalp. source due to the model of Shichman and Hodges # # --------------------------------------------------------------------------- CBDBS <- function(V) # Voltage between bulk and drain gevalp. source ifelse(V <= 0.0, CBD/sqrt(1.0-V/0.87), CBD*(1.0+V/(2.0*0.87))) #----------------------------------------------------------------------- # solution # computed at Cray C90, using Cray double precision: # Solving NAND gate using PSIDE # # User input: # # give relative error tolerance: 1d-16 # give absolute error tolerance: 1d-16 # # # Integration characteristics: # # number of integration steps 22083 # number of accepted steps 21506 # number of f evaluations 308562 # number of Jacobian evaluations 337 # number of LU decompositions 10532 # # CPU-time used: 451.71 sec # # y[ 1] = 0.4971088699385777d+1 # y[ 2] = 0.4999752103929311d+1 # y[ 3] = -0.2499998781491227d+1 # y[ 4] = -0.2499999999999975d+1 # y[ 5] = 0.4970837023296724d+1 # y[ 6] = -0.2091214032073855d+0 # y[ 7] = 0.4970593243278363d+1 # y[ 8] = -0.2500077409198803d+1 # y[ 9] = -0.2499998781491227d+1 # y[ 10] = -0.2090289583878100d+0 # y[ 11] = -0.2399999999966269d-3 # y[ 12] = -0.2091214032073855d+0 # y[ 13] = -0.2499999999999991d+1 # y[ 14] = -0.2500077409198803d+1 #----------------------------------------------------------------------- RGS <- 4 RGD <- 4 RBS <- 10 RBD <- 10 CGS <- 0.6e-4 CGD <- 0.6e-4 CBD <- 2.4e-5 CBS <- 2.4e-5 C9 <- 0.5e-4 DELTA <- 0.2e-1 CURIS <- 1.e-14 VTH <- 25.85 VDD <- 5. VBB <- -2.5 #----------------------------------------------------------------------- # initialising VBB <- -2.5 Y <- c(5, 5, VBB, VBB, 5, 3.62385, 5, VBB, VBB, 3.62385, 0, 3.62385, VBB, VBB) Yprime <- rep(0, 14) #----------------------------------------------------------------------- # memory allocation CAP <- matrix(nrow = 14, ncol = 14, 0) F <- vector("double", 14) times <- seq(0, 80, by = 1) # time: from 0 to 80 hours, steps of 1 hour # integrate the model: low tolerances to restrict integration time out <- daspk(y = Y, dy = NULL, times, res = Nand, parms = 0, rtol = 1e-6, atol = 1e-6) # plot output par(mfrow = c(4, 4), mar = c(4, 2, 3, 2)) for(i in 2:15) plot(out[, 1], out[, i], type = "l", ylab = "", main = paste("y[", i-1, "]"), xlab = "time") # reference solution ref<-c(4.971088699385777, 4.999752103929311, -2.499998781491227, -2.499999999999975, 4.970837023296724, -0.2091214032073855, 4.970593243278363, -2.500077409198803, -2.499998781491227, -0.2090289583878100, -0.2399999999966269e-3, -0.2091214032073855, -2.499999999999991, -2.500077409198803) t(rbind(daspk = out [nrow(out), 2:15] , reference = ref, delt = out [nrow(out), 2:15] - ref) ) deSolve/inst/doc/examples/ballode.R0000644000176000001440000000260313136461015016771 0ustar ripleyusers## ============================================================================= ## A bouncing ball; ode with event location ## ============================================================================= require(deSolve) #----------------------------- # the model function #----------------------------- ballode<- function(t, y, parms) { dy1 <- y[2] dy2 <- -9.8 list(c(dy1, dy2)) } #----------------------------- # the root and event function #----------------------------- # event triggered when the ball hits the ground (height = 0) root <- function(t, y, parms) y[1] # bouncing event <- function(t, y, parms) { y[1] <- 0 y[2] <- -0.9 * y[2] return(y) } #----------------------------- # initial values and times #----------------------------- yini <- c(height = 0, v = 20) times <- seq(0, 40, 0.01) #----------------------------- # solve the model #----------------------------- out <- lsodar(times = times, y = yini, func = ballode, parms = NULL, events = list(func = event, root = TRUE), rootfun = root) out2 <- radau(times = times, y = yini, func = ballode, parms = NULL, events = list(func = event, root = TRUE), rootfun = root) # , verbose=TRUE attributes(out)$troot attributes(out2)$troot #----------------------------- # display, plot results #----------------------------- plot(out, which = "height", type = "l", lwd = 2, main = "bouncing ball", ylab = "height") deSolve/inst/doc/examples/Daphnia_event.R0000644000176000001440000001077513136461015020145 0ustar ripleyusers## ============================================================================= ## ## The Daphnia model from Soetaert and Herman, 2009. ## a practical guide to ecological modelling, ## using R as a simulation platform. Springer. ## chapter 6 ## ## implemented with 2 types of EVENTS: ## transfer to new culture medium ## moulting of the animals ## ## ============================================================================= library(deSolve) #----------------------# # the model equations: # #----------------------# model <- function(t, state, parameters) { with(as.list(state), { # unpack the state variables ## ingestion, size-dependent and food limited WeightFactor <- (IngestWeight - INDWEIGHT)/(IngestWeight - neonateWeight) MaxIngestion <- maxIngest * WeightFactor # /day Ingestion <- MaxIngestion * INDWEIGHT * FOOD / (FOOD + ksFood) Respiration <- respirationRate * INDWEIGHT # gC/day Growth <- Ingestion * assimilEff - Respiration ## Fraction of assimilate allocated to reproduction if (Growth <= 0 | INDWEIGHT < reproductiveWeight) Reproduction <- 0 else { # Fraction of growth allocated to reproduction. WeightRatio <- reproductiveWeight/INDWEIGHT Reproduction <- maxReproduction * (1 - WeightRatio^2) } ## rate of change dINDWEIGHT <- (1 -Reproduction) * Growth dEGGWEIGHT <- Reproduction * Growth dFOOD <- -Ingestion * numberIndividuals ## the output, packed as a list list(c(dINDWEIGHT, dEGGWEIGHT, dFOOD), # the rate of change c(Ingestion = Ingestion, # the ordinary output variables Respiration = Respiration, Reproduction = Reproduction)) }) } # end of model #---------------------------------------------------# # Moulting weight loss and transfer to new culture # #---------------------------------------------------# Eventfunc <- function (t, state, parms) { with(as.list(state), { # unpack the state variables if (t %in% MoultTime) { # Moulting... ## Relationship moulting loss and length refLoss <- 0.24 #gC cLoss <- 3.1 #- ## Weight lost during molts depends allometrically on the organism length INDLength <- (INDWEIGHT /3.0)^(1/2.6) WeightLoss <- refLoss * INDLength^cLoss INDWEIGHT <- INDWEIGHT - WeightLoss EGGWEIGHT <- 0. } if (t %in% TransTime) # New medium... FOOD <- foodInMedium return(c(INDWEIGHT, EGGWEIGHT, FOOD)) }) } #-----------------------# # the model parameters: # #-----------------------# neonateWeight <- 1.1 #gC reproductiveWeight <- 7.5 #gC maximumWeight <- 60.0 #gC ksFood <- 85.0 #gC/l IngestWeight <-132.0 #gC maxIngest <- 1.05 #/day assimilEff <- 0.8 #- maxReproduction <- 0.8 #- respirationRate <- 0.25 #/day ## Dilution parameters ! transferTime <- 2 # Days foodInMedium <- 509 # gC/l instarDuration <- 3.0 # days numberIndividuals <- 32 # - #-------------------------# # the initial conditions: # #-------------------------# state <- c( INDWEIGHT = neonateWeight, # gC EGGWEIGHT = 0, # gC ! Total egg mass in a stage FOOD = foodInMedium # gC ) #----------------------# # RUNNING the model: # #----------------------# TimeEnd <- 40 # duration of simulation, days times <- seq(0, TimeEnd, 0.1) # output array ## when events are happening... MoultTime <- seq(from = instarDuration, to = TimeEnd, by = instarDuration) TransTime <- seq(from = transferTime, to = TimeEnd, by = transferTime) EventTime <- sort(unique(c(MoultTime, TransTime))) out <- ode(times = times, func = model, parms = NULL, y = state, events = list(func = Eventfunc, time = EventTime)) par(mfrow = c(2, 2), oma = c(0, 0, 3, 0)) # set number of plots (mfrow) and margin size (oma) par(mar = c(5.1, 4.1, 4.1, 2.1)) plot (out, which = c("FOOD", "INDWEIGHT", "EGGWEIGHT", "Ingestion"), type = "l", xlab = "time, days", ylab = c("gC/m3", "gC", "gC", "gC/day")) #main = "Food" , #plot (out, which = , type = "l", main = "individual weight" , xlab = "time, days", ylab=) #plot (out, which = , type = "l", main = "egg weight" , xlab = "time, days", ylab=) #plot (out, which = , type = "l", main = "Ingestion" , xlab = "time, days", ylab=) mtext(outer = TRUE, side = 3, "DAPHNIA model", cex = 1.5) deSolve/inst/doc/mymod.c0000644000176000001440000000200113136461014014706 0ustar ripleyusers/* file mymod.c */ #include static double parms[3]; #define k1 parms[0] #define k2 parms[1] #define k3 parms[2] /* initializer */ void initmod(void (* odeparms)(int *, double *)) { int N=3; odeparms(&N, parms); } /* Derivatives and 1 output variable */ void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] <1) error("nout should be at least 1"); ydot[0] = -k1*y[0] + k2*y[1]*y[2]; ydot[2] = k3 * y[1]*y[1]; ydot[1] = -ydot[0]-ydot[2]; yout[0] = y[0]+y[1]+y[2]; } /* The Jacobian matrix */ void jac(int *neq, double *t, double *y, int *ml, int *mu, double *pd, int *nrowpd, double *yout, int *ip) { pd[0] = -k1; pd[1] = k1; pd[2] = 0.0; pd[(*nrowpd)] = k2*y[2]; pd[(*nrowpd) + 1] = -k2*y[2] - 2*k3*y[1]; pd[(*nrowpd) + 2] = 2*k3*y[1]; pd[(*nrowpd)*2] = k2*y[1]; pd[2*(*nrowpd) + 1] = -k2 * y[1]; pd[2*(*nrowpd) + 2] = 0.0; } /* END file mymod.c */ deSolve/inst/doc/mymod.f0000644000176000001440000000221213136461014014715 0ustar ripleyusersc file mymodf.f subroutine initmod(odeparms) external odeparms double precision parms(3) common /myparms/parms call odeparms(3, parms) return end subroutine derivs (neq, t, y, ydot, yout, ip) double precision t, y, ydot, k1, k2, k3 integer neq, ip(*) dimension y(3), ydot(3), yout(*) common /myparms/k1,k2,k3 if(ip(1) < 1) call rexit("nout should be at least 1") ydot(1) = -k1*y(1) + k2*y(2)*y(3) ydot(3) = k3*y(2)*y(2) ydot(2) = -ydot(1) - ydot(3) yout(1) = y(1) + y(2) + y(3) return end subroutine jac (neq, t, y, ml, mu, pd, nrowpd, yout, ip) integer neq, ml, mu, nrowpd, ip double precision y(*), pd(nrowpd,*), yout(*), t, k1, k2, k3 common /myparms/k1, k2, k3 pd(1,1) = -k1 pd(2,1) = k1 pd(3,1) = 0.0 pd(1,2) = k2*y(3) pd(2,2) = -k2*y(3) - 2*k3*y(2) pd(3,2) = 2*k3*y(2) pd(1,3) = k2*y(2) pd(2,3) = -k2*y(2) pd(3,3) = 0.0 return end c end of file mymodf.f deSolve/inst/doc/source/0000755000176000001440000000000013561603554014735 5ustar ripleyusersdeSolve/inst/doc/source/sourcefiles.txt0000644000176000001440000000225613561603127020022 0ustar ripleyusers# LINPACK dlinpk.f # odepack # https://computing.llnl.gov/casc/odepack/ # http://www.netlib.org/odepack/ # http://www.netlib.org/ode/ opkda1.f opkdmain.f dvode.f zvode.f dlsode.f (now part of dlsoder) dlsodar.f (now part of dlsoder) dlsoda.f (now merged with opdkmain.f) # created by merging DLSODE with DLSODAR - Karline Soetaert dlsoder.f # daspk # http://www.netlib.org/ode/ daux.f ddaspk.f # Hairer # http://www.unige.ch/~hairer/prog/stiff/radau5.f radau5.f radau5a.f # Derived from function DINTDY from opkda1.f dintdy2.f # SPARSKIT, Youcef Saad, NASA Ames Researc Center # the file is from SPARSKIT, while SPARSKIT 2 is LGPL 2 dsparsk.f # brent's rootfinding method, based on R_Zeroin_2, itself based on NETLIB c/brent.shar brent.c # original files from deSolve authors errmsg.f call_daspk.c call_euler.c call_iteration.c call_lsoda.c call_radau.c call_rk4.c call_rkAuto.c call_rkFixed.c call_rkImplicit.c call_zvode.c deSolve_utils.c DLLutil.c ex_Aquaphy.c ex_CCL4model.c ex_ChemicalDAE.c ex_SCOC.c forcings.c lags.c rk_auto.c rk_fixed.c rk_implicit.c rk_util.c rprintf.c R_init_deSolve.c twoDmap.c *.h deSolve/inst/doc/source/ddaspkcomments.txt.gz0000644000176000001440000004454113136461015021131 0ustar ripleyusersKddaspkcomments.txt}[s &ql4Y /ߍ̆c=o?g է\5_M/1/FW/?ξ\^i ?-_`U4*֫&3Go!^N=]nL>k@}Zy +QrbPTr'&-aO;N/@7}؅7Ⱦ? '·z;*UU2 vE*MaBȯ~Iw e䎑cd*rCN?ƏI> $%3-m7ڤ}  4XgR%’w#~i:4D '_uuD|K}p_!xݬh 033g>,Gx&sJ@LÜOo.G G: ьxn,z)Yс_t4JYA~g< G#3?^5C*K^ =0h+p g"PawGr@;0.ϖb,Xպj#En[gj 03T wu  C5pl&;h8nYPNl*+m6Y]` ]¤46;I':McA$tӃϖY9H,RNb-l%Q `BD W5ypƂQin < uܜ~T?9޹G1^bqK} ,kDga ,poo!Ms|$WPX1iz_P尤v%KV!+;k~”ȇdYdISO}m0R:~CMb^"*@34=Y;YzdJd$xdݕ[y0/Old4&ܱ Nok2 (uʈ9[>ȇECJ$TFҍV -/d!R؉naK{R[1`Ꮴz~GeGke&gOC0u[d#GyLcp}[XUSkJkdHvMZ n#2`5.ËGTֺ 3y_GI `IP$I487` Q(E@Y)]"g نXVd$ihexYŧfD W5Y 2KJ$3ꖨfcÏ0de4q7΅G7V c-m"#m~V=9ɬtƎ#M{O`Ŭ+T&)˼ 4ndȊ8 57,׿!f}0J,iM 7jfRAoKE]Q i?0t s7ijyXV3qB+ oC֎ Ʒ6(3C+0bM2O2+(*J+_1rn&YׄG߁*nH(B?W~Y}EG%ё1 NWqH`VȎ.CdRo~zY/W4ۗ_)8eRo_bY=,,zW^:B =|=,q)^QEZXqݳV.PaVQzđT v`۰ $t%43_+EĚՊ F|nԷ,pr}q\PI"Pn8=I&P&Db2 /tc$a-q8X4c?=hn*=(Vݧ*=0UG&V5cz/dR@R 䕆., zZt9QGy=ZGol9w}A[Ȝ]]⋈|ԁ',e`ƓUHv|b.=u$uenQf;Iq!UqODCwkW@&:TqD*!,\vE'6=cs]ѕD`1w&]&e<2 "φ{(:42CIypMօO.^Tbb2]7Bt.1'%|Qc"6DX%F@m0P :𰲯+8+ǽRy*z]&M%A~ B1z=+`T} Wistdܴyrܐ#S4 ypF@0[@=xAl6ګbaV9*r~.ӉHYS8MLd_'HaF#Osv}"M䝮o$JKw`W'WLV()SKYǍO^cd7yI{8 +B.H(,Uƍ7~HoOS!▩-/kđ)^&_d0oMRd[PB88ʇQH(2Mf)QmrT T<H8k ð9U 8i9*MpFQ086s0l&4-W,JqV Fym&9ͱ s1 aFRYZ&*4T6d++oP": " ;9l;zy S28p`zd"2{$Lt%CtH(MMi軠wBG MoR5HVxo,Y gd²L|x`0e51thͯr9 Դ%8s'EupuWOs7R5T^(|tBxv:^Ll"1R>8WtgAGQ]ιȋ)#V^[XRMQ br2i׭v:vz`Щ be g'< ΨyXN#2*(FV]yULb3 f ?r'0M(\6ɑ a(Qp0ewu< Ԗ6'M'ơ N N4LLPYB@Xu/2`6P;<)Qy{>Ç*~2v&)hd?Q6A>bݓƽq2/?!:"!v(Fܗ <.a tǤ/=HHh@3y 7UҤP܍۞bl&Pu۾Ha.J*8^DSbF/M9ab^7]AfUb(bSOP"-SObryֿkeļ/=ȎM T`:vXϣK5%PF`B4 .TKPbCq/n5 sij2?Z- 2"Jl@9 B9I1ZVaK9ATo9O Z2UGSMbt3GeVSa O/p iTNdH!&'5ḒzbGߗA+lϛJ`@_yw9y8UufjmiA ⧎bF%#/>^/@?fy.ȔUs%{~:T.Vߣz.^Sp5 ڠ{F?tld&HBDgbr%SiW?.4, GqjIFoɬmbߚ1uBH%ST| Na`Uf)=Y u_cA$ >>ۮl4ӡC6-SO:g1坳)<`ƥ4fRT*Zxtr+τ)nN8='B#6ʔ:t{;P;Z|~a4Sp{EGꓱpEcH,Z7FI;FDq!yr&IEc=2YJkHp t0CDTz[3m= !)Hx_/qB[|ZQeR7&4o  gS^KoRI7줽V?FR1=N˰oק [d>e}O6*V8M|M8N= n*yY-ڔΛj("mMAKE:ΧƄ) 覀#$L(~E4U9ȯH09̬?g?zs]ٲ@1X``z@*e4 ԟ8 `b^UyQV)1 :-pzc{1"vR.2s5j农#Uւ'&]qL0ZH U7]rFP+(g>SmzU x;M 5Cs$Kӄ0Ȟ*C%9>rnE9 i FrZI:&;)XsI2h)W4XmdSۮ9{ŭ$2mHLSGy$KA9 vJCQB*Z ]a՚kܝ'j_૥rxmny)KOn~v;Aa~Vgܿ !J7F`yh¶v͡&ާ2jUf֍&LI?4* Gkö=c (B!eZT2PRv1/e;tfѩ=[Z@Mt"u@"<|YC` | 0zڗAD9ZF}?-v{U-GjW]f>WI܀\/F9?F@+l*&# ܘoR~Ɖ7۷hj8V3@(nouInUվP ޤI^9#2~")&>@Sl/%Sr|rnkkZNs˩OOzEMQ]`CnR]ȟlnA+l0nw,4Qd|k0َs0eT"(:2$Pvd1 zm͇+Љh4=Ģ{/{S4 xuqٺn~!T[F mS7t]MsV) N{i~z*|8_!+TG鬃47c o_60,~K$kqoM ȡֲ&ar]y|cA)|? 'Ddh-fJ#C/둹)# @a-/:$D 9{R"_.c>Z|t.Q+iSzƲ:\߽u9|еp|'uJ<_KEH%LR3&ஶ)4 ӯMލD'Z T L@nd]n@PmCORIs1[㓌te].+XP2m'v9:_"_bZ_&!(~#" 3M1c?MF#߆Ua.Y%c ,{D*JK- V;!29%N6M}ߝ(~[%L;4>h7]RH`-c60uqj_*' _Al5KT3}簫0u̢L{eW4rثXS!0v9t_K]mm)PaMGZYa\}8˪R6H}F‘ Pm`[9IAE=l\R#~Q1Yof_qИ& ivsP}^$%O=nT;,Tg 9m$Ήj}g4ҔW؏pHZձvIUzRkT=P*?oĖcl8 B@<~<{W7^3L^եE>W Gwcg&c} *mk<֒K"6MMꐛE_^eϩ_Z:5DgoT(mO;}v6#G=g0ghϧœ_vCF JX'gdcAev}Tp \Əu2_!^/a3^JǶ3W.˚c/ZzJ5 Òl|$?!!9II0!ZФP=POn@Ҵ7h++S9l+'z'CJ?B_n.ihmq\_L$;oѾoC@[m9qο񾤰(]3hzuxU^[=n}w׵οSug'yCx;p3P|d^̽`dGk2uVmhǹoT𪼻 u*HYS((+nd]aQHLV H+oUK䢨O "H\׷kw xU4Fzpkn-Yl”'7tFMdKDV6nVLV,ŭʰߛ.Nu'w)t`%ʻغԘŽ%wze4R"s{AACh m߸njC iA ]={i;Ph N?o8IkiU:JT5]RM/Raz]@i.U%Tr w^RցGQ9&loB[y*.DXDJrUmY"Ư; EMe],:Hj~= Nn2};MMoi[aot?Tnݺ5Өo7\.C. ٸӋNKL&[ ?ţٻ M x"~l@ ?dR7턎;G>pk=(^3lN`gF6ZRHSf{J$d6R/Įk]@RΥ -=yhAے-5Oliܨ. aMu]G/C۴ƵD]1r8r3a>}' ??{V,>Oc FFͰfyZFGiflV 1'`rP}vdE'k5<zd.mkYmv)L)I V~!U7k<r$YD_-^kvЧ&NP I-pip^a|"|[dBq]D(OKjB~[J+aE])gF3ǥ2֤\l"8*gyy5@Q$ ̳;TTHpܼ!m4,Q3 wɚHD`e&p7̇:l0O%k"KEE}tR Kmc( BE/&wͫya&T~{h@e_a;qV{A} YH|)˘]gn^B{[R:G]XЏW>\?ٸC2N;Xf%6)bhqu'ވFyi{1Qb{dqL|z_/RKN2$0X]R0кL D)nնBTFcQMaR٩)jܦ~y!\38Cl(Ø9 J[FIIUts 92u)…āǺ>pfFIŋ+BXuI@JK d ٧AL8ɦ=Zl7BF蕠kώQͬ(=>/^{ b]+; 'ZӹֱEX58@#8.q6h-_B06Zrv &eʄ;Z=c!Ķ՞# Vx>1?b%?8诊k?hyI6xr' R l*Bm%"nu@+_k=a&JۂONGc-B\wUp$0oSo6qb#˗ȅI\MI m'ֹ3V֮6PĚCM{EBն ;<7p௶ @k<R9m~?'{ Fx5 ƓabPZ6ڕJwz&fպTWHm&{LKe! ʂݻ t:(I EA-G &Hj债l%A64ehmTvnМm5Z_.1 *OZQdlVJ74A^`Դ5x:܂,߅n74$n1lhSA/7zpjt{X꽍,]_Z)rP%[N}tQndP}Khݤz4+7c*`mJua>-(&Mn<[RjF=PiME[zY tefIgmOsq./ ;Rv1*J%"L*b t9f1Ä6էܾu)o:[u}yav6| MfeLV5mC{O<˽wx컳 X+nn'u> xzyzB# <0d6s2_𐦓<9V[t,oUch'hQs4Qn[ϓ8g}2nS#T:aK4?,jP3=ݬ$ΜANƒj}LiAM<}5)ԴWnl"/_4vMdgOnO(%,H&=h5)sQ}!,x9KI8S8?]X |aw_pv5{kdgϺ+Z8*eG$ /koWZcgΗ-s~jRgghW M*I'55lfnkVۯ0tuރñ}]L&w w%^v%'4P^↺Y6&E'94.8RJtNg(`*n>cu7`!u%]~C+ 7cB|Jeb0ϰr^($3EίTEԊ{*Ko5eumt~BJхƁ[g&9ÄMnj^%l&+kmV kjf*G?;]1cP~]4gȝo߮3i*'&iWuGJ }*hvU^sqeNuByE1w# &lGuKy7/zUvꉶ{S>Ef|úa[~&$@IzB${নH"UHΠ//t 㤅{CyƢ@Q`4TA,BDB ǜ"%ˉ}$Lu!oOGuHhS/j/jc:V tE\i'TK, D' "3Vvڃ YGmSb`/%]*4fL0պE]j /Uϼ,ɍ{NliV~/ЯbghS}0 IrWVZl)ED:T=3rL5e(0ZM@Vw}˴`p;"9PO3sE6/ML0vWk^ wazRxWnɖjQ(vۮo|<ҰLyHݷ~XO[p4me3(4i*_%Dᒥ%l}N *ʸ%kJ45G)moh7JnYz-MUϦQuBc_ԑ<8rH9:Gvy.q_vl0I*@ i gcu\ْF#8+aEw*+s*KŰUY1U+QDT[^:m O* &Ḓ С)Lk?Q=[xFڑlm?z5xQɚaO;YdkJBrn1LɯjvK\{;bAӰVSMFEBYGL$)ݶD`Yjʂ ^2i8 d^t~ne+-]dX`Eq\*lRku^o),nD-r9/`d}W|S\[ N5빪4s{]\D{Hzoo˯ t&V  ZZ1y>٠Lž IK D~NDcx֍m @W6P}̩OT~?!t.>>u*p3|s&`vwncߵą|:~w&D$!ym=aӓ d CSFl~=[vVqyI@ӮB~3uqImk.󛴼3}yDݱ* jQE*ƶv0"@ލc{3$NtxѨy9C÷\Î^%~ί? Ndnʖ%C?꼹Ν|% 3zҨJ77"V[  E4]_^4(2o+ deSolve/inst/doc/source/opkdmaincomments.txt.gz0000644000176000001440000020154113136461015021460 0ustar ripleyusersKopkdmaincomments.txt[M{Ȳϯ'#4H|d,``|2^  H$0U-3ea~tq3"nFO_> o"{%XO'o F_*$^MZ^Dabt- ODE4m|9I(o$$wVbIڈ%h*gyy_ŪZǺ+-?hBMsւ? 5?nݲm_uB ~uf]g&'!N̞OX>> 'cQ{`4,ŦM|<}Lo`:φ؟!_wHLqW^ -1sgLW.w^l,z-Qƣz ,S"DaWi-1jtNi{,|C,/7b/cy~}kw:z:'t'G1{LNxRD&D/XBE^*p{HǯUar $SD{D'\ad˶3E$Q!Şč׌9_Eq*vQ x)b/,?h7te᥾d3,D((|"ɖ. _ގP?p烧>&^O|~Wp5/x+ 8*e{ߋ쫈eC[/.L-Bi7 ]kWvpaFCy^s(pA] ^\V*B6T5ng.ď~NHy``>1")"y6MFfr?C10O>\${alS05SLFZkcO<ӫfcqiY!K%r#E a7J!OCy84S,:Һmpnhj>JS6gE?]? OB''ɠ ٢ıG( _T X)#FՂ5䣘"Ctk*'_D*3ib9r5SGGTIrtc9^NYu&!{*ABoހAdrׄXpH*܇ÕqH J`o=H#(1n#P։ך6I=503fdoHƚko wCIRZ+ Bd8H o_V!ظQ!*Q (^#:,:ERZ_ͺzur LagAL`W8Ŧ +"Y$-G19L\@OI{HR%37-T2i7 J,+qH%ARϡ58`  \R@W)'r'3EB]l(a;!gu{4B&n5^N`hR/>ȺaFu@Bʄ?̳A4{/7iϖbPnpBAbVoW^6YJ*9BARrLppSF"TQ<9(f-l#gG1 Bz>9, x( pCv[2U11v2XQ[Ȁz1`/Q@R8o=љ?BsboqQطQ-Tp8zeI?CxuV[Q/xħUb*hE Y` s7oT:OL M1y594^goϨ!X#2v#:$g'r֟?ËOy"8CLT45v/d#f, d?#kƌ*)bmWldBSVsɧZKk";q)8띸T&: _|$,@gt,U(5UѰX+JU+JTeb U DQը|g썮2 MxR}"nwUPŽ#8=T?WU*" V pU)c—S~6Dzj԰Y]5,M"F9RWrQ%Iဋ=6؍s1SUe\̓׮ *^xRajG+}}SoTnK`Sfe}zg%2sV§p+ֲߴ򃸷bll$8V\56<#'^Gv?Dn)G>ۓ|4QQ(@ljV(TPg0o͕U@8SR?R`T%Ga MQt|W-]>d}F=,&52AvfsOBmp^]9UwR>!q&Xv#Z*ӊXOOzxKXb<|yv#i-&Zg \t W81$%XTBϛi3֞ haTkiq.iRlj1F[B0ts& hdh3@VDe 1C΃x۠?eA_>gKCONiD۲ӻrDϸ4G9\<Ŕ/,= !ѭ x vAJNE2ci5+N.Duc=[r%+#ŴW%͜kSܩT8>b=, T~Rq! D#R uA'16G!2yl1 kXAX,g65ƐJZR)BSBåTr]Pfh0RY_6T/)S~NWX|פGCqh TSYZKH^hf?/R6cJSf]N5 ͸b)ёTC72QP`J=U *3U`'V*[ 0֘h|.ÐnsCZ!Pt\xTX=%*%-X3r\KQ)gDJes"h)٢ JEvt. 5*ݺfLЩX`́h`Y~ҟK,`uO>K@a1:<̢fxFdؘv]Sb%C\u,Ki#v:*YsOT04nR%UI)Mmu>2Fu1Шyˮzpe K~c4#4mpW M@g l??=.,k!4C!Crx*a) ' -PF}z h2B*~{zOkؾqzRIr u18LO8I2z1#Du, wUpq|4N *aä/dGYcbʺҿO*⁸R%F^%R !Y/-Rڌu=_u@/+H4,hԡQVW_:wg-2Z'+xblSz 㗳(rGjAx~uGywz,UӲ5XFǐTbQQٍnՊ>+t׀aY.9 C.kz*.@&|xհ/6wd0 6㲟 L71yJ薝b a7G|=72scꩆ~%p!-9ļS0ˇ(V]$2ڶNSqQm/jMsG@ a9=T% sk8$X^`MU9lD"m Pm*_].+'?Q '",Y; X>MD|aTGLٗقkH{(#Wch7#xcɊkv%>e[enUM˲WҴꪓZ{3NvqЉQ‘Ų;se0?~AgO@4͋Fg}Xlr/]5sZzL KSIeRԶ3I{o [oLR 8oL$58tA|M9ʛIEѬ($v}7 +pC70* fqsCԊqNAM};ڎK\-[JSHWj(½4%jďm *#\Ps: EW QVTL&uJϾ8nW^k٭nI:k_ZKr>49Pqڮrml;WgVPFѥtEev](@;r5P4nՖ@8PK9U˹l:~]/{5P˾(r :N%zvi׀:Ұ/CC[Իj]vzf*f.-M1Ps^́Zu^b1tF@6Or*jڝVSo8H9 w_Ksd/9;hn@ /fۀbÉ+Ԛ{Lj5M w1+gL&Owgɞ|e%yPަ!* ur`^0wWv{_BΛwe Պ we$%Pޢ }"TW:YLa|ڥz CE}<i3SKH}YjTC bb4_`tNPg~BPuSX{:vKu[*G=7a'wۍTNEdqG$eP=)]o2w߲"ksD&UM vA6mmq.NI8jiV 10rw FUH(%S_lcFdr~*ȌfFČ>3,H'gWu=AJ?Z"J_pk5.[ٕw`ݦSN>i|m͏GO]ߋQ1.-l0lTHRmẁ$kAMu&:"cdF4Gbt}\;q抻!n'˜12GplRi! SOg@r̂.XpS 춂eYc^h 8w&:qөu-d1?( vԂ-G-2 G`&ezz/DY  9͕p ][2wϾOn4aV#j5IpFC[KO&ʘ`@n|Q,(f]&K+NI[x@[̥ BձH`UijL,@XŠьTCK 7% MmsEn (lk@H+jzv44цN J'8|C]YLrk^UEP)0;T%]5rvsV1E; d3 &km\9b{ĭcS.Iea6a}i )Qq4f6%b&͡P|y #߿UIig(*#0/Yh2pB] &0x E`L$p('1jJM3̱څ+dV8F޺ᒸtgc^=_ʔaxvSPsbc"p #^xoA m|(&NFzPV$ 8).;j<,I71,q}0xqMt6,51‡76놏Y4_nNltVwLpQwF7ĶmiMkT |baYQТ?$dz{w6'EP)[ Z]Wݗ HlgJ`0+2% ?UWDS3n[iJm_f8!WQsjdQM*xےӄVۉP]'wZ1Q#I,nǚۭU'3*"_JL(TiMdk5 1d, 1^.*p,d%ݰ3rSDy#"n'z~i5p7F=Yj4`+"=ވZv Ǐ0TN3 .huJT+Xޒ6YT`NfɈ@^e9Q߉JQ[/p/)vbDrn-~y1$ 5  gK&4~avukzX2;~@*|d"jFlb×U6RH±⥸O0?©Veks58 TN6= Xlg%~b+e&Du \-mS_'Y#ɤS Gj}g]//}h dePc3 ~`4_%ЕRn8$ '/TY1DH"3$-Wf 1#&|wқ{5)j,ܭ耪 {AF;c$ W9p rS$ez2 pȻ 5W[ }"fEV=|'3u>m=l@tl(^PWcތ{떅23ʎA6N F1gwϾ^ >SnOM |KMd|<;C)~uWS譬ç(' rln㶜+˃Xc5x11- OCm F֨`@~wunUrF#:^5pG}>&c?ge`?|u^ jA`I{ DEs v'zoưo5܊ݟl}_JՔ^+KW>7c LY vSp-LU0>gbb \oZ2k *DU͔yuX/(~4jlk A9W5/b%*M4+%!͞`l;M[!Iݩc_<&hđiZbV9KKbDGtףΚ5W@q'L6@2I[0m)?uX6pgFjIivꋲEB2N'&tm |>QwXj*?!(O?i Jj+hc Ѷ'cRoPfjGE%Ʈr^R%(Q\ %YMJa]m,E%q}n7*E?RS , m@.rZPALzaE@JYp}'U%$!zT-BQLC[A[lx%W J$TaFl!րUhN?uWs8Ūzd"h8pm9WkKc ](Y0M70(쾮%ռAk_wŽzu-_WW[K1rvA,uim.\V; [l[*LO4wR5>5:"R;/["O\Π@ךZwfI*[jmuw[g[G#G)F~N[lښ! 7 l$YQQ"K;jh* kfwقrhh9a֚\ 8bC5CRGDz>2 )Z "Æ0t7⓮KWnðgJf>53 (Y-WTw;9ws8A370_{(OZO:7Qw`"yCR'foP08E\ M `TbzC <:5 +[ w8W31Doy̚VT6I4tzdMxDr2:v)oj-ǘL.Fb&N ~kB+_-dղzwO2>Vo 2:-nH-n#Ji yΑN^B$#؃Pv c!AK@0GG| ނ4dCr`Z+$1pM֐pJI%InA?"% 7oN!׃4`*H{߼ >Y ~~O7Ч.落l;'wOj͆ oh5HhAU`"\G5p񲨌\欙-9NEr*`ƋH~7D5/n )!,j:ClZfӈ~>x_'/ ]5 *܈"1YȰ \cTT-5jhkxཛྷҥhJBXZ/Ū_!G$HGOy5 xnBb]#@DѠXLb1yxVDBK\diFkalߩ~ 淚W1KI$a4Oӣy8/+ S9B9^C;Dca wZR30)ﲪ@"x. Rދ@&>LA("ڡ}KogB%3o <yk~˦苘>q+q ?fQ~RHD'K`H\4#5 J# \ZaˁAl=c7hA)px}L5|3lhMMec>.Kr\9[ɱ@1&{2udauV~2K5`E=t]=P2uϳLo'15kƣcAάK{OUG =]uh 9Vv3S VM8QV<:9 Dx`+ݙxjqH c3xS ECvY_;Xc;LLWDOַzhAW+)Z7$ 0)Xi|T[!eXv Qd N 3w]5Kb1g**=Bb^c>Gew%;@7> 4\3GQ7>4" LEvYYZ]V eC˱G=S ^X*ocο țGʻZ4:Uг4X!?"ANØx'EG-9w ud!(/ڡq["P(s" Q[}Ne.fl 9]K2\hq'@c~XYIabël617Bb$Q>\>QH~pؠɷrlVof ȡ 97r@y nդ fke9~s!ۊ':~3I''Ƃ5$At\SP\<;=:dHws'L&)N ,?yDR6<Ŧd""VDɘ|(7l*LL6_!c!A=x4dښ X d1 fA LBdm#8C\}$D&}8Td6 0hN Rғ)|nE@`PjFY!YҏUR'+7@jAT1]fpV;bbHabE(ĬuA4&hAX$a)2Hf62ևɟcDj{C 9x@gg!d&yJgR;&wH+08,\%,b`pCVȴ Z96v>vzA;j5 *vP38l&%}+2]~Ԣ ȳOξA?Ah%D1t tSWV]: .Ư+| qh ;:%O54M&5rVRxIh0%y'ȖW1Dh-ii8?bIc'9R r-s@na$C3n*6+e*?UG)89*\QĐ& _Pd/..m"<|'xG0I >u?ŞMrqE),hZs2iH)DX'IGDv az6]|5cc]\ۄpH_"Bzo.kf僞䪅M4dܥjI)qXCoY-n$kRqc]EZ/xs9n`4zu4r8r=^ 3h|dK)Gs]`$cl+1qBy?3CK۔Nf1U)(C W!(W1LQut!gǧJB;l^|>'G"h/C1w_P{;OptkA w2CS!M? vp,}6Z/u=<8k\^>]P񝱠D̖F{Wlt;u_l#IH:ˆ}׋m Bٕ$stsТ_lcj9]Ey\! Ӧ/݋PP'B>KnX$i0fWp֌:œ >J9Yz[|G`p Eխ^3?)5A% 9D=\ 5y62vAqLrg'x2V|Cor_طAeR Ԝ#EbӤ,,I:&#Q=LufqtqW@KX?rl\|_jp_0[HVOQae IM7cC%Rj-{$~8 I8p 2 pe[sY4;Joktd6f/l =mcGCnbUУOl{oS 'G^Yn ʹ]CΧSGIm/'\L#әaB̓[r\1|K˯iC"y%0TԕǺMol=nwr+2JD3^f3>W0B 2dc ,)2W%6CMv% h Ƃ&h"@R,Hua<`d(u pb9ԨGO<5>Z"J˚,Y!첣~Yj9tF򳜊H6ajrOsYK$>Q"͠ 3xm8/B 4^ m){.!&rr;4\{y8Q%l!-PFw%iѪTL k3xuKT%Cw9~|(nx^cZkXWkSU0Ìj Kip.nrGG($hxmgy|a nt.S66NMyO. kc3T31pĬ}6]P/A" + lҧo /D ]XXȍdGa?s7Na ~w(Лa'zsGm2xI XEr@=DϿ ؂(-+k1&ȠUk6aU`DxLOXƃbBPL$"h{pv돮:4%*RJ@IP¬1ftAW>9YkR1;G%L @Sp&F{3{M"\r巄Ez 0.JM'Ng6fҜI8* H..} zb|Ql_je#u. tazsT&C l}t='܌Ƙ8-TF |"8C)1vʤǡ62!$1Pɋ=>)_;ek\Іb"Ș!WCG*Ud(, q5, Uh"N;# !Se^˩nSU5Lz|rq'Y"b"Uv;06Nꔣ.jWfF"V+IaRGQ"{A6(J ;ȍm8=Ϟ;L}`!Tx|w$j+] :zk6u2m`'pj1)OT՝9 YM ;kT2|Uv.!6W#DhЛpnL*bN5;%9M"CMtNadl<$y/_>ׯKJk 7 E􌰘w8v], e˜DHB 'ԅ4 & ptuFNp\ O3'W\~m0[}zqnkoċ?. v>gg";{;{NwϽ_ Gn|Xj>a{0Pni-1uC: jZMBT+9x}\k GWN~NSˌ11:{- A3pFX = &`áܩq.%3B_Dp`/i۝cщQm) Ŗ Ӿr~$!+^׭> q%;qE^0+νFOϯ;M%tb_=E1Ƚ}[ko5f'?G??WjE]L˂FHnޭ+lk/ŷb6H\Q.񬔭*+&tAEbudۑؖN }]:yMvڽ^ z߱vHSc:ɘH i1_'>h)SXb=r3/H\c;Am΍ֆFHr ? !ծ$ޖx^[vt!D6&yz*]#ޯNg?:=8(<lEMyw'3Nj展7/'Tp{}=* 6DHV̼?ȺdPS0&MfLHzBણ60#sӿ}DzA8NbнOAAc 5Aykbh4@ G(I8NM9#9(i91Ce/&՛7Gnm驫چ=,ȫrw9" q`'e a /@}z͇H]Zr#Cv&±0lGE(;嗑p!<K7ŒKg׀9>"k۹].k,fChNyQ q erjt![3e| o.%gеAX|2}x4mj< \@Aܕ(ZØ}+wl5iaN+nߺ7EgWMQN>Ny=:H@qLd$ݣQTby |^i^=>`sO R%]nGN3qiggŇբe_=,:Zfk;aFsRe'T1)Nˉ d=_M[F3rCn;`thEc;FgmNё=cuW-3;Hw=_fP)i{})U8P,=Q⭰G偾+.] 2nrp"J]eӵst[a`9k7#FUsɹv9Inb=ę2*Њ:Y ѠN.C86E' Fv4TOfEW@ #dAËa]]*x@HTeJЃ/Z΅/>q(laE& w<\4k&T6.e ~}NvZx&9 O E'=b!La =(K]6 '- sZgJs3`Ozxzsɣ`ڞ;p׈S&'cc˹.P!nBCINAP8ΥPJcl R xs`񔅠;o0jN#hq'Ek<+ U t9 qWKun+chږT8HbF`aa; Xk\aERdiH',OWr/nYQu3$P{(Bq)pCC%sMM՗rm࿟_RȄ>F5`}eĭb  ]22DžlJS_|ڄBQuR Iyh S8Da `RC8iZfWi>_"BMusM#٬nY>^޼;R3Xn )]L*pZXHn NFJF,1 /N c Fv5ITD~烀օLA܋m|ăYDL%(Wp+!YLspwZΜRLzc,wqsuj‚7WEi2A΀<WdP9;uG$cͮ;d'JEh,\u򶘁zMX[wnף'wuc$yJy`J;rّ fH!5=&#,>0NAc/h2Ju9=)PZy! ;\j$}f=L5zNkX5^l"acA4 rwQݼ+1-"QkwƝ5n\0te訲aדUa$$3Hu.@TL>jY M3r}/Mɡ ][8(:0? .X"B,6Ó)i95;f7lE@$u/c 9_Zq+a~ YB_(݊wQ𨵓52HohInQrgY;rdc"UAl Emh \EAW{\'n?&彔F4=Kٗ* k8:c(1^fjz~t=c, WTqۯAP +V1:!Ixy2H'0np\Z*ӳQo |¾H1y9 S:8QVcE]R75[ !\V7jh갓Gk M}͏`DpTDX NB=Zo\Ff9@`@/ͷUcE},J?ܲ),FXZ 22z@`lş|[S:?>ǿB{o㹻ß;ō~s?umaǽvTJ ˿nK7}& ~䅁0v?ku[?zwd5+B6CMv]}iޡz.ZڕyO 6l6b4_kV$PHkzlp: *^+_{|qin>8["^c^j74mg Q՜aAti䚣:Lm*=J֘;@ߺCBg jڞ_/;H@PTݶ t܂)ac >wX Cy@%p#]eYsKb>P Kk*~ыDʖxEFP,NBo8Q-c PX¶VTVI%P ^srZvAL& t5ZK}ͳOG_l23A<<9;:ǧ|p&k8^[$>[[9[d ) JG GunuM|ȡg5ׯ#()ԯd=WB# mkTRF@J7fnZ4NA4eyKkC bJ9CJ'㪃{ދ֐|b skOj{=\˳acklOavt?ar ?eR @ХDj;[?[NkG?c-I:v3pFGI'tpq><9"sT|7#O*;_I=>*,zKɷ_ۮo{[6 [GS݀s7 &w]u/KYЦw+Ʌm̗[~է໻O /-j[}Eơу@4xRx5~mn.rY:P/EP9dpUɐ󰏬_?;]Ϟ96|;v_l-tD09}-;5(? ;m}u׼g$1xm=j1yj c@0n[~{ DE=S$qu_=B6-& w6zMɵco=_o!nqj1ݕ/qeж~ZYۆ^6mBϚAHe%m[vg.Goc=yoh=~ϒ&?8j;v5J&7;tL CCMδWL#}$R._.O6< d4 .nQ܊pk-[=PY@%{ +dt۵$Nko\UT|?hz~o }zA-s!Y^v2|;:aut?UiVC_N}^=o]m9lN;ݎfӍ;ݖNj i;otRmK^w]ONWA)P)l`ٰv'>*f/4`]^edڼll v0c O#_5G[;)L-)]Ɵ>S!GPaVv'Q,֐ DxMƒQx )e:<2Rcp^=ƶ[nwl:=m5VNl?o7qhVwnfota44N~ovoNm NW%Nkw]Gq:cmow"ف'ަNkw xގ l74뵁r\G*6z-@Ij9Uݱ ١vvtp8^^wvࣽ^/ v:8EΠhغ[mGKӇujMgS%N~8nݎΪEvtwzrn6n;nkm{8r`pvX>rtN`k^u4unm5vkӫI ĬgvGύCM ^`Nu7_mUAkoo~kq<㈳88;=C2ikt{6M Y_RdFʂ7EBX-7Q5EY9 c-@t! <Εa$ȚH^dtHSZQ!j`aDh`'+b@"4 ¤@]hCslKQ t@^y/! XM5:*nkJ!HKXtͼȢPicNlj[k2;`E5@*\ <bX@yP< zCTlHDkW. Dg 3b>2*= = 1̣y\H <9jc{?0&PMTfl<3o<͒u]Zԕ +t0ĝ+>Cބwi!u$ŏ:f/kULE/*O}*z=ans4b:%.$Ӝh~ZMe 12ߔPa@QC9ƀE$@/-i䧸M5Y` U2@ 1h$Z SjRNpP*CH7bn&qU$[\0TCkC./3X+\q IGDq׎ݶL簅8tJ'%4'q[aԆ1[Vy9,#xl˱iAx 쫕eiܔC]3.&i#/,53Lx΍,7`5oE;Wcus^rP=j(v@l $.ff'piYŇ*35Z-n`LaUpR7 Ż[6;x98f ӜA IƶR DJ9%_bȑv:|Ri//;a00)܉Or3'YɐXL}53.gonLd 8}1`ΤMO+ 1UV\NʹG,(BՍ3!: " @ŴŒ`q{yx[NH0챪Y gSʹٜ7p4E-@L kCc; j$:ِ먮 ҅e2 &ZI)',夨Wc)pJ (Ƅ5Bp'UHҳ &msJ4|~ngx/XwƀȬ|)>ta@ #$~e#n!hUPS .w p!gced>gWbs̩%Y wī"UP1R+FXm$6ɚ; +4CX\M3ͶvՄrcKUac|M<% V`̝mxhGQA&3Hb6x``mYzC]|qNjKfX;%yPF?&[tH  "!6q8j6uB2SG[@Bf8_.EX~BSD6J$plIP+(i&VS5_1jeet)_#І'ۻϹz'bэUT;pYí_g%87Asf+o@s=ZV3QQxelHX.BBMi,q(Cs5OH$~gE]aGji|eP?8fp; ^OؕhêYDHaD,d qȃhMbP:*ӈF)R]zPTMecKSۑo?زP&W3aʿۍ{'Bz|2B%&&d5iMt4NbId!RD20Fmάnv'YE( @1$4X* zQۆ[ qf8"0(NFo5;%QdP@o_P !x _BP}%Vp"XYfe4^(QSt0'w2*~%KN< ^a 8Z6ZF^B4h{Ujq3W1g]BŸEcd8p\8pKSeY\}qY}PqK6S̞苩aީlpkJa( KU@ ۵*/ O p4OSʙ*їh \P=)20k9WPKC#_cF-h nA#ʃjU:]sFFNMKŇ$ke!٤yA{"aJdcK YΩaٶl쐱PT61k;1a` ;(ȞclwR듂%'ؿA͝o)*PWTƘAh]%#mFj6FӲYGhjf _G XsQ!Bj38[2j]J54/8D;UfpG_!e `nS+ /'h5q$Ǥ +AqPsQwlpo,F[Wcn &bƎ4E,I$\2]MxdE5eo0D I=ZX6P Vr\Cd*Vl|jh[@?pS1 ,ekX"<7Pa뉨[ά lTh}pnT)A4,K5\XIFl!'oN?0!8fJmv*V9;~P=_uj/++D ٛeEB.`&^1v.Z2׷{K.mt^F6b&ڠ7-"q5ɯe ^.oAGS35$I8. M v; #mb!蘈KYܪMz݄ld/܇ 8+D|Uӕ~yZ #1"/Pi ep/5ݔAѬ!`pdwbIFdRZȉ^fiŒ=$F5/ JH/%,Gj\l s@|` rbp搉J0q-y_'̗a,B8p'?HE距f[t_͘X@"ΘEM3k),WScɏE Z R# hBpNJ̸w6Gj&SA3nXUCBL}>?06h $P1WwJj4(&"Y!D 0^B'!&Od>6eqy[-hrְ*dl[vˣv+o%#!$}" PDR ֡&.R` @ `lb N1o|Ȫ+A2ԋ'D^~]z("<)lAwEwuRfpOMZ钍z*ߧMFg3ql#es up Evӫ dy F$Ѳ5Id3Uka>l#00&g: } ]lح ڪm;p;wPߋ@G?P lO"[сr 4wBdbl њ K7{0ygZ[s([X(U)n)_lM] QhĘW-4EP0fڂ+Ŀ @rCY+o .TPj 0WjV 9Ádp[mH$y·q`w,%4>H$D넢L 10vstnܻe0QZP 9e,>v2>GGA)F,YF}4lBmch<[%<&B6k=h. BK]ZImA50qܫ÷ 8Fon67Q tz2Q4-9/`ȍV vll˛WX#*>|=Y.Rm:Y͆ʼn[gƛUehBoC,Xxfm9q;`ۄ(';c'/NWPrqċ:]h̰@<ϑB5ޓ7#3@ʹ=ޓQt mpJd9fyz0ⱊ Qly3%"LwqGLJG۩ZjupUmTxĬk];[71;.̹e3`]3 *zA_} ,P\ .+ *Ԉ4Mz?&N|C]}/PSA`,[ qX`pakfƲphQRKs 6GV鳇32"y H0;["3y.Ow+gi?{5\;2JM/fTVmЖ6Tӭ$p魛ٌsi ߮@gzxA%J*'c ɲ"eô~$r|aKhG]"]}XO1<Ocv`Z.Qp!$"X?c'}Fە ! _bA8j%\o+ʏ9OX&qQlþ2%lU) 4ƓŘQ"TB.͂WNҴG<uٝi޽7]DwhS6>UH_v/1ǁ'ݢr8MH6*--:)wL4x~,0f<&&2O qhu/ѵbCҪ) az]ujI?x-p.(S|i~<|KB\5}oa}=GWA{3,[$[.[WqyW XBNg 7^F6\M] KqF ?`7nhf[^uǍ~0Bl-7c'>:im09g>[Y:u7)R\MpK.#D (. lU#)-nj݁VEw B ɱ=nΘr׆+{xuypvո-?|xĴkp`iUIV-Y~ŦT&B# qNKDlMbb_:&ŶI4yiANw:Z7-K!]5H/4, m@ .nqŝV3V&> @ e4M$Y,]$(x́>>KڬʎT$EiS !L`IXEWy_yp"eTj&>ubHH  M,?DDv]J7"@My-1ݝglir;éyv˵S1V xPŜAVlAR:,_,*nCQwyHV7YU3q \ ]^ XL9ut_VX9Du 5h sXh1jñ_H[ \6srBYY"Bq,̄BVIɌQ x[%uq@>b8 q&InʗRYgpydibo{W0/ƪz긓ԱsTyAd=^4f 9◪`n-Bi#Hn,n v6;S^ĸC|*S E(#U.]QbFzL!C0Ux) SïƱ vY>&UQ<-4JoVf6U 0mI>u"[Ĵ{;hhđ@Wqt?_dr9fZ.ɕvPGE[PT'7F% LC2jI()d>YQ((tZL)dU tɋZdS*[Q(KM`Y+fdh(Þ1X|@Rφ;O\& /1ak\=QriSD($ Gʉ` Ҡ礠UHVg0o'v ?3w.Ǐ/+;{d`#uLꀦ(SbʱoT ʿweAdH C)Ң|t\s= iIAȴ S7lױYO5pPeg +¾J~7;C -> xj(dٻ ʎJ}U"b*ѯQ4ã߯^Icj =:}<h65nDzTҵI'/7Mfk PV8Ma+\2G3_n%Y\P%R]čwJg偏'Qb'Ҫ~۷~[ru+0֫_/ Zn7 ͧ"w9sh!Ř2x cڜ:*\/YdV;R_kEw B| H1ŗϕ^N}~Ǒ"Sg,?Fei)`Vu"zC4n|Ķp(S6i#N :qA"''$B%;j&W!eYtfվBeQ2w/|[5eA9CДD5&kNLr <Ǝc48ýisQ(UYVqp#9ٚj+ ã=?-3`Lo}Lo<7>1հ3b~?z~Z 2vkf(o[" Zk`'Zs =VwO-MzzzyiWv E!"1UJ>Gd3 Yv;6GA]NڨqR +sPd?ga`g ˋa_ZRYbHt>Z9R w#wg! ;JCmdJgCnnwkX%Ƃ6<_[<yv~ufϏ^v{ *!7+)D)op{{pf!D?*"1#*\4 ='iFm#tTsb=(n_) O8 m`j86NM$, {d=Wx8)γv"x"?;OLB|"KEw?x2Eԍ.['&[tIzƕAEXDޢdA3M&-ш{67WȞDxy<Ϯ9"7gb?"wN Ö^G+N w"faƑty>_,7?Ni]SbTLs c+ 6h]iU~v56C=3;#˯%v*LisInh5`M}@ՔBs/Zr}( C;eQ1\TM:dږܿbHsFQ-<'el/t\ʨdY"yi&0=>P: k,L.xWGg<+X m 7Yu3e&ʎ*~P֭XhefAËa]̓'ʗp_? fj`\䚎r`c +#3[NU%dLkDi-r ܞHLs\I&,Z"G|jo(e$k?#1VQOEo0X561 6896kM,,LuWg qD*@z15JﹱTChkBG w 2]e+휡=Rx}v%gW.6(՛O,LnV=_>n+5ƣ[(*'Dj뭗󉮆wXvmiXa$Qh"҅͂kQΉ8keݲil_+M#wf&YJ Q O6BOl N\2KQOXTǝ=Gq "'lKs/G܍0<*ݰEg\z=SBf"%H iQ }RxCwNYFFж0}F)A# vߊk&8rTC* kxekhW])mlRbM0.@yA|5T*imDtf5gn4B @J*>QXDoZ``P|,uQ 'd;@?;7pmŒD+&ZٸO(&.ĺ\iX=:w~V{nVHcI>,[-h^C=v+= Gkwnns:zOWu#3)nF] \G7.2XPn`vS&ohy}㙻,3lvxoZNKZ.<1p{oT3om:-L{0zLjfw^4 vmnfqon3hCt3]irumTf^SLOv{5wvvl7ӗfzݽ?4^kLj'vA3{n~ۅfmfx=uمno.qt=:mjƵӭof7YNqu:܌[fh?!z}y XJw ~?֐ R05!f̉`8,2!'~AF3xb&ҁҼxBgrStG  UU}J7ǻ) f2+7Yԭh+AfQLn3zo\6UA6H b}l ґpz¬!Y0Rv~Nԣ݅7&o☧s?d@j8T bDŬE/$0PѱgYw~Om;@ t3HEm5;2;/uUTuX2.F[I{T3w&)%x 8@Y-kvwڛmC˜aSh6J,$rLr&%gJ.vFQ3%'D)?rq3OԑJ+_]>P#ޓ`;AJuxZ]8$#2b¯IKr y>[*' \3蜑q3(d2wī"@ہMkr=Ï|,$<4ZJƭNoAVJ&zF}ЫsRڌZO|ge>PpodT@7~B}AAKmDHC6c[Gmo |6rZ+)S3חb=IpP$F\SME 92l(V0#ξzx)x0n7V,T3DH9c2:C`1`șQi5 VŃQִf(1ǴaCkKVp f0AŮgE'OZ}5'y cd"ڼ9DqC5\hdP7,ؕǯCL̃WzSp3N"Sű4ו4ћخ 4'2R] la& wŐTn V̻7 8g%(jl y5jO=HtWL ,Eȕ`y2M'u)B!ݼ 8)Vײ_x(jB6$R6Tz®5&@4!j*AB|eQQ$9Wl!f⽾DE6JZV?ƖԪI=ʺ! 275S?ݸg8ZTPhT6/Rkfs*mUWw6ϭܵșGAc`Tyx\ bx$П9vf^Gu_ec [Ř H7ZBUA*lz^{STw)ck4\0l<^i ϱXMJ7*' SЈgrәdb @"yH5GU8+4\R3r3TQj}R7hcE6ۡEE2, ~߻>$ avQ+JbܑM!gzb(_0wB|~|uFsHF_X[W!>AۊHKzn߭)qb7D ˔t[HKY1pQ<_Bu)a;Xe\wBٌgss3;F){ekd|C"³7ct{5k^몙Vp&w_ԯ {&ZfHoZTQ?r22`\Oc, Ij a3A"d1Rz""bg{, H_g?;)!t5-tDqvKs7!- /,ϯ?n4Ț'zkfpe^p{2^Ci,83 5. )֠;!;NpWJUVK6iɠ6zM^nuwt_x5L6[&  Rڲ% c=VZ28@!Զ"M ĆY5t,m|d:8}|JU;*yT}B yJ4\4E$8R|x8fRӺghQuMBlmۀ%Ih6a0u__EMD?TW\}kj6(4cWuQWp1Z0c7:GRq) Ls.-AY#0Pb(6>["$-&\z牿nt6|lX:q)8GY (mEDě0r4\M9"QHl`C G FA / G4OݍH!Kbk Ӱ=CetvH G;CnE.}&} ~s_O8na'!@Up'I0.^ ܅>@2UĠF9`ȾWuu1ܡ#UQp%0Ƕ(sIMa(I/B²mVRn;Yx鳍n7*#fJ+ :~ !?#X+*EV *d:axEP uf1(ʪ`#ùE"OXLb1[l3&$hƃW6"M@EZ "Bz7T8 bMUrdԧ^Dptl $ (hb$9L,K(BDp4Q[TTrl+#K7# O`E^BrMdiϟR7/Dsŭ gs]*:4׿:Ya$meJD֣̑MDjJ^LV3xBN,}5s/K&Ë]\x0ðH8$$i JF W>NdpPTDdL8d*$@bwBt#|8 1ms!~FؘwX-wˬ ؂;%aK8E_sF  H3F͑|h4EBV>ANs 44'ҋ] \ ҒΓW !< G_HPy r;5`Ř>:t%NIU9"5)0Q%,B_#,يЅ=gh9 qZgs* I']!7x ئ(si$`iPciB`DG$G#6DB:fs$[:<9Ha%O@*l%[FtF{ 1GVst%fڊwKdt(_Z qͥ-рQC s:iC.x|@\&Py-WC57K' \5`Us8[Um&%,$Fv{xPRO. I+ ҭfMn.q'#_NW8/y249ЇU у SJ((U8ePDȺUD<~J!D[yB/n@EsʱX]tJ*jD7#5"j R p"7~s@z! sINqbfiCulnKX]]9]Ng \wЫjrAbaC;ش1Sh䶁Sf _@2(ǠL!ʠ$vQt`t )R԰X[nDЊ8,kH;zZ | Lr`׈=c<&ۨ`! N Hxx7 G!Ncəh]g8=UX}\@H"z M$#$EKN놛GfIatg>t=i4&5lQ9P%J6AXg"(o+i.9_+icx9x#'Bb N Y , ía? cT2Wi^W\rؑ&**lP's0,/=S6@TŰ8{pdž9>tvŭ\ҧ^ܒl 0FOJ"hƯ_04 |?XID?9zdZn*Kё=Bfeh\Es!v8#RGor=~2;(MH684p땫i+3sPOq )W`!A2k= ùDZ"5&#I\l8FAiG;4=ruti*^2#cZ#ThNS'/y,,qk;1n׬!DD )6)^ӂ۵p[f:; b#SΠ>%rmj#!m^)-SI#( `0^Ψ>:J΢/h}[Ku* U>Sʋ|ﻝ0sojn=]n~tɽX rLz _[yC`9dmuA@cF7A(&`lBdl>E/:t1cI0Re!}'V_.:rp,!;՟lGZl,ű"?М[ɋMaBX`(7s?aүS f1g ,Hk]ͨW==/ַ1RԘS[ȣ =*3>4Z.b >K_98;8϶Vvyz:iNh.;|mUI...)1{  (:X8%cy-.CeQe/jWG/ ?rZBv^WNt>]*zN3;f|m%ɃSIy?FWwiKZ2n8IZ1GTnn̶$0gǧazmHG&0 +q4Ce+k]F3I'x^K11 E3돩K蒌]/4rd@:\0) c'&޺1@Ā {xuyp߸-?|x᝱ LWIj WB#Aȱz$3ŗ/J>ۤ歾Qm-(›n Ɏ2L@Nm^ӊ'RB܇vI=Na/5Ĺlj*\>q I'/Wa$3(tq⡍>49,NB>+Ci. A-L x2/_}ܹ=ee:+  `rGdUx!'' +$v|9파]P~ړg\; Nu/[.WR֬EEn('dHҴfUaILFR!xuVR`_(Η;Cɪ'3)/-; 5S`W#Y?)R-7e.2sX'jñ_P%yz`>71ѳNF :qLH :HɅhqkQ7nb(au[svc{{bjpMp>D: F=6,X΍;eM 0DV/[Ch3Z T'Emv蹧Ͻ5C\]$A [0k$tG] FbEa6΃[r\!Ώ\['N_c=&3 yZt쑂[7-:kT ncQ*sE7 ގnˣ^^{hskX3U,XVdgk!;*3cuK(HFwL'3[1YQ(4(t!ܜ[)?kug$)(1M|Y H`(Uh"5lcu w+ ^<_0#}p?K(%} ll}vd,qNzQpԭkD:xvbWº? ?_ٜu9~|(nx^Q쁘h;GSDVB3yGUUAlZxکJp Jh9(iA✾0)*LQM{W[\@!-M)oSa`ܝ>҇ Sg{tl bc8J(NI*<%Ef&iƪ*B,qS%s5fvxЫr*Ku>+<h^74~gdRBX Uo \䥒]DyEq7[s{_,K8#ZKEgY'Nn0R %Y O>\˝q(9¤@pYN=<lL0QtW8n-}֢6?j1Tu@rκLFc@2ó˳LKAG\Qzk͌+!1g:!>yG& $MPoD~ Zv}Vj"XG` 7U.e ȣ9rfavcLMt=@dWT"З{ tV?KT-/Y !@؅9R-r͎sJ8ɼjz-_T}Kys*xx/9p %z\WH/A)J 0{|(`YR)"p{;in}TwkPtZ2&IvwtHwj݄p9ظ4+q|"A?L A8<:9 r:r ZJy,.;gh }1GCl B'.,?ފgN0-N@(5C ,w)@B"usAh;:\?͟f?M%!VQ` c@)Xpm?t~e[z<\x7fuVp-qkQ^e:i0phh]хwk1h۝^4@-G}d&;E;8<@`;n{7⷇/?9uA+(An]I2xxEWM0d/qT~;&qڈ"9mE.Dgj##&HNZw#ӝԹUޕUL:ZXR!H_oQ(bwx\ FkHe o,S|zEZ3VeVIUNL.Ž2Rd q$\@]w|8{`cGؙ0哛9|W |wr>mfOL+!߱C;ķK-y=ުBkP i7Fn%N͸/^; Ȩ u[P0$eL3G~bUyQw9bW@uhf7{qNmʭ/FI rMb'Mv9ѿyv"q({Hq\ ktc(eB-Ѹ=;stjt\XEaAm؋5Un!LO^I׹1Պ:Wvz5;b1χljBcÑRY{_ T 9s9/7&~'$-UEXzWl`T1顦2R9^ׂlxAtǘuEQM=L˛HUHG1*a^|s-9+%)/ŃxydIZI |0@;Rp6oP㞳wjy}gNuqrQgQKxރA+7-}"e`ŶlBr `;@sZ<gO"A"Uϳl?@nEv>=Hr>_,7?Ni]SbTLs0 }ԩ[Ubq"9W$?Е+ #7K742)٧&Y~ր7if آ_Fl!5v_Lv2uvYV {“>CpFhaO>?:gW燻vgWQlѶh$jJMwٗR  ' ѼC3D 17Ug{IU%;K gI F~CFH=m-HJqJBBTJ%/]N7XH R\ŕ_d7/usAvn7[1u{]p[0`gDŰ|x`IUn#@5N;p^U&-Lߚ{4?S ox圾9<'Tzȿ2 9G-L%ǐ |0ҝ1!Q}xj$l = OR k\*/<'Z#./sU@1-;-b b&{t aqZt66=6Ic2J3 t2Q_WX`t;ߤjS / b pmq!E%CMHh!9 N@ kz̹jzK Z>X5MR ],fJdL)C#~#%pw3@B R[ Lh{r=<;5pct/d[U@˄f~μ ӘBѵM4 űK`"X-*_7CopX}@~ba~S<49 C*Lm+D|ݝf<7y9hZ㙁e@yʆT Dg+=*eX@ dmTj :kwLȃG_Xxntq݅c Bʩ8czd2^?LBb'ݞVx\F@Z9(^"+ \ieAvKDBd +-FXiE(_-)slAqt;@oTBZAB^tyq1; &T 8exb8 1}#LFn ߒ#H)cu@PNK쥿߇/ ^ﲎ+:My=nnommK$q{S|Aʤ0vu0!4!`~9m*|ց;X~ps@4`Ass\&#ĵ4H::̜ 1'5ٍ.t,4?@r\>/ CQc;ﶛV/%a@:s]yƀwz&m:7:zvpnw۞{HIŖC5>,[-Ceq+IWyػ}c>Z<h @u(r^pG |hS݌:<~<_?cooᑚ WᄯiǞn7c6?`sg)wqi9D}b=nx kmz]iAR~oMSx;A7!և:;t^Gͼm}39t[~{{0fZ}:~kuhz}64 hrRo!/sA[&vA7ӓf:^gog@hf~l;[?4^ktLj'A3{n~ۅfmfx=uمnoҌ{l?pxs7=7 =gwӢ,Naagop@{]y[O]Lwowdu:ގfFof/`M Rߨ=E~.mP9'z\rͶzjͲNzB]#n{@ޏAU8 _ rz]a.I5*#QS0X5VGrgaG{sDRL(r/MTm%&rEQW(:6kW;vݨ6X'4XhVHtM $HsEgj Q㗄Q!<ّ惵Dz0U?`!a# Pl2!pƨ+v| |M Dg<>Ygj=D06316x#s ZRrI @nsO$?X C@ ``;9WR]9Wx؍K@9gu58'X&2}TaH&-t4{تjgr@׋rE7Ff!0,u1FQ%A2RM x OVdp!YGF! H̍9Ky8DtSY mп vT )oj`*=5u I^rfI8Ǫ2O?߾+ Zߖ\G1iI/U^Zc t7ǦcNʫ!ba^`EHAh $Oƥs*mͺlj)D;r8Hھ?">\? TROpcC~b.ȘJ'%4=q;Z2㨟JxڮfiWKc' ոpF&x^qnoipeyH DCr?nJShgQ`$̃.-G4ov!&۱ʼ3/ڈq~k(4CEbexcЋQ,˱x]Z81|l72d ƒػTHDF6J}ܾ’n/ar/ },76ĥcD&րIf&ȭjqeKͥDĕh;3}N^+ :J/϶R NE*-qQkC,E _^w@$f'Ł$!5/?q+#AT7yP#yiyS{e cʬْ#$!$x3%!T 1=;FΚu8iq(Ӄ ђ#//TYxΣ2^*Uԏ .Aȵ!3,.i*;'1 k4A@m,t_Gxr-0]_(nN|p]e7g.! lr8Gmz400Wd&DSWk D9$ vNJ8Phj:%ה 74hT4v+Bqs(@"Ͷ#eh=E 0MccU*UT@nƷfkFhXsO _aK,ƓT}ЮЬIjj`g$2I,e<.w ]>C:1/%ruC9* J7;7{fd@qц t,ʐ=!(@T -mRb} ,IC`3{ |-kscuV97!%Q`ߛR? g=ns!Jq RMpBs$T]DۆPA!n MXƆWǹ8uHEYVIen4&qβjQkLK,`TFl%1Me М"LLd沫Mj R8kFUN7ngx(W`w|TE^0}50H*X(r88su<4x:ldB:#^P" nZ;4hAU( ܺJxMGKl>۔J&hT\[)[A޸fdI:ju?}cx[G?&[tH  ½8q8RmP*<-ǑI[ ._+ ք5ބ}6{ ΑR,6 ߈jVhd ճȩOͲ202ɒjw[= 1N۸bR;uvI poJkP7G9 =VhE{%' Gؓt\ ylWF]SN|pN'2RlYb* wE xP~fYE ڰ;\H^ +5@Br\`)*$$wGT[ f›y2g'u)Bzl=P`"6@'1{2_(P@)fp ;43J_( lOTK$Å+[Ŀb0j]=-(2)Tx *Q64u`\_dc( Ӡn3,Bz|J\I3uu5? &…@k@t4NbIcӑRC"FmnΖ'YE("3JJP`0 7Hm_Ojaѻź &"gR ong_bQoB;c۽(?_U6w ׉`]ޗV,~V "T6R Ÿ?\knjIC ַe R,샾Ȗ9(hͳ]a>$WE:0pbE]^Ⱥw.@/嶚A"I.`/ZuP`r,DRz8!øC@hЛW<,s >RRhܵ1,Ț,N Z;{;+*qE7S!JYw!Idƀ"`])VXcJWãϕ!r2D\K@)"F"OT%@j %)4fvL3nURln`[iQY ءKuנ'5T@;(x+k^p.W䓍5\xD -aS\ bC `h p-%EtGҐShM&Tƌ%1R|""ug{й;`{s']P4Njt7Nߞ}iruJ/o@+[baF/&7? +#Dӳauܴef5@ ws 0/ V e'nV0Ϧ_Lwt v.'wل]so}(ۯ{!2[~%7rElPh0|.HW9?SR F78M,JkSUۊ^k6[[0+.Ntv.mkΧ |#('PQq #Ԏd ?n@pH?R^pDIzߡ1oF)6QB_myl*%JM$\$ï8~ ؟y+Gaܨ~gPws g;>C1j>ZA=F@Q`p1"N0 %<:Z:"Rs'ZMLRAàWӪF^oOҢpB ΥǘsVa(5ݫ d(#V$VF82a 5R%#ʽl[!:&  W)%=|XYq<ÍQf1G GDOȧݍHyk k/ =;~{R%8wv*J/-\=>z/6i2rzA(`b%I&zΓL'mܰNlf,$SOc&03q2DQ^> q?;́X;?3PB2 MI״~$_f8c&,W{j:VSDG7 ^䟸>JI{=-86`ր8cUFD8dF:ysvWbauH-HRS8u9dr{W91w HnܰH-(QZ8O$ӐBq aԒP(.bH:ƅ)Gj PrVFb_[e.W)Pi xv;_-ojLe~9sgFê WƳIIB4>HCDC ` 8xI8/bAU0yh.7>{, l& q% s w TA?AHנz _XHF$%Mlq80|gkPpgs|_Fd:F43|ӃDP LXR!ޠ5l:8&onDTx6̐ R%? C*&(~>ͻDY2j7;sj0j:B:xv&N,5s0K&Ë^x0CH_$dieFk ׭dpRT'D(\ޓѐ&bv,#K*_>PDZu.|am=,B>Aף !`!p+%jxB.chRal#(A-HmIC @Qd0n*&\M@S7rDF 4rrາ3v6"&*p!Y#|O! =K{ h@$" Cץ,'Ϋxnl 0Os[.Sd(|H]-I""\xPgIPIC6WƇTpWn5`z64H$q%Cd6"L(wH_ sCg- b 87%k)4 AZSdKDsZ=W?mw**~%wC&9o{Vx63`& lEp~'Nt%ABn|>D 5̙KM㫄 !2>CGRO gaCW?+?]S A[&#lU٦n%&/& M\]xPROY@Hw%/QmhWvJ +a ࣄqĊY^o *&Q.% Cl \Yˌb J/S4l8D:z+OA|cCi$^yx:w $\#!S"X<#H&U2SFhCz$u Pܖhﺼ >'I¶'27~ChPJ(#ȳӣs&$߁vb FͫxErd(ʠWLA"׊$yQu ꀩٰ/l1ھnD܊,ңV$Cߧk/)9.W\bTdj A,C+ Rtd2ߒ1Nsɩ}]g<-=3C4#Xo j%H"En &TlE1##*1HkN3,[b.ѣ!z)# $i 1,tt-A ._OSvy_QS1ՎX4Y880C!TAKң66,ʸ8L \@<9WHHu T> !m ߌ t5-u▨0iַss} Z-{6(ȰL$OyKDlƯ_04 p+1`/ #vS_)hheL75F*Z0;q%/XOy&IdMDU١T/DQSU?̄OTme$P&)B]=\ktG7(DKm"%۱2dG,"PYS e;aɷt9 BX/QUDnP1D`cnbTO RO98;8϶Vvyz:)N/;|E 5K('`1EPXP&FP1a01of }+yM: ׫B;5ی̚),C{ O݋E[1yW/??=4N7cWcE&Ҵr/W*%>RtxmB[$mkfTuS5ӻaqC3?nqKXcp\0ќs\qVaN'-)?~,3ȑ-$U𘱙$j4`@6 ؉Kej}3J.ET*ξbSf UG0V$!`*Hnҹ &AM*K u:h tkN,Pc[a~[0״"J /4, m .nqV3VTAZP$˺$QbB_10q֢K,Y᣼$@F?>+Cm. 1A$- (<9>D &DM|t/2Ƙ)Ȕ3wS|*)i|z Lt)ndvC=yv˵1Vj] Qoˇ.#J6^N2$I[aMVaULFQBb+njҸ&hZxyb!adC1ښ`Q猦 h e,]iBrs"$@#ߣĞ FFe۝a[r\a݉7ty#hNpB~53Hn+%6.b\' ZlUuSsTJeGގn ͣ^^{XթA^k+25q}..+[E\.Ljuy#+wCXR{Sɣys ͨ7a%VgqL~u< b:Ep}=;*3=(@aݽ"k(V@ꇝj@bSOqgҝcA$s GI'WuK]D!Q.(2sN`dZ-zNʎQ;qԯkEz0~2ĺqH0x9~|(nx_QhGGfDg/J*WM:8SZS^efa1FAc P)MĦt|$BZzfn>&0ľOE9և#1"ޑ<"Hdž #0.O-.O7{7m0_y*b(ɰQ4ã߯^őiu5< 04.È]otTUϡxJ4ICXmQl~1sjk䡴.*-z_s#pn%$T1rL'EF|\Vs~⡴GfFꆯe&@ !Zܛha:N@aYVe`4@=,%>yxv~qy&I)%d1[28&1x!-rĒ@D> #Xbїr$Iv}nlRi zDTY, S֫0֐4fd~D>3]uMlX 瀨a BsŎUJᠪt& 0P>"_ GGgҡeeDxGt fz] 㛃ˣ߈ONo\!Pt]lpxtN;팫`ܬa:.IdR@9Nf+|2#XoV$ pKw./>?d6}vڽ^;P Y= ױoO?Nz8L砺 /5n_Pw.>V&J1\KH` 8A\;9=*Mȷ97vxt"屣W1 F&DopctIBVh[跣SJyq~jpo tv@֋Pd>] /> uݱnxқl0c*q8"/Ydс7`ZKr9?u@ _ 'G!?ggv1waeV8sªs2E1;ON9џfYY3zi4/ DJ'cBQw E.m 96T/*#\牡LqgVw B@)ˡ$QUx-Ml@GCj5s]!G26l9 7S0Ћã8w#vy~`.=p=`]I2xg70/q wL5Ml!%s:ߊO voGF M%;,1/0cwܽX'IץJڔJ$ߢ$uHdFZRh:g.S]Tnv1UU-دӏYHRn9K)2^Pz\!0hP~,aяdeSolve/inst/doc/source/opkdmain.f.gz0000644000176000001440000065140013136461015017323 0ustar ripleyusersKopkdmain.f\MwHW& 6; bpoKh#8̯OUwK-!d޻:9K9 >d0|#0߿b/ƪmʏV\#,؟I7?lq83/hj a0yp3w~4jr;ncnAV?=/ܫj:??08cP腧Gwӻ=xž6*Q,&" r~F {)ؕo%RrPDklG㛷#{I DE 9$MD NF/@&VE*~Zj0}`,(v Vuu7?@jNnݲm_uB ~sf]a?N wfwk]g4-Ŧ@#kp/>G>t8 ?3 h<[<Cܖ'u?Col\o Tl$-@$):{B^JY^XhK}=FX)Px^VwH$z1fҌHD;y0}Vc. hSZOP$hZzWA _“F`܎BhZĂ{ObS|-Lt;^<ď8"(W` NLW[M4ʋy")^CZFѓ>ǚƙDDzxg$cRq:oу5Ų>@Hh]0)іKSBjv㧚Jii8?7kI$_>BS4ޫfcSM M7!E 1[ޖPwn뇼ԇ}+Eǧ vI~) Eh4`v;ߋhyI2|Y%rjOC;Bc) {H~zu` T_y~Z9w fNSAۛwu?w.~:")/ >PUi.?jDXW hSpL77dO9̒j5u͟Z;>>TR9`NklF5/a&RHH}B  aplJѕe&KT]k%/#Aw,~Lfe_Xv*?CJtTS3cFȨ8:segיHv\֏B $"KJ~AT ʳWϻ<'qG>ҺmpijKU:gEy7GQrR Q-j^(8v<`v1Ү ; ѧ(g_Ѡ[V7 r Gc OnQADlZvq,k`Q @:n$dO.$QQ7 ePC[riׄ7G1^ZQԞ|:H S]X[$ cL 76fӽ)JIl~s >}3́)5oH}& )/^ͻtm|~;|[;8b7T >J"Z((74Y!*pQ[/:yR Z_:urp&N,0ȀqO3f/s&OR PL,9 UX$5G19L\@OqNfXpЙ&r&vnQD"_1Xt;Z_Sۓ[ П#P؈j=yl@ }N JJf v2ܾ1e:zHr E zWIcrj4p! >%tqE/e #Xf DBA`V/WOby6wjf2HJt3̺)K (K}qi1t#gG1@jdGb;a-5CbZmd0!A ~92( yYj絷8:(n>>uK G/LSc1Zei H|J.Pjg![ZF[׀`3ڟiBeXpj97?^q5Csɫֿ|}SJkD.G@+g)j2}yo Ǐ#ǴqԖ==L )<@Alg=yV˜^%cqRA;e\L!ʐ4bZh ڇ SfƩILC 8vr2F*:w^@C{ItޜT=Y*+EVERL J!(*,%,; D'%]&[J#8=RǍ?W*" V k,d˩[[?s"R9jh|4,Ox,u"noۇS |9 [2m| ιUi\Ẓ J^xajХvƻ[1թ-(YvY&/0y-YCc,0Ry\W^{+Fd*I9h}ka໸y D&7T`Pݮ눌 ſrgs ǤTPnJc#Jd3׈2xҩ\z?lDg<ɑN{_.>}i9(eaS6d 6Sdv&5RAvfuOBmIw2^9YwRǙľd+-O(-oiʔ6^AAeaz̖ty/N(Pw);e+X8 I `-pLp*Imm0؛Pq jJ>k GZB`fLTrJYW38e4 JT)ڄKȂ++B2>ah `CZ!etޫ=JQBW,ބyd2ojW]$(2Z&9Z?)E(-dGLYCƀsp_z3vq _p"EtJ.,9pMrZfSd[Z#Z5{ʻ2)y«[m&J n`'lpEWtĀ@f l%*,Q) 5R-HBE):Z%皀 rg%~(߬s(y1g;'mƼ~۪W-6\W9ICJr-X4 N,g[mSRq% '}] ˇAO>@E9~t-%(LLV,Spx-:T&ϤOi⎬.UVx$f:l({R&q:1܊ KgX֢+G~d9YntjR{>T]e WU((@T>1%l#hNj֦OiXpTgFZAjLe9+' 89w1 ¢?_[^4J0'0]Lj)DcX6#lpClfUh-{xA?]KKv10+9بݭ*"Hdm1zA!0E)Tfv@ a9}5TfzKjg#@tAn4ev$T dz!sʷOiz.fP!^+#˘Dt{()6(6Hy#ez%> ̟eZd.UȲW*t3VVΑiCV] JΥY9#A>TJ5h7]ypZ:9;CʈD=0nhW?p'.YՌq+=:$;siܑen0Fl>cZo;˫4|=LGakͺr~Э"O('5p\xtӶ52hff !()ʐK}35+?(٫h-ƫ H @b(SMfNKiyɇ=c_0,{@v&ioQx`*BfK ׿6&%|wAAd=o=-r ޢ 8w:=L?ăO%CBt*:2cÁ`MBq8gPEaxҕ %jΗ:yGzmG饪CWwh8؁7_cWXJnM9Н}q.ܮײ[v~u׾:Vk6sf] nv.%Pnv% \6;ʞ\Q%Kv9jiYOuv-:vq\%r˖st$Хk7[=_N5_jk}Qlu^Kt{/ua]\wٺ%:nEu5P]L؋ctЗ)x۽d؋zm$e;^p: p;r3d/9;hn@ /fۀb+;!]'zj6&cZ[aȮ>W5ʲ4f_/ʤGCA,,%wV,VTIi%ڻ(N`JN%A/e ʮS3_<]LoȸwdF*7 [¡} okBRz7*!N >O6=W%< v^]..sY U(]{|1SUj%`k`? g@#WD]_ѫ/s]݆\K5댬f0=aB(# p.r6c>9o1vtyIng/{F 1I B1r9ԝ@V&H|f E8Ge _k>3v7;:4tZcawHNҝj^ra)# C@PUc*z(ʻ@9|cKWH1[TXph@&ޟ ~"3lV4*ȝ?F@̳$P3̰c"vbl ^ obBL(pU|˧c1T*15NP/#)%:- eO?II 14.S3 wBxu2MyIlǨFb8q*?܇jƦOVn:o'VمEr053':z7 (rLT#;cƦsO8-P|!_tX.)gH;-@{F P?Ͽ^DX(\9(+i_4K!G.Tzt!Xј.;x#I ا>Ixhs\ !?vE`^hJGtlCgA:Υȱk`D}ew 3+ TWσ+X2=V9Fzkλ1Z^7A~r,9u@B#3DsVrNكS0ʅz"g#.![LeSy`♔!ֈ#`EycbAby-;[}l҉aRy4Xч΢6WE&n㧱]}ߝL`GtKn`:SH%sJc &Lsr1YrR˴J1"h { MPNҪg8 vyii]ao7 8H'+,'TVWVcf^)5 g7e%i-WԹҴߨ&\J=v."Ww?%'t]h2*RWD5,v:'mCVZٷ1qyHvsNeG|tOa;X:3 )JJwE#ˁ C R{}9G ԔT]!zQ] %sOU= }ƧdQ2V xV*U TeeiO_2D!H EmSuRH[='AOx~oZf 8}[UݒRuL)"` `G!"[K}cj7 d>*ijg 1^.5HJ8L!4ܰlSr yy%"Z3r^Ilz[%=' =% 5Y1>V%j>~1~u)cfhf)*`cDEEhON Nd CZpEs5ibPo0Y 4=DϽ2,_L¸?,!Vxm@$k`8⋏d$4~UٺiSa;?*~7U՘UVUjo>.Hո2%`V*%QP3ʵKC᎓H勨i~ۅKZB'IGgnV6DfGfcC΢zAʠ&;nn|yOzQ l?"26cBM}|džؿA@1ҙ7%^fwTQ&|CE"! 2R3[E%E\R^^JW u떓? J) ́5Tu%O-o,peNWIUNi/ؗ'Rp^E])[ Clwazd:#[k,"MS'd[N5W*b}-AƖ{RtqpDYU/ à mt. na ) 9Z%VvnC%!%X J(V=WXgVkk\'lz~@]]Rc^v+ -D2<81aC;fxT8#\/cs_GM 4dY149_UIC+yLz#i+*>ʕlQl9jGǕ}a pQ`0EV[13Þ9sw'HTwSp*G49_g/aeg"zٰWg3Apq[XRՌ9;g U!!Vh >|\WmtTJ_8VWV"AUJL|nYA3Ӌ_UKXL$M7[O0C Lzv~a~z=sWJlkhOҝ^ $m+Ȏ7E\`&8c!)oҖZpGG4K~xD3KHWV*v,}l7E95T M$Je@c,'biUEw" Mq@ 6AyN5& `*DfpkJ'TI8Ÿ|B $YL\[fhp!|4,J!~H}\Y֓Jd2<٨p35駳ReTq/LlX?"I~6Ύ'썦KQԡfEc>BLJCT!2=^]B꼆ԵŤLP{U>)J*VNJ Z-wi,±:X렦*4Д.Վs5h4$"_V8O7|7r#IB'"Eyn-.RKTt4}NumVIfZq$R3p[Ee.wk9LtEeWt^s'Ie&!TQ ^sN7"H;ojQ=P*:I%Q x,jLaLP"@ذDysg]|05\zmDVayƹ'luiܬY"CHGp谐P܌.j;$>|U_9 :>Xv3L{f[0TЉ4CWW@lg<峢!02Ц¬KeI +1> @DiN_~M=驦'k)G - Ky~*|I%(U%oMEL$l%#J&|C^iiEO쯀iiU*UXIN&2E|qD4B4G u "J8\](+h=J! 9r+@6Yi1YaS(]ăN%M@%%o\"iJq5 d  ,FdcyUrMC[NP"5;"Y:kF ZƠbj D:H"Un<JAٕozeu(X nnrt9tvp7eNn8""YT[9nī,j%͵4n(bEBր {p6Vm)/*H֑\sqV[@tv%Vf}(3Ԁ򚛇?FORVH}Wp 9ί&p>}Ubal]9*B EMJ>ptlC%T20Y@8;8"!f˱$N`!J,>bz#c-bUD$E: e3V, "j<*\Y|1΋#GE?c"9f?uK< lXF*έY^C٘ :IkyV߁zdHa#>Ҥ(gUcgj0 040(͊*6{_D5|>5VV%UZŲ]ߛB/o%"wHсbJWדeLJXMFǜj%U7 X +-бi01˝Wm ;*_/4t=PgHIUsefN ӦVNpEzULT@3Ԕv,et[a(Ϧ^wTNUHaˊX X$LDKi3#X 8CpSr`f|wIaw >5zr$dsȻcM&yjA4`{24854]$ SrFj{Q8ȨPH/EP oblݗ%OJT:ҜXyFĠp އ< BcG>ofkm9عdrtΩMGޭ&?hZjâfz,Y"1<(Wb+wjx'BWEuEaюfuSD: 6 1xѦJK7Yx|Tj9f9S{_,bߓ|J0GߪVwUz[m6L,F+}pu5cխq\,1vL0%@-3pU2}Y," NﹺD!*Wy>\&(2]Ϋ66z^gQOL`^ ޑ'鉟ڬ%\mkE싊u8^ݦE: v*~zSsKfj nI>.Dj 4%tuxS@t junʊf E,-2u2aڲOk7n@!.sFqXaݜ I+Xp4'mYc>KN!fj )հA 舀.m*sMwX$#}[1dZ ZgX FX6qg1K5rd6}F S8hyVVQ_ "0C qe% jiES iG8WX]m(٧U}{3jĶTG1N*m~nDWC,zJCOG<8ctʆ!1!.gMa,t[.F3Oo5 tc&y8G:nH`OL!g. j³O $Yx&i]&"Hty5L.왤`=?h#Q-_].Ɵ#?ȆB::ô쪤r:*m?'Sqy ν o[^1hD-̚DR|+`cGA`x𛛌D/ZG^x6&5Ę筩HL(phLX\{/ L k"=x׍?~E 7й?#$# Vqdyp%EvTT4\*sϕm2R<B,?#{CԲ)&8VYbV],R++@F)_r) OEVaQ׋kݩFQ9ӛ/A0bP9n1Ffzx/YSy򍛺8+*k֢YWhx~iEG~ݷx1^wg!|8?*mH2t-}Le5Y38z%\f[ƪ|Mp\;"_V,׆SO33S(vv|֯b肀C$hVVc(>ngzڅ`t}jOбXknɔU|} ғp_`hu}zz߷j=/P *p52n;Nn=IĶ<>X:T@lUZ hӋdIO ь]%se33-tUҪt鞬FGRxhwuL͉(S$ȓqn\V-b*̙a@xyze%W Og8wLIC9{0";Tf:)J.r $+#ƷHz {lcõ^n#5Ւ,cƐ+7 җgfA&jd<]X j^߆TN rj.J!j&KWWȒ2" xU2&rlw_+=% 3C @(W;)RSXUXikX+;)@Wk"!s|\RE4z^^Te%F )@kiH.wIQFs buāsU MQCeWD:yյY&; ߯j^13kCJg A<}%>67 y[C6?e~QaJ<6tHl 3Ch[#G+H9u%Y{θ"0Δjni0a@Cr3$Z<LO% 5֪{5Pʧf[rYl!fB;*7qbQMa! -No벱1-fPIlIlOء) ; FE0 ,-TCôѰC{jOW_S(Le2I8wj-4##)oxWVn̼8`hkmw)@|wdW\+1,=C#ȸlHhEE "O_=ئTE'SPh㧅+PMGU>Jp'!焏6#wUȄR8j`KM{u!؂ŖxX(Z/2Z%H+i(q<>`GY Qx)&TY5"ѕ?F,DWPpDjv`f"S= ]r)s^Q>ĜcB # O[!I9??^%ƚ$%ζLD r)l=0.}b}frԚꂀV"pDܥT5Q>n,ya^D-.vQuE*1QZIFj[,zOIVC?ٚ+݅yhtyNRoUƺ#,$m1 tb+~&a^4,ԭmøOD1C.)g6.,1 ltE|yNB&/,JBPfGDI??p1`+l_qP_/x[3}~Z|ң /!S{;{Eڣ2Wt Ehs(MJ<{[.u% aEBNV[BVUSy .8MUM2Q4JHxoӐL9GZzoT{:JG $9=)$(K^"w6^Z8%~uz  芎u+Y`S3 Հ\lsFJ͐.'}ϯH:v|sOwpE%yMx4ݽbmd_Z|7 UE8Q0<، 0mLlBde7&ߔ0xN!Ԭx-uEaYV\Gnjh2tsNuxn6X6~1ӈv=W;="!$1ϷkUpl -[&luټPVqEP`YeR|o"caS"n VbTU;Gcި`8h2z w{/ sC疺N#[X,,$48񣤋T-pr9:it) r~pڇW"^)Z~@!ؠ o{%z~=i9|A_:J*nKMDrZ (Prn*z%# Go?eQyBA "3::OF[kAvaLbe^bfX0 Mb$ұ("[9?'Bv8/;50n.fvݕAM*RTwqiB6RS FθZ1폿-QhHqxOw*{YwE1 bAV%UwUԲYQҡi U"ZavYFSVe@Ko. 8amr&itC~?U~I@fLyJ$o?C"Ծ/_~ Lh9v KC/>t3hLbG\-z i@b}  WD: TeMqc  #dIo0% o%H8 ML)y)vlzA`UzےiT9@K[Z!y~" Ig}AR@[{?/r)ΐ`bY٩,)*:e>Kާ4t_力'%(C;/gkIzLMtӂR7,}O7q7K?>l6e>4W-y2oz8BI(`Թ DH*! _?޲N*Nx פ?fkЧglVE_4iȟzgG}n3Pk9ڮ@n6icVtxl _1B%Iv&yz6,\oIq Y-[xg9?WpDjW݉a꘺w-OMPq2 bTo<-_XIUc̢L;Ur'm) 놧B 8qBk^Ӏ Am*4ij#LAQϕ(le|ln)*[/yٗ8ۗϙFvV9QrBXng@A < G#HKx;hЎM[ iLT_bS$2Jd{>` ΍'{yfw~1 `W."=vm)sYMCْOpĩdx9;~L2%O{(>v`a`}%J D/n Jtޟ&GPEW1hj ~ɗHzvh#sG|a O\U(mCX],1=螵 <;[E1~c6f 4b^#8mM(9/XPZh#u-W1_{7&B[1+7I`oB;N(, D,"fw( 2iMh|J{6, #~Rj5CEcR"@Px+s[󯷊F2Ms)Quߠʗ$,XF]5YFWlU;*BJAROC4ѯ DF縜ggezܽW zy-͚̆{ʤ|ӳwz;8 7"X C?=Oﳝft* ‹DU/^ 5<5Z^6;&+OGDlk;g.eA_qpóprr=Q{ zr= jUL`# VpWCe5M}:ԍsΏA|O5ϯ Syi'1%B_;o`8I:DB=1Y|/_g 1i$XNkpt4$7$3H W!!uy{E# ^9 _ HHvqXazlJxi>SD"R}Pw(Mñ4C& }KD2d"-J5ۥjp3Zi'kdW8R2s*b~dmV}ó.ޢ=~EQDMTj W2~Tx+7o5h ( i~}E7nxe2%)H+N3}g۪7ꫯ[c+zx(9Qe&Q9ѯ<пnƎQNAQX“g0(E_ #.OJčm+w+68'zrrHQ r1Uw#<5WV5FGo:U|_뷲mԒ/m }=Ȣ1(3tBu[=Ta HTF-%v _t)Q0PLԍHfBYSƔ;녲ؽkȧ%hÆruP ׻)̤`a_&w@I^3l9 ObRL׀NY:ZȿיNN>[0~֮G J{m`/(?>rw?.k.Z(li(`$f=8몤?u`Q YOȒs !.r DYLRgI|pr /X΅3R>yP Ȓ O4aHɑԮ ,}1Y! -ʪ^H<% (gU}^󅏍 0FIc{ ٞט(tݘVMWeUyz1p[:^ y[֩&‰PhF_S]1 >q &۪mneonnC}N#i4bEE$s `_fU1&0mB9$FғY$~P#\PgsW̾WG9%Mvƒ=e~jp`?|I/3palrHnSs rVPr,ojr6ծjjbv/Fv pZ%ީ -HkiVBeǸB7D}#Q>hg;Mt rڧ+KV6<ƜtiXdt+{7)X:_d#Axh@xѮhxLG rBλ(> w@QaC"#* 92s9]mveB$,=)rg5Kave7сf,{VEWN-yq]0@c¢tʝA,̃gO mvݕS&k (u }:Kyb*vyN=գ4OǶWmT k{ǵ 綽[nSm:-U7I؊M4uF&(*ɳ/ҥ1U@>UT j*Xh@[bFZg6HV9WL2іjLbH^ "JV8(`liU߬szXVu7~Y_~R +XWi/BuNk]ыaFXBt%8E#<2 CsSP)B#8 rG4պ'˽ 6)\(TR6~շ/yvg7I,LK5E|L" ez;cvumRM+&txs#׋hZ0RdA>X`ʮGvL)>^wAs cvYh9Pø[O!΢* >>pkiuEЀW9UL6-ܨR6nj0i^E"u!ZzGNE!b?ZuN'z=MzT&r.p 8k AAiRNdz6_MsEY,HվY@M'#0.sae6_Cyj`5{FFuDBǻ 7hb&>; ZC?}N 'OjxS7}*55-lP=X:V(݀= + lȂ}r}#Lf%6R1r )q>'a^P(Dї ^p=֛IHpiso8c8d~~]@tx2<[IjͯE/LcW~=rkun$¯pW? rF8Hs@Qm~aEYx#/+WDXU HଞH:ڼsdOqvi"kbGNJ7)+@Og2/7Yo!(숗:5cd^IA:uF1n8 j,,G5)m[gE\[µUOni8dM$D!:o)%o9q6^d޴*1u ?} t׆`YM%pmjUlV2g2gߦ`>NBg.c?:sLCe8%ƹ "$S]ξ/tM}qJ,h 9?hӥq>ήu)`Xc1b(%?MKy\WF!Ypa @p2 YfwXZ)0|Ї&eNG/&䰴bjM_9<WLY S/7^W=*QJb؂ePŰiPֈ|"u>BQV\KEa쵱pZZKb*jPpRhC`!V![Q NObTM+IcrgǧF@ϜT4 Nlیүנ+|{*A[j=郷Nh?M'/ &,h{FĐQ1¯qWI .2F{z1Bd)wf4tطF sZsFƪ z }%6=+t9ke.]-Ϯ e>"vPh*O|¤x $2s_D)Df+BHrwr/=5ӈh`  ^7/g:KAOz5D9YkjdN(TXf>0d*cD`Q:$6b9Ve%B2y--p-seX}gX>$S/xȟ{gDoc/o-kSkvt(Uյmt\3Q|1_@׏??zve tkǷElZfGB;VhCyʟTӮno< ();bEZsݰxSu*^ѲR.ޛOv=KOe:{OvGcQ]'9\%;<*PM2mDR4_HPw-n!;OVskM/SD`<{DWёF_o22k\jeΝoZ' NMpbq'/L)_zij0]|yфmUZU&,0' C_3zL\[Fc4,8ʤtኆY&by{;]b',ε 9WK[btqpDpMNVYKV7ǃb}T%a"Sht #[OSudS )Dٶ+ S8I vCÒ9biv͕҅X긺'tնsZAbssJW$5Amk'xY)?,F;'< z?eCͥnhI!hY}Cân˿ vXzQ> tj$<ߵsM=NNF5np䦺{Q3BXQa'fsVcco ߓn^Zq*嚣gEeud4mk-[1qe}mGkVbwepBqk6vjR VVEkwңN=`#ݻ+zn-=rVLv2z\oŧQ/Grl^wٍ Rv0>n3pzV^D= P9l Y3e*w.τ4aglvFkڥ@ڍnh_;T^CUhF*w=ku&whmwv6:;-fWwn[k5v{hbrr^7n'g\59MjqG'gQfWcjnZ(;x’T4vnWQ4wv_v^\rЄhVRv Zj٭9&<9;vvy! kwSʵ[Qm7/d_mե* wUg#jw]]l]CuyWevw:X19+ʓӦ=ةrgop괶u鯝N[VnJsCK^T9vdoьsAqvX>zZNgwn^9iuܦVfr)oc2K٢٣.mMm6{ G{mDWvU):;EuvFs:nsvUQy:&W69{T No H+$ɤ9cVp!rDXjFje5#V1=͗u%8Y0Ao [عpR?5#BȹvXuj*Քbra|܄E9#QEhn!"ЪX:5&6i8p/qkhz\K_S7guOie]MwAވFXlfKkHn'5kPF..*OB&I(6- :Cz< }g`qbL ޟN7pF!OW@1N\KVlBkf{ Eb`Y(JƎ3 /Y*b-l[I`/ Fؿ^SWw"X\mn8\5|HTBK]g!n7L_+u5.eQF]vx4?![( RGsaԹa Nr PQ!vdI0*+qK("}˱ jv'b~.c]b :1KiFy7a-4 9Z Q ^ Ka~ti0 ⋔Q< TTx}Іm8veӸE+7%U8N(*xb@,t C+|'\tu1t$ SYY}z7\$N۱cLZw a5ʾ/C\} Gh2a~?[(P2߸UcKKxf[}pHy|G2.wOwZeuD m9:G3;$,;X!lŵS',NP谋CpP%4#Zu  bhnztw&N"َ} iQzKm!~rw KX0hHL"̱obW,Y7gi>މc"Nb)Isr&·M?x6g\/coTȉ4X,0f&Z&a@tV!ca0"nYhC)3!Bo6fvht}D6~0<-f<)q1PBز jױtyȺzF |nۘR$ AIh5T*஬u86E@n TJwHfE`#AJǎ`yJVtQs P?]46:pCC5T2{"<`J犎z<C(pN8pt MX'|.-@Vu뷶,6(st7ETqkUP昏si3ʛ(a' EprMgWe\ԝ"wX Xqji<&rv=As! ɿ2p=\ڮq ^>:`śⓒpZ}&$xlK(cߚ3z_rhܟڅB63dlƹgt McVBvx\ ^( C_?+U\EO>ա`؃TyHjK*`Rx" S| #, "NzZp.Fi-3~%6~_ .Љ*PlRz apc. vĀL#USfс]4_+5J9?Xޭeh|KA `xY_$P~”Bڭg&7oq]hV-^|P[W#JpVZJ *:N &ڐi+6uglO5^A<]aĪ5ƆmO DQ !$Dc29IhU`٘-<~՟~9ݖ59fym5_TmEH~day7^ %ū dz Xjl>h rj$E%cRTFT@L( ŮlkA5qPK5n\HL"q-iD`xa(MArwnj"Lu?"i*9I<,HDiR@za6ެ6>u=Y8Ȫڐ}\r6ڕT2 ;j 0H`)IMp$*q_TЧ JR"+*UOWuŌvd%[Ɂy;1'ۣ2D$]Uj 4|VڲG8cT'4ufsi<= tKtz7)'V<(V&uƬVzo63_ISL6q*p2Yvgv0I WxO4y,bx?u=}mS';N^Mrٜ78: 0ϝ[7Kۅ *3HJ]̢N[cE1 qs_\P1T~ T(ވz'&_ip̊,) a鳡qϠ jfdg wY%eB 4)q2M|~tB+Ŗ"@~;qRr/8V?3<#gJ|*T z}l_7]Oء/qʓ; Zov'$N[﮻QD ڷel} jPK+sb4+y Z[yX7m6a7pɳ FS<]=Tl(zx/ƚw9swHTwBx~XNG]aѷI)^jQYLA*,aƙS&jXPanylx=g5* '1yx}/ʌ_JM1 8r_4PT1ҥ)rM0M0Ze6xnI]*Fu R\oꎾN 4 9LfS<9,D򷂧= ZF*f%Rx8npã)gK2۟XGWA'aSj$l疠AP]S053e<g9TImۦM 2!0w#$p\s~(pj EEC(pz_k氍+_͝Џ(PfW@f\1cg+6*'V',ħe-3.TE-޿a"iAID{xh EpkD9ߊw;\DcK\V%Տejz6+Ğ2'[r><'U ABBhFl=BmFy]){\.f?0ӎ6ld՘E VCY,=2ORHy3wWѲh R ܕHaD󐷍ħ >$vDq1#K`IgN i->!`ի4br1^T5m X\7ק*H3 8wXX#Y+~4jqD\UJ,ci2k#tqFl#oN?5xNILZDLn@rB Ԫ;re͚(m!4VбF}OikVH-z5IR\G:f\IPG)"K;1irhc]ALL 5?%R͂Ύ,̲8,BoiMѣpYڸ$$aL:{+ 5~*x=K*i >jVSflVu-z(/6]֕6;F_&;h+2Z  U\a̝ G:J#WÞ 'Ue+MQV+BDMkW+L|TϊBhi6&ǎ;'6䘘IwЪM)=pE^Ǭ\32@@E&f.GN> RK9 7UnV+i|g8;ZM =2U,=H9 y N]4#yȒH;3@4I"'jtX͞mȡds8(1FU␙H002OLRTyoprίze5gO+W=,LFL{ۢtj 3k%rx 4)(k>۷X; GN-@㡊AP uHHE>w`РDH&Dws֤QDgLKMP 2eC?x y '_rs-ݲDu9a@%3hʴOneVeZl8|]Y ~c*0coӈ`>Q g/!.3Kw\ 1I)A%'{I8^-nn9&1b*PEbv]|kNpI[_F3=Jm"[xNmnшTh KmAED}ryVzg+/R?c#ըe#pҸ?Ձ G  *t߁K;#M:jDφ2Yݻē<* dX{WwhOg<;pzNQŻpKQ=XFؔw|wB@O5i72 6$PGmFiݑBiEJjЖ0x&.~fUлYIQ̅ 45>:6otQռzA,3ޮ1 (({j_^`Ű=ߓj/lx8d9V3y<}5ѕwrwBWt S']ݖ#o"7k\3e=jjC&P1\r% oKj7H9ivM=1E wO”lbb F7)ORYe8 eNpL`:,@fG^UF_5 ߒ["3Oa}oji}*z=qjT]b`cUTjeUY@p+ndSNKp'%9S0~5jrMC-o(eNĦy28Qf:q^^v&X=y1V7KO=֞ ]v߭^7S}2^f߀+kOi#_̺itA=9]WVqj/P!9sVhT-: c[Ysvg4cl`awR=w&O.ݩwsO/nOە/Q SonUsFŢL\Fe2ziZ,*.no,鱁3}҉80xtoȫyڴuu 6泶 Mb'ީu& To\+N8 HQrv}ú c8i7-X1Eaއ [ X:ne(vLUH X@(-ATFaC؃3l*%>ŋχ2Ô #C!|h\U?}l*݌*`~s-̾?BE|eQh))3u c;`Si P:H(ZIٕhAbxŨLN烗Qńz]#sMcϣ\2&YvtU-O!lj?Bw1?>3Z6bpeeyZ-*Zi+70U n\Kc8&wG  ]Tΰt3( ' 45k^X$xUw1C8O!ZAW*'|#8 QDg"YF YQ(P!xّLu]SOV;o{b*">Ȼ WZ"!ko%[#]a94ӕ=N%kɣfUBG@xTӤ~k]ѴC9S܇΋yuN}dz3^RN!Kbo {{xp=oվQ?[U7c_D$u%an9|ghтpX.|uy䫒iHoMx_^M0\\Tpgay\ƥ?KJ=aɔf P*; Ask߰(4$>;yLQ Z(^ ,~_£wxıKVO%%[O;q ,b(=1r >X j_I ԹB:pxl ; J i+ХwVɻSqFY> >Ce {'^iMqVuD4N#ov"(83ꊘ~dUU? oʈuUġX}cVWRŊ+O9) G}Η®師"Ro\<@,9ŠugFWBgIJ9>Jʛ:&U?X>"&?cv44g%cD)3\ŸEш+_`8׎0Ttpt Jo 5C]0v_]e>3ifX.I RUYM:Xc Ka>x+cO3 lӫqt??t`_an-7(aW|ܠI4 "p4ldCXs)MyȺ7Y ǩzYƛ=Ӫ/)ϝd؊O(ad9JG8[N&8c=igi+{xq~pvQ;-wsXB3np"U V.U~ƦtqT ?&T11O #}my\ U:$itp9(Ikƶfct1-9X.U$GIFQ(˛`pTNSDLz}Y;JJ f0{&"` MAFD8,A}|eomoo(e*bC♐{ϬB9iE#TEx]xc7)o&=wb\5M2 $rᯗ$XJ!\ Qfr-1Kż >3p;&+*H@ԝH{tv2v 5}Kz.DQ5MW'S=_ܤ)2C8Y\Tv;r|*9~1NAWGW5kz.F(u]@DR_(͍ő*#ihI쐞Nh)Jû,`ʖR*&.-\ȕ6ЯnM/>*y[}rүĄUBoFoTRvur[zAOO}cF@r>}_a2b瘦nzu EUlB^J, }$>TہzX~sMŬ,!cGNN.jͲ%q1~j F؀|p!ihfb}s}D[P7gN^e{ϫ:Z\$>wl/@2+M{FRg`9Y$=:zXhΛST6>iGioX| !]* ڤ9]̗o'gM&f< Pn.>#< WaOsNCXl Q]ed5bi\JYӣߎNab_!lEmݢJ[~ۤ;c03 !ыxWy,hg M>i-g'[5#(L_[ HΪu=(mF @5mf_6nt83b|Qv?zvVj2PIIP`B퉓VCuv-Vw/:M;dYEUe̫6q, -NX( 'Bϑh$̡N pDA@?Ϙhh4h>TE@s,v8;N_o 8-sDUF4@@<"V0= T"ԟoCK3˄';G/9yGx1xwtA.}À_鏷o?oQɇ8?@c?L8㟟~0rCEɿ4)=jI\.Z>~%^WiԍRdAs?f}Я>}O~cQg <=nb%i6OE>a!$.Ӧ0 ?=[ϓ yp:B4'ĽP=' z8~Ч3g져Zۋ޿hc_|Դ>Ύ8֪o{D#z'>:8??ݤ Voj ! {l\,iW5OTb**TN'NZ䖼4szٷkgUwbR:$8RX4S$z+(D`UI  o]Hૠ_nNttۻ{Y" FP K5\#@-uº(KmF=dj*m ^z@o؃43 it۹Bs%nngP+*Zyw˨V2RU4^! FS/ie/QqB>62CAU`}ᖂ[y ْ\/ިc·2 ~yVA7NoyM[zԮgoSf♍ 2V+E3|7}UV갿_qJ'Y7YO/Գs/y16E079@\<2!_e R"]c9ٷW5:ӑEɦ~=jvd\c7%2;:[ű5R*;ױ^b 8{04O\lC3KVS7 qmS ްJpz +GD'ir Ut|a `M-P%v/Mm'$\~m4+ 7JmZ2Ҡ?By|vh%ݏRBg!Y{Ĕ&Wx٤Z5{{õH.^:P Ab<4@&q"&}2SŐ_>{u`'Yvؖ;[V|t*f/WPaR цύ<|vVZn-Pv8&5:RdP@} PAQ.vtQLI8aBU:0Bϟ7E\Α8,.?Tb  (W~}r쌸ɲcVUg/o1p@Ƣ@!ɯŭGu|^I<0-1ۻى>^`8ۏ (WG!TuvhQ-$9pNэ0\`T ˼d/>E}j5F?YF>BƚӸVbm>6oLE}q]@Y{#(ZkyZw0d>=lG{ThETRMCS#I|z~3%# "FwD|zG}FE͛X݉7MOۅ+OI :G0AtL@z^is28:I1[9ڧ8iҐOr˓2QW'%~嵧WLU H=O{QfHdD^rs8p"QBA|0C| `vPqcf(̡ Ӷlp'n+lSρ !ˡ*ЭWgLZx?Η' ?/^6nN-}}r\7R/k#F* 'G^"hb{Tl^Wx_>-;1k4d;.uNl'a3=Lffz$5TNrZ%z+ΩvCL3Nt/[B5c(cEE "tw[=z}iPc9.V8mS$}ȥ^* P x2 NRyGkysz&rDG=e hm&m?#yiH W؈¤"ɨj;yA3!l! 6n"9֕9P듛>14"EK$iAu8(5^h& $Xn3jp`嵭_.jx.^MP5nA` 3l\sˌ\6tm !]3Jꄁ5Bw?Փ&@𠷲ZlA(+m#x/n0oKN؍2SV|xg?zj1K矠gq6poO'%#/݄olr CFNUb#6ҥ^a?ɔ6YJ|$x{&o(I.w@۠6u~dpU2%n]#(_#ݧ,RMȭPxI|:)L#%H]/PKUtɲh "puw2*-S$NCֻm(_ؿ^J]8-zb(M_DU=spxe_^|i# e f]*BF3-ɚMzzDWo苋[F NSL>7r$Brb͠p=?堳'``.H I'&5-}@BMcT긞p 7^,7E!B?u);.pl^v@^*.EFdS^,g` |RMwҎ VVt*_4;ֻk8IȁZʓƋN!58P}:Z?'7jٕ>Ȉ>#*V;z7T T{H>t# y/|t߸hWm]fJ:鹻(7o;@Á`9e@ەFhی #)itaտ$ī[/O.TX rYĦ$dwxEl G!3 ɼ;F_#% 0j~p+!kks]FZޚCR!g@$Qx!r"'*;j$j܎*w[M)B]\ju{MSu:)$ѓ]VWh*,":^F+b?jmGp7\ԅ\KkiDT"?_G*yQ.Ic7Oh,0V9ͪ-v)R LC,\ ͿI~,72ާ ؂s ,=ɲn`r zp>RВHzyN`95xNEHC.%ZAz}w0קw) Nb!_TP5#evV ɡ?]TُrACJ &2ڛ^ek#8X^{ɻ LrObYƼ123ى*HGY)S'仕 +:'K72A5#b0oSIwntrZlȣn8Mij=oJZj,"U.sA;^<8|Z)\y9]S2{˚?]6Al+BI_ҔO9> `Mg&DL"K'舯eɷի#ej ίum;Dp?c?A$O)4|+O{iO~JNj[RN߄bq08K@Δ[y%)Rx1܆gs W̾W9Pvƒ=a~jp`?|Ifv4í%;[䇦w:Y0 gaM܍QMWNڦUM^ńL}<\ҕ-ltDb9[[8A HuݿC^j F! CאY4>0LIHo ̸g5M9~p7mY+u5/q]Qv]۫f jJ 6:l3rg[)иeTW|DfBpzwF1tHK:Vُ;Tvtc<1~g_e,S6 6`T`>>?Շ5=A[-C-Y0 %PW5RP+L+SCCf [9㌯':jXOzV{[/VgHi{o{#fh/ΐ S{N ut~x]"R4{dgz7zLo9m9j4ИvVz z6++-0ss[\S칃sS]ܞ;x=~c5oaxlf>2-7$Y2?0^nׇw mwWwÖs\YMLf® k$VvS3cWm'yB:x罢O#X#o"&I+.66~_}G<癅 + (Y1( JOϑ#Pr%Ȇ#?k)a5y}-߾~XF0񕰻ʃ2k)o8G+,Ae~ٷ_T?Tf^0PX=$[f;:75N'6L~?nO2`hm h;:/Fق^EjXRiCEkcY9!${}.*0ڠUET#w i#xL/FK#7eXr &@ C?r* cU|zV?A0ť2IO&ٽ^) wo{܀ufH?]HTz@rkt><⛮~O`BH6) ~2ƇҊDN3<|?(XCx&_ Pq+yi<KC-+}f@t" ImӶWT*QH[񛥩݃,`n~=܎dqt]d4Ϝ2WdehrߨSM0&"2cȉA[-tՙ qՂ%F8S9py\]0 ׷C}W؈y7]wQ9).$7ӂ ] U )3|5|4O8D(7YkAgAYơAFg ̧F9E1K]<`8 -;jo8M_澕^5%\[hhtvNcNhr8.33q: ᆃD${W+*`L_A+ٞB0¡q4p#-|efq~u~̺ 5DVTE}H\eTP$ЅSe&OƸ[a%Z9=/'JM+>ήu)dGGJȰ|;Hpwh f((Kg>0/3x8uj|!_ dHrYJGF>Ĭ8CL_y7=ގezs, p%^|b}8/ّ`E5hˎ >%MZ($nSS wU7n@tBو8G.xjz׺| Jd}>_:-l#SeR+!=εvq23cdd9+5bNw#Ÿ9jq8ܵYue"SQآSe墾1bE>U?GY$oE2Ż/CgwlZ*B%k(OIjik-Ͻ-P$ԌMKjh GCyjq UI*馕jRMpvyBjt8xOy16a5.0Εcاv{vN_O䲊DX7~EXgH)ҹeg;@\irb'nEVpkuTGU=765Z\&,Qg6 Fhpe)a&wwzyopT[ X+;??~-)?,Ztq?ۇE\cItFzݬHE'."9wESCnDRCau=/l&ك-??M& _iOL*AM ŦboJrMp2MuVhF-LGԣWjuuO<|qV}2yRqc_nZIc 6ng7.`ɹn<;8M$gx;EK.itv:{mUUkx \M4v-մNsەj)F4FAiwmT)MTZTWӲj: zmڠZ޶Vmt:;jVMm{;]f)vvP*wj:VM#GۭbӔjEhTjMWۨfoj.6l[5]xAW;TZ]j:4vVMPUifWmw-qQ;WQh5Vskvxh. )J5{h4;-6N 3 ~[vf^@wv@ul[2ejJK=Lc%ņ .n>pҫgWWGaP$"daՒȢhrC=w1XNjplܫ*Kf9PxXt鄴ͅ" dɨ5t4Vd6;D/9 -J+/s5e@Ay0Q ߎD ƕ3cԬz]XMw\4<@OP>oUp @\?&MYFrvw7*Xe_ o4bnO'B+ӮW0P,S#3yCwd>E{*F3Ne0&VoihFK;I u89jN5oqYs 265Ǻjl3c5YL2<\< "vV|@ \8:7zn<Պz{|X,3m뽀CȻW]ZRK[Ш8*?{ (0V聨*}mJNY mWz&~Ngfje}IZC-K˺4,Y?LQu R h1b*JlM k2pg!hL_+h,503͝yC<H\g䪺Ip'l/IX4n7rIl5>#aaU:6u<.ǒ-@q1&QaI"8U'tX̅Չ]VbYDy7a-4 9Y \ ^ l%?pԉcde~5u%;!vV6aF ٨)@7Ł#'&t C1*3EXE=[U)G C*/zz/ջ :mǎ<,=,2\n/Cj̩`~PPqb]M!H 8!=퓅v;gK&Rx#-5x*"`޻{a!`v#7'6@_yJаrB:!\5j <>kF Vv|C] +8MX 4nnG$~;,JnMx=?99qc:; |&8u!9}ۗX ;jgKaD F"dL㲞:pVx2g}%p9e׋*ӐE"$-3a4N'1"ˡP?aa +*KafF53Y_%wqTz{짎.e.<Ұcu n< QW/>mA+m0oiFdQUQ%dT N.S"@Eb]_fTI ޗ:Iouk`CNBb!Q\}l\VbNۅuGj!;.5DŽwt7 NwStL? !d.A7QtNT9%W.ϮC_ԝvX$-5R*;EݠƑ<e{ l]>.unf?l<ᓒYu&$xLKo5Ir |ѣ@KC.`7Vp7g3d;L&m{v4;H/2 K%W)"u|"?l耷\4rr sbԏfu1!| 'v1:ho]7.t|KU*3}X?BS3V+鑡y;}_3 eJW@{t['V<RrVWPщvZ0yUupWJvٶqbZ $֤՗G2;/L{RA!b;kŠ{#(<-hH <'ɒCcҠ%m\JE(A_:B]AB"ԼP9 -Ei #wLu Z*/4=j(4DM6eUj%=sQwA #Km)30l;,RbBdr D%@ЯTm#b1F Iԋ :HK:2 4f'ۣ2Y XWcK>eTIiga @ƈ3dL .0 P *>K$s.P]2aL5 'y,>WN(\Π3fP<@D! NKYJ" 4xDBxIwEȫS ,&{!÷d h?ޑ3$~u7(n;wyf[V8㣴s  !/~"Yz?M#L0pya B@λa M5dXWUs"WV0bN먱)gn\NpinSp$#&C٤!ǫGD=*Y:iܸߕ%~B G1i?[DWcP[9_ZGbdhڶmV0h 8ښHCGj.~* 9:0T0כ;!˕-&l;jt03e%zB[} 9-4JC>k< EbG tz.P"PXA¬09$ߴeXpAn5AW*RT38)EÊnpf^M7Yӫ5W ̈&4jCbH-h"q)5>7 vgq13tX{'Tִh|3|]Vj5bjڠXJ_*z k)y" xwWTU"]pp?V"wؤ e*Ք8\%OQC db >c [?4zPwv|o׃ ֡afd fvCrL TB!yk/C+5ˉGOb]+loZ}I32G =u eقCSb#6+QGI/Vy<˯ه O욶 'ГL2Fm$I,t?iwc#L1]SC*jg`5$v7d)[~2ed&׌'^3EP~{2^ ߊkVbb oWAvf0I<~O_:ղ2^ǙYoV7>Wek7ZzwDi^3)V}a už <n/mLhX]V6 S\#׹s ZZxQݩ1btNf 2 3 i '!'~}1_*e\F,P(-| +5QXNbRg" o7ZXkSv^vYFNTsWx 4}wi0).48b79P8ť Ud1>Es"D?k;J/"۫fp+ZLg_}|7+x,WhDm#(`{O0aK,88Re=?bqEI?H<V$La*"KސhN z'FТ S䱛7҃ ZA{AEhҖrW 5@q`Ͼi*0xѝϗ&`KMFz`xf䔕FEXm ?c8բM˕VNeVM?4%d&i9#Jz_1˚}vc:?ڑR8"LV{^v3Nc,Ҧ30?a/m6te Ay/vwˣ;.<ʞdFs C^Pd4Ps W zHsH]ӊAVs5$ȉp9ZJ1$r#_L=0Q >;Qo5I@j,crB  ct֒q2rssI!D17g!r*].cYZ*#^mf_ػߋTaON/y8{`0^-UE%{c8f׏̂Ɛ @<%Y9ӓlWkG bh9n.B(R dm4Y\?0T0zè7J^Q06_Ӫ(`d"UQǡaCpL>Y?&ux1A3ݎKx>&r1{cv˸oVƒ"!ᯘdb_tDkMŔ'eIL\_b2|"QpQ|:cdՎFFJ :j!hqa.2#9@y\!"ʲ[=$d385 iӝdYЗ{# ݜOqxB4\ͣ%)zT_Ǒ=LtzHNMCV *`}fHxYxV 5@xisc0bH4# h+xµBe) @@f%S4=Cl0 ASh/@}%{$Ү x_`{/fh~:STTa./oU7 M‹[y(y~wu10hݍ"uv.k,a0R"׹dӹI=,t1{۷b,%.}bIa^j: p]tŒOod֨hDFI #c]TF?RcA˴,7ΡŨ/ޤuqKYk-c2A:;tl#׆ƇXeւ:YPgks~8e>g.˨;*FK5OP',kd37ufb#|M0ŀ|/Nqt[*B!`fa(`:ue+إ^Jr&r!RzR\7aE33ph>#l!% KMS[H9&PK:P˜4-$y[81?; Z~tP`u;g܍T'=ɶ8Fx@̋}; b 6MU5B6u8ϬC#b]Dne%| qf9Pbhׇ^.Y!z\sTT \ a<Hf>X<;QM)-ESS)+k@얝5:تM=h-KxBeW<6i_OSNe_mt>cù:0{pXjv;;+V\ eh +" pbt|ݳb 7 (ӰPYvGWt]}jݢhUn / .dvt=\B.IxoGg֦¦nnͼrx\m-JX'♓70C\P@,T&rȧ* $bɁfELkf~-TV!cӀxFhCkƠ^݄f5ŋjY32ͨc9=ԂTJ&Jk?lyDZɗՁD>S(E{bc7[6l6UAsQ\.z9>5@sݚM5QK@28r`ΎG'Lz6G H: d2=| ZT.E0dp,C0Y͈'U*V0z<+v= `?T#`,'Fx0(Aiȓ":VQB> v091/FQ,֡5㍈̫X*K;9oHC1T&C}(МksIϫzJL ɬЂ䢩Bŧ% :b_2B|R$iO6Or.j9),WdpVUp4Y,*Pk.+ic NK >K\6 2 eȅ;n0S/#%s%W5üd+vTO* "gIi (shkzNkršElO?B< wntatO!h# ;(awMqDE3 zqƝ :͌jV2 u⹻zMSO|To:YopWHt/ aSl:egkĽG#?ev2Zn 8)U.`dTyt7Ki9=xqtt/:etdӛ4?,Tg55 DIE8uvmL\ڧiv*U"&jj Ft3ڵb5bQX.63F0147w_t4\T:rfQQpte}!a4C&ʜ"ܾOsPV-ׇd|' z⇬j?5^/:XQI](WU"߆5/8WoMbmԮjc-aUlQgd !2e_ y շ*$ \#$d7|,?C$Npp@\Mt ܸPznr'q,u"8Yi@ZpxWp7n5^ 쬸HF u(+yOc%G 6XU1H >*s}?ۢ7Vv~zQkwA!ީVGmCZQ$ٹeaBQSq CqȮzXc?@x=X2X^t~8|dz :D"jbv^)K-߮ixcw䪥q `T{R;د,Fb9+'i_QO%R/N jܱʏSVS/ۨf•kgǧo1 Uoܘ׸D`JldCEW0r9Y ”kLxC c$SSAgLkʠVe{ <&66Ɲzz^Ëoy{K I,+{yƞtLZnZ@}؉)V[`$>4;kBZSRa /E>Im>olGqp@NУb%׊<".+쉲. & x]%(%Ģ]"2x$}e%Np8Uh-:g\&C0*3(X$3: r~ "h{Nᮩ%./MUYzE!wPl?\{x2jB2@CUJ=g$rĞ<;x$g\wJ?v\\VeQa+1/5A2n D Qo&#\rL?n'cyIz/tPk0C/jR]0EIF1I?!TrfYuRłO'I + bK6cmPZ["G8TI+p@@@%TV7p A᭍etZc#E$Rr}S5P9ڽ LpF˪sC5⎄J,#'Ƨ:٤`s5q#@9/inE}Thiz_q``yu3}Qw dD//A8%ôr4--b|ί4>B#roM}=&Sakjyrjj­[$`KenY'˫/aw) ,ͼ.`h5Iܦ=p=h8]/nE=l> 8s(N Эy e3CK&FOYcU"*Itjjzvxh; QV4zW\ÉS9iEI\7Y @˙c.uFWa}eQG 5Nخlx裙GI2!: D_t R]ڄxVG"QQhӬK} [(30}$:tXߟet2ZӀѵdi\Z# NH R &ovaZL#+Q+)R]EVMjYD#vu`*x]˶EsɊr%` 1&ҷ}K*-,*$A^CtVORE:)2+aŒgcz%sfw3 4ȼh4Mz-oTg*gd]Nͼ*0=O/&"EcS<=C{%t bo5JYVtL|j4}'`x x&cUxwP۫dZOz$D.svv*nQ>|jL9^Q jH*L2zd*joog3x4lYv,h^+36n 2[`6G.>ي|8;$&Ǖ4~g(BH&*vA {keGh5MH}@h?u\ 3+.!ފq)CN~;:esd{۾EQ4[ n绋@܂1@K8Xi Cvbgslqxl< ã_埳(v@ BbHAVH,΋C?n# f J4˷@Fo#b.];$YG G=ޕqY46)VɊOcdHROmC9^wEX5=F;yEWxcwn<oHo}Wm2 O%%#:i(7Ew.՘c\E;# PFМ> 1dI?< `;\ns7ߑ8x 8VEoF&EzR f^4E%mQiP1IFaK5" obBv >ߎ@P [c1iŏĝJ"THt+UHfO)Rsfl7*HC=fsH͜'.#BCH[,fד SyWqǴLY!伞W9bه)H\#J%˱CK}mf_6ntޟ^`S;phKDȼΓP+T & ܿ~ߜrIrЍ\ )֦ږ/Deku 5SaHZ)M=:w@Ō\t9|kۯ8%P*` o?Ca/_~IljlN`e %6]SWn6izչL~YwxĞlԹ kr˳+DC Wі_^tzrݝw\X %aNlE$p輿*/W_c Yߢ 9DF{r'!tbN wE<:\X (| Shj$8EEdOAӌOgr=;Kg=$6 y}ޟ&\oas_rĆ`/>SakCBKT(ZBzPAoGnz_߾a7iL?x|Y?m*|h&mQ/?.G+U?}w@w裃qMZo13N6V/YQV*\ P:ON8J;[Ix!VK?pݴĸ"ΐ(.@D;Y\Uh3MȴT3V5 ׄJQ[z~a~pjߔdNfkFҁ<ҕkV %K]n_Mz!񭵚{JImP:B <B9 5P7?\Vʻ[Fѩ]y}9]jndg sلLT52[\`K &2L[_N+Oyy#7UMo$pA̟Gܓ$9eY',.bE0]šD>5>.kSx=! E !pfJT2AR)eGύ<|%J T̚\: KU"c)Y,IlJ跤 U\j _3 T.[wRE\~9%aGw]5tl]5 CYaz(};d h_Ur[igEzIKjdU(_\\tFoțlPї J^/:EG ;!Dt&ZmDh B+j?Xo=+A2qާz<+Yc`\ S{`/,`{}nn94%kt!;MȝpeZ.޾IYI(CQʿМ'ST1jTkN4 '3ݐ_ᜫ)9l}_Y1>~As9pnj#og6o_&c wn|gOې/YKi'1s󥻣wG펝fZ66mKA۠l*N"0c uox+^駗&~L7c;;^E&bMJJU^pteAl2Uk" ޖd̢:7xQ-)_{jg4H,I7[YþF(*]6VQ_}crt<*l9'{KWQHXjhLLcNכa$;_cεVt{Kbj*_[r 6C)FQD SD>b:aEdekڛgx$ڸB.*cprQ%nVzSQ; 3lJm]n/J0{B৶_,*&{{V`,OP{з+#fc6k<| .Z^L Y ?S?tO Sl ҮöWޖ3+'і-M(-I:5SI?Y2lӯ{ЪO@ІlWݬ+?T?[÷ܾv~,+~,T뿃&t|蚉ءYjcg{-bj݈iԺ;fs\mĥ0KhިPjWStzJ]8XFEM$3Mw&Zz2F/Ws̅~fVܷ :*y6y_5e= =r7 OY|#gG:@?0knzZYp) ݬTVC[ՒKBPqem=EA - >KŸͿA]1s=#\cZFZ%#TyOg{T RoR܈G,z<}Nj :?k8\v˄c/T>4<@WCd@ Ą8Bjs!A<^|^q7CPIdD'JDsM~㴓PVt@—ǑPX١D*S*>:\{qCޮci=_A_Fӭ2H^&Zh*eC:q?ǵ1d@J8[ OUjO]#QսjݘL\H.Sc!u<RH7M" f@4"\0ThS1ЀDP '#Dir$ԩy(QETJ0I| K6[:N {35jKuڙ]RL?+tn\3UK_+J:uh;au)4[;}yEU^ҕ hɜ*; i^'i~Յ{oVC<#rq5w= rͪ`;ty~яV/0rZHn4> o)hdWE3;>s:rP//3iQm mI/\6;ҽγg'~a[{/eGu+D/x/}j?fO4 D+}D7~tb="r>棊B? Fy-əx䅥2YM `=&MC>ʈrb>|,!xvΑwDQwΏmO9#(=9iVG懥RsCnB_r20-lUhCf>KuU/< H;N|(Ӛol eҁgb[^++IL\gs@#ԗ bݘShjg|:7#vƧE7+"V0=?[~ǧUn(_[Z7b@>c+x/ҥB>UTز9ځ|ikԮhGס= rj_TnFRm(rfHEhv5+ JW 1@H_}Ym\< 0iMį%+0g6\HzqÛ9J" Ԉbk0qJHSشE_8Sۼo}{ZF}[R[`6OѢ=lyBeHZ}>tZ>l?և3򦊷 =vTaq:S-LkU 51DZnIMq;Ȧ& }C>=tꤲWkz]zF'rxW8OvI)]PjeSթ :]6aUb?[di/6*z9G^,$sUޟO$5 r?w:=2W޶T ~X4S &䳚J?n~]kǪ2t;uw֞<"Q2E/篘G]T唂 Z+I*o/>?uwgFa~綇CѤv}LY#'8=,ם(t ܌?~t^FS_W;`:/j+VIi4S /+dytx=x)R 38+%_e;NqR;¨1{3pb^q<> wFޑG/š^&wPj'x!WUcr5ha=2gZ=ӻzx5IDC`]<gl_ ͆0ܨ儮aḏ7ʍnácDA~!!I\iwwVS( 0)]xx5ZbX WjAEmHe#'n(Fؒkk$S4q#AB8 e]& MmգKZ$dW(OWd@R3>bBIE,lhm0g*iyoFL J"/p@ ԃ ΕzzYpҜFAmi/oYO G;(пx gij.W>'-=8$ī~ey=^p~."ĩO$onh5+y$@&/;ls׉ܢin/6lժk>4=q:D)vNYz6ڡ1s]ZGnƓ/Fn]vŁdz2eCBmYju ku}].AʈLy֫ &zqBz[^]fq2mGMNv2HgE/Ϥ'2 8&qटzNvj K.MRooUS'Iq릤 &7;TfQscs;f55~皞\8yX{ǔn1v<ٍ<D]=Bǝs&b*!9 7c7U2;w+%cv Kݍ[+g7C1 15}WMɽ;/VmmfpSŞrtp8>}Zm߶l#um#|t;>"(؝a^ py(E%T@[6v@_ 6#.#/cM2J(<: g]d='-#ifF̽e"_tIbSEN ~۩8b#3kk2vW]t=M5 ̫ r6n~)QHPK;~"8VFKyZM`v igz0.-aIws&ePI+ *>$/S-\qa4BAV'#6/Qw'o)]T0 gEu4a)9Nԉ ߌWMuG%k<!%v d+_eKȋ9'4! 4~KTO/MihNLָzCOVl [f++@Z{* pltڙ{_ڼj*z)4h NY\BX̘6%%DV[9uI ]v.B@6N?9'|H8uqRT@0*5&%E KK:n9z$?l9hrA ئ+PMj!2(hT`JxxV  bxϪ_Et9B(dxp샡Ɇaua̺`6DVT%}é ʂQR/tarpWRP<<nŕhmmwom]LwB4a-a6|GZ Iy $^du}XHdpk+&"΀L,J!pAZ,t'4+/%F3A9}%2 4Dth Ba_-ldsxĝtGRo='k0vkI00plnnlƖEBxa^loyw(1KQ|]up?Ot7|_U \-0 SsϮ{ .3qpBwo7۴W%]#4\Ϫ`ڸj[ s۝8v?;j>j'".Hl;צ ?TjX,h,4zZ)d*Y+ɣҤ'@̙s{#J¬dذ d ZQ3Sև`5NoR8JMDT4ɭdCT)kc^=!B'LI?3 'd"Ĩ޵Q怛$䘹*8}9٩kXLˉ)F|)<7Fq.R=nBtjz# |Ӕn{KY6yBD3&a'MXc꨾ڑC-Z &ڿxLV|u V8OQj\jR5 vwwA_ud =kYM?n7Tz'eK k0Aqhp{U#kz8l N4 oxm{LmBhv:Q0{91Mj V+9 %U7 8ٗT~zHY5DZ]5U4o 7$lvxytjsv6Wǿݚ̆x&;|tmv3qDy-<0kqpWmޯ6[k+L=:+]NGWVW` ߕoƙTLHG .icJl;HdGLV)}_Xm%6㡍ze:]զ"j:Zlb.Vׂ֩l{SGP0](hVrjsa\֚ 6 Ƙx ݑi#@'Jreju3M?@KW"2k@<4Vۨk⤡,X4G(lmQ65Q͵{>/#4%Bk^R_k]sz SaZ:LC6kMl߶U{CӍiǞ2A_W5hNV\RvlCl7x.]'s&qi,CS4ĕN=fCu"&ï ^miXurH>OGpmwWm57BKJ+QP+۪˦sv_7?-(:G= ekhWJUF>V=Z-KhMyrqz5{?W7U_Bq -!W"~6kgNܯ˷IrtϷQq3!ηkՇREO=^ hjnB<@:03~!4n67Z*bC&aQ˨VDFv`/Np(%\5eϜzp^Mj:wmo O`=8.5#dMkSvݏ4$Ir%9s۳4yt+/ 5#S/=F6H3F1›3kC]qr4+'ЫN,L% H@tɝŸS MU2iz 犼nM7W* '3ӭWЉ,7Fi+6<wC8 F߇Jo,ѨRjL f2jS f*tZwUz6"O8Գ[dcd tmmdnBe|20R'ya% B^tcq'LON\a iiGۉo[:/7SGxCVVdw3W;zR=+rϖ&k(A8|| ^(*|KkE m!zE |z1V塚SSRܑגvOjZΆ S .GSl E>O#btCRGԃDXmm7!KP;:*yFMTr|Ql¥+xmCPh*c}9y3Ɛ,0.r*uWq Mީ^=Ra˾d+P%*=ZTV%:.?2V'ʭ~Z(h5dSe]jр_kw?˝lG ƭҧ!Y6ꕄĊa/m+QZe7]_Kq (򜋸wCznU}z^L<1y48hV3Bu<0ӶXY鍩7"ʜ^ f+;IOS JQV e60I3"&JpQoh;/d2xn tU'&ousrMvrɂgHkĞxޠLn6_Z+|[{*.⩻-/:C a(D8l;kfۆ?-Jo w7{JhwP20:%na?al,X ;jהgf>IG.Thܔz{IkyӗLrS8r񕣐XO -!bt{f\]%Ì冠-iJ7HIPk/QNAS.@E3+EW/qWmP'>Q쬉"%Kkѐ=WR>B &S«%;I\%I4tbaa r~LN$e[a3nhjhۉ"Q0B#DU&6΅G1 OUfwe\ʼnyi K g2AT?cF !,IVW$_nw:bt.s9⣁. G!Al"s`x+}y^TY`/:ݹ3Ⱦz,oN6]n .& K|h6u/6Qȏ+s2h38%ps 7gp=6ٮtd}aOe%!h-ң{Ck/g:x[o aFJ븂{hrllst5dy"!˺9i0 ܦF }X!iyfsZaD81ȇh:'2Ֆ|ī|* 硅 Qi»8p|FzR '\|>ƟAY +kKKgj`ˈLL a"s=4bby#BбxI@0W >tQٿ7%]8@oMC>Y}_a3! -h~7&WITi9ED,Hr~kL1Tӎ̡'cg6H3z=j>(u?F8 [ղ CU>uM!FȚH~"Y T'?uixbι4}jd:RS6AJrB"c>c_>fwT[nJr8X0y<p^I8㗒&w"H2RDhWw^ܫ݉{GvZ3z/SH0LjUq~B>p0 @8`L)+(3EjrSDw1J܎s y5j#KB&&\ݭzN&S2xӚenC߾ ՋW8%Rɉs˦!Ty?-} j5#wOhy !ζWiox}C^MRUl̾tQtv23$h2m^WNՁsE9C)R1!T w\M=-+w8E孱z/8Ey% njCUq= r%H3eég"=gx 1MmæM91qa/.9aAwȁ32ל[![hU͘.U 5zΰ^foV@D )ea S0 P@ !qHpu6䙹1;QFjWy'UaB`D+.\Nʫe$JSAϜGyeS!ĩLIr#(F'5 Yhf8I#*X-4),nj$I%!T'l{nNN) g^|eM8ŪP\緳JUMb$=އWnaZ˳@ q qYwwRTr!s(h+lX nj\B)&Q:P޾mj1gIѺqUkHfnb5]=wJ6 =٘ +55iMb?>m3' 7-@1( 9]Ϣvxz UY}'iUN&yrܦ4Op.;.FBj2@j$ ^nNw;3!c?="dƊkY;wȽWV:~j.חniE}_R3x_ FiKX\<׃h_ZH˝ϫs 3Yx-2K ֡.IIve; dZ!,TZ;+`A 6ɍJ}ve=Fw,?NSE쪚1"ܻ|O,AihP(6GRNmZ^!-fHY`r[Ós?81ĊȳA1$GLMTF#SWi#"(z_ Y 6a-T.BƬ+x,jBt*b{q%̰ye=j9Ř芒: g$#ܞ{?knq*MτT.n =nJҞc+Sݮ?Dx kh Eh)xzjG[v$7(g5j(^%8L MoWZcx䂔oTO%E6d&/M(<9r,0j5M˅ZV¡,Oe_ hJ᪛z!?vȻD,׼i'.G Lpgt$F&LSi,'\QW\/3lU}MGJrՇĉgfwyQ#G>DK){}u5Ji:Ʃ# #Vzo4%X#vf%_/kQau"#$r_$[4&E"A'R饓t\ӱ Pb(Hh@ܘϦ-((8"Evua9./1uyxp/7RgM&U&\/ph,V۪"q w?OϔAҭ?$ x>Pcɻ߃| 3=S5UM8BubAtsd^Pǿ$ ( ح f *Tpbpz9'T4z`,G[Y $8-W(C1ΐ'ӗ֤PcP X"@HDq5-/#w+eDGz* 9jI~Q71]0%쮇6QP? V!LA/B]OnFW3Agϝ1g5v~7bh`IN-ZsR\c ;QÚ&ٵJ6!4){\$gyY+H71͈,Dx &6\ñt$kŦRs["Il,.%Vh?-si!GTڟddՎƇF&:b8'CzLR$b!^̯&ʔR =>p9e]4ZrI 8Jg4)Sjj٫qM({YGLsE+⡩ܜHKsvH=@{@ߏJ%җyF Rfn ADsxaiK\$^ZJMU+3I%2+io17n#Xf!U ظlDdw;oA#G,K:sUzWxch..nE3}ARVSy3A0rgsIqK .ڳ]g6jFp{ku>,%S@VXy.XN^UpL݊ώdrRH(ꚍSsP`%rrl=蘾E3z|)[ s>ތǘKrbFy5?,gkx1h⃟Z4)}"G7<"j)LGCCuI iílf3 j獯u3 $qMh)"&DϕaP.&g++Ĵ3Z?% Ӹ5ȝ0`XUP5pWs2c#I4eܿJa@~Cܤ ]ƹWyȽ}y<믞i8.΋Hm3OD=!9IAb /:Ѥ>6jK-y묝6)Uidhj8/aA]5Oh֨ea>ќiO_# Íe AezW?3s^=3g{Wa ԗ$R'>ᔻsQ692Mz6,FQȎ&r* 6ilA+3n1\hh)ۧRϡ-$?G_7b%u~PHD1U@KAhIˍyғCO6'1B,(.kwܴ/`iL1_Hi|#/yu] $xJ(\0(n)նx UYo\mϚ@Zt*Q&5$c,@8P)[-m*u;˟\$iN#mpG"[9+VkG^tAxCwh}ݬ쫍.'S*d{?|ZvYRz{CO=uf#^"U9?7r': 6KibЛj~) &c6P9 ll궞1uKc|vIOvpJ'55ՎF$ɰE5:ޫbVCyBf?GT/ %obKP ƮroWK5R6R؉>̢^Gq6(?ʕ^ɮvku #۽(> oN ɜ2/(QHTSDFqw "|`zbq/aeLE괈tQM !˘hBf9*VV!@>iY&T1%pꙝiԟWJj(=LQnߩuK Ha;́ tGk:;kj5I``g׳s}Lj5y`\a/e1Vg;ns܍5Fȍp/!d/$#A'zLLoNj_ ؀)yn~z12dU;? fSS·g:+ہm$zIIƝP%Tطtq@LhZ";FQn~SBfg6*y2NU3cm>9szlo7Vr˙1H"v7}(5lNu/jhL+e>LKV!-")QS1@5]{/C4@_E) ?e:vI[WJ` o Q1^DE0Zx&$h+"^=o9 ,P嶵?QzlI]w ;$;Ftppo$v;:R /y=~jrɽǰzh"4w/D M'A[zIzn/õsA[Yp%*?Ie9y57F;£%ѥZ>[$VO$ š o eW omޠN[&ޘޏ=鹉uN8 X$l0Kv!F8 Ygp7~5DAqiq-ޑu5rQ [RH"aIn@bātR+quj)Nj^8ݬVGv:^NgVŴqSV\I<Rˉw@z3Gz}bxk>Y zg6HԚ* ƕ?;tWP$Qc3$>wy ;ۇړzxl$VKǥaK1YmR]Zg>[+>e570?0~ -qb+o%\p ?e釽lWcQpm6. xN ST7R⦴66H%{q#Acj:ph&*F U!Sv x9=;>m៏)0dLj98}6g85.#cmH .`C .1\tꬭ?v.ʼnɰ*=c 53?Rҭ;RX Ab|oУbB.UDGIiFH)M04|䷕$4}suqR o/:LJ_H|]8M4edz(v'^@L 7) x;Ryyws=PJ J"H:Lr;M]NCo\ aLh"St<6د \Fָbg"d/,l.@UպfdpW|M Jؚ֠#WE3 ,bL@HgOwj'L}.X҅pwcM{V)/8QG482L0?IʅV%w|3 nS˪;0)ݛ:_,ƃm[0pO8a Dgͭ t+JػU {@z.tl@/*"<ɕܓZ6W*{tc|o My?2J.5naҰc\oG~&Ñ055p%QA kv3,br HE+(.;w7$FvjZZ-VYyŦkW\+7Y*#l@l 88b}8aO;8W;"&:d vQe8 쓭^:B+P)#ώgRyG3HxO=!}q,Ȕ*j)SZ>׏o U|!ǝIwP!6"c'9í 2B<4˲~1j?"Db'(ZeG!C*Ic/ BmrL-L&;="(GUު"n|Sɝ@CqVkkhҢjO[Q#aAA!wԷ§==x"_RN>z⻿G"1<;,Dx͘-]O7z6D_+U/(ʰ֯{_΃c3&Vl~׈xh iF3R*ɡ@JXIO-XZ¤Fo`94+y$R~ W%6/۹igࢽY) *D11L DlFt.F:n+(P @'*!uIkQx1@]]j|*o wr"2>e!%@N:=JaZu"6"8&bv+\&T=^BpIЗ#DbĒ*)^T0G{bSd=X\BjTC )[4c#;:}%buUl@1*M $AZ1-;MAnjwP/tVE7 ^h*Ď< P9f*Cs'cG#r^TOlg7=gt^pzx_-437V1uMRlit<>DjRI~jn^o."JGn^'w.\%%W;+++{ɴ?:}v zn[p6r;?;/:vgМs12gK7D8H)|8XoorpӚ\omfM_ }fmÚ:CDwn:8r~6hdYe41g\6PI1BO(p M]nv*iC+;o4؏`cZC "c 6 h %N!" h !>?[K+$)흃7N?DOh8 M$7uScm;6)'EQkVOweq\/#J)O0S4͛Rı"_~{r܆H0 LŢ1*2mCިwfyb DCP7-Ԏkѝj9vpbV8R2#|~;AV6#'w{8VdL,,MOS'5^5F)ŵbvڮ}N[ƓR4*$^V k:_\džw- ANrlE<ޭt t$9:c}t#'^[z%jw?fp tZqZܬܶV>}:˒d OZyG,ޑ?:܎==?=ޗE4!;;n C{w3pz~=wO>~|37S]h Wu8wc}]_>P󏾡k@ThdD*rȱ;hanz³nݾ8V֩Oz;@zh`t{ǝ1]~.md0% fP QmRsF|8!fM"뺩p zRN aiz- D*0y=67vZ3wRO[dTSkԈdpݛ\zjÌSs7*泙o\7\'v\kQ봶?Kem^Ͻ+~\r< (0"H Ǭ{K֊fOmN,~Yhm쯃mzCv(V덑7֛$tf+,3hf`\5N J"4J* ЃvZ<SI >C7͚n"AimC( :!⟢Ʊ9& ⇁¿Q gX4m氎P\4!:xyVfߣ41ӦQ^|zUlq)lRHz(ӱ2m0aVl[v+~[*:Jeu߯) 9׋S'~o`Tjٕ`ӦLv_Jk0Q ݺyᕁ"PQ^K^t$ 5r",Ci 1ӄnO3Խ7D%tPp%`Ê9pYS~#MU(ؒB-jazLRwWWjsE;^  #ө7"|WmӞ!XPeT9S h "/)X^ͅ8Z63p_iީ)ѥӼؚ2=#n{]Qj*m8<뱺%W5DjT+ڧ 0R~F}AYǽ;HmLoȣAKc9蕿ޟ7T=HvM׃JSo-Ƙ<= DW~ Y}'5ז)vCd.52һ< dݎ0k6hW\?ڶ0ice3GhL$g變ivWG_F~i|+M!=ij_!qR٪x%DG̋CJ ^udiJ_<87v173.cfp?J&b%ňPB?trGz]-Fyxm[^{דJW&tL3N99حjW8Gd8j:aqȆvZYKWɛƴRpuQbuEmpor/R?Q b5Os*ve,,@_fz(;Q5_;!8fA>ѐK7!@u64ԉ)]'oirL DҩJ^g]q:_ |ͺfpAX⥒\/{8.6ﾴT{o% xwЄ/]3;4r"sl?oELm6MZz¬b #&%[eWj sbמNW`T#'k|h~d64D PO@hT}:C=Yb~~*B}nЯ̊DG^%&o澬_G&I8}o ^xMO".eA^a׻@Ý}k"ѝwr V0ǘ87VR`%g$&ʥLi*`Щ#,$0?d~e͔{ q`Z ~!v. HHib.(ow]'eK4s;`.їtǀZNg{T qo?rK$dS0Nv09>,#*19nSnrkZ8RTvh-y="U)U=:\{qC`ȦzQ5 ۜn5޹ʁ\dB dc.¾^[Y $UPa#׭Յ':6U"jv^gث։{ ėZ@ITgTd fP8jlD/lrփƳt MNm+eYtQUw&d"7z\dާ0d2įĿX GF!}{[B~L2߳`ڻS7D#tvĩ13w~2k@ +&=/eS|nxc Mysi60is7x,t$2^^,60t:X[5]γg7P mlaYhOkbQ+ي ޒ>y-6`z3rQ; x4tU@jDE,a%ҋRNNs#M9Lv͊U Nen˭:$uJJgshHU_;G]3)"OҰB%%p23q)xvK l3_|K{:10k'Y pV(7gSA+Lh/25c|bF*$ԅDc?ۏsAG  J,PHP TP0g 9[BϬ^e/|Y$T MmޝW*m*9 3_O4w{m?yf{>n<)VB `pI,Ҧ{0Hn;*T ZV/t姵zz&m IIw ێW%ƅEMV.$4WntSj*08#|ጩ02]^Ẋ\Z˃n _YQMH o7KfWXMikͺ뿻6ji¯G /8y?Yڈn쬿810rq'\ &H}K=8TPUظNnJ;!C)KR%$ވ'݅@8]ۑfziR?UtSVF5Rloă}Hb>a[;, Sb%OY^̞iZ;Wp ';->wLV:s=Z_.\0uނ6 Z =-% ἓ%ο&$ ]sj'UkwϏmO9s+=9is\P@7^1mGl~J+5q6S" =N;N|(Ӛo4 zҁoNn-*G!߹b}{v&*ʖ2' Bj:ya/i:Dx\/RЗlTLy,UFzgnl -=6ʟ DC:rKb]3If %/Jߩ}\B Z2BO} e z>hhu#qCnDdD0sFKy?k o$3iZ> E5ů]/R:D ?M]̰BMZTŋ^I3Na$W3Tl>MYk(? qfبq8^lן4=6ۛ=f{{?{dQYbdaoߣ=$6lڠsfٰ0it{dV2S}굎@ {Zm(}b__\/|Y! ϴiyz+ze< {:M9,v $S$""MJ{h[Sz^#+C/ E"8ףZOJ9]#h@Le8 F:%rv ! SqDdz$h^6Sso *wt0K(I݅dc6M# GD6Ig*:<-x5o"[KX3L~G< uLźiFtmGc#O\moV g퍍}jo+Xj}*Z>$AS7h|l36AJ<;]j{QS%M6G;U?mU2Pk<򚶧4_E19wCKWHjEZ rj ;vB AyxC iz(Ft1/y}f44'|t2↫0k,J op]ҋ{t+²<iܷW[i}{m XUoUT\bیM?mE+rF<_$>TkB:RC{[q`A|ȡ8XcVH"s2.SCV_^v#;Ou쐧O:^1UzFrxW:vI ]PjSթ*:]tUYl$?[di?w*4.-"M2WUD2N#3y?#sYmiAϯ8`:,IOc:@>6_i:61OnwM[ kCciw [*B>#gF74uӦJ䯓n,#|cR*Ug a@csX{J;=VS֔b#9RV[.sR`;Y1+^=(˯/P wjewoWy2N}~UxϾ(jY9PhT. EBvOw˰3tEO9'ݏdd܁£ڊs%?\UZ} q&!0K;˨L4R?Xq"WKl/~c^@N3)S鄡]:V>m,~) ]#\(eb>Aup;iהja˥62aJ{C^bYq+&I Iy3O{~WofZр,FQ]xuZbX W5l66} Ezd|5 aw+̽o[$p @-}/$WʲPJnkWWt`!&+mAu<2"2;=% K.V?wTm^Zܶwuʭ8Rx 9{|(Qdcr|1agd#NiFtuT,܉MP긦̌hSEq56aJ6QG,|`E`A'(ќ-ngrvG446jdGA K!?M\l9)ާ#hC.!Ʊ'U=H0)Ist0^/wN}bj{1 LxxɭMj܍&'x>LWÐ9|[>`tEOnjwm$m@uuf-T}J;՛zJXwlW+ŮeZIuzwm-VG7x27xZ:B_ !]姦? S'?ݶۮ=bdұѸ|="ժ%B>N]*^5KMvζO\Gfa8ONCrI\O*WqtHœl6Z.L~sRcO*ǯkxՑ[z$ OӉ>q:Nڶ++ٯf>}vŶ^.]סo;*_/ N?dך\mWn\/x ^vI<-?L%8;ķ!mG}"XMҼ"`lY0Tx>tLw@o\(҇Ra&z"C2eՇpp\Up9O:`vDyLRFJ4Zj9kt:žb&^J)ѭP;/F]gŏh4DV3QNB3=';3ZN?yCa}O/[_qY 1Iڴm"czaxz"(+=M X|$b1,w d/ib&f'HЩ((!AR%˝xђC'QFp` $ьxgvR7ʄwoƟ {LW XpW IfI=4WXg=dx;nO^a"l*XYCooruEΚᵱ!ODS^j$@U3Z~HҔx> w$q>=(gd|-k+9Wf:$5r[*=Z ]?S~d~-n),In5rZN"|YM[S]V:WRŢZڏMꔋ]DEBYzG?nN:oҰfL}ĄG 5jGlʿ铽K=fh~ϩE 4DVt-Av{OQPp:m?o9о~P`룴4{p1Ke a<ɛ r5 ;wܠuY7a/_% nRD;1LvnRnBEo6›! ?'W%>f ez p%AaT=3S}9QReJ;/[_٤m%EM2򃈶FUq%dg+ *]h[K{iΆqD@dhU.WJ3s*30:,u,t88Z IX*%N;%{[W)"m@UeZ j\Yp7` 'TP$hdVqa$xfD.u&0 i̴nL׫/ p` ?줺j~漊z9\ NrqބNSp*l{NMHVQWZIyȊdirm}OԵ|9U*ka63 n9]x(v$QGz+Uۤ+xt`sBE+&CVZe4zS+VDuiKRﰓXY.+*[NB8Y 8ζ]%~ YkRmn[iO2ģ;[jd˹E{aB2fR  pIXU7l6sInPVbYR۵d<|Uv\nxĸOHyM&g޻\%`i0:sBS:&kMf!M*~+*C?A|RIYNP<<nŕhYؾv|ѿK|(1ŵ䇔 ˛1_n`̾GWQMAwoS>j3^5::,j@8|cʼM1m88uun&XQj]~hm6Yhv^`@'/ ]Z_X@: maO["*1wEky⿖oK#mUؑh({[>l>{|^Ӆj`J.g7kH؈wQƬRz ]uɔM,FqOziGu/Qʝ{N*{}b NJ*xZբFB0FQA%a}ںԦU}}]5J-{87->+Jf=kͥy\fu6 {̔ۃb$C6GK~HLk7*YU?ŭ6U%%1f~0s2J] ZڣgegEop("|4 a.1s㒛-d=$ZlJ.W [z%NbqD|% pD dgR'0|T)vY#Op8No4p\V72a-8$Heg@Vuh03 &z4b _lgl/x}8XFqakhy+^!G:z;GdCgdNqGRMYаWxضeqՙ¼2#Ř>r&J:zȾ%Ir9+_ [*\S$22.|4<֓|P7KJ`|T3ݿBA:<c:k_9!~rYpwW0\c`DюKUf[53R௙Eӳ۾w#2B0}:M%W̡jJ<|5ֲ`]#qe}g zI& *auNʝ7,cd1;#NQy}!|5ENfBS$*Ac>|rAcu\ ('*Ew4۟ǪiGre.q-7TM&EƭqcgXrr-9M͔ Y\ѹ=u(+ F:80?8}uЛg,|f3@ E>w+l8 N51OTtu79f1gU3bO_O#غU5 &rU[u$UWaHH(>}8p%$Nu;U*W!Z@QGFiFZQաi?F%,GTx䦘H鰳Ū(R}|>*r>J“R Q<2bFա!w`cýhg&x♉INZE,hx,tPf[ Sp ٦("Y߹9 Tp~;6}@맷.L;pw-42|BGg%sEGSJ)PZo|z@vM$88X0%&Rv]%4{nJɼ-20liP/M^WB^jC%ps}np'*{lO (knAV绱PՒ'%cђkOHM7Yh 6-zLz_6QrHߋ܍37baٶÃt.6C7Ri{vïƆ9R<5}.jC "y5Թ0-U]]x l2`-'rWٰОRx~Tk浬[q*wEL]dxF@df͠LէR~h`dl?&# G8*GiFBÀ]G˅(wk7x`\(Ro'sU95Bۭrթ7qP}Gg:=Mww)JV!H\gNv0Wq#~Y,S9 Cz|c^JxƣUR(ysoC?q䔤ՠK/uqe"ʧA |ï~#z(_+=< :y)9ȋ+D7/ujCuudX+83oRIZۥQC\b(ƣ(1nX+SSUз62H֋, E D: y) xqjv0+bӫfW1Uu7US5.+)O<`+_`XMwImsMq4fj ~~Ċc'ïP>%+@!N} WXj~0)b֟"*[tJ}c&8!>3Ou_YW .jnU`v1J-RNc#2bPnIa: kͻ43)9] {|8 킂oFnM IXlҦV\"^VG1HT[0ײ @eąI4땻gtu/4e&jR{"|nR'__y8VsoQٿ%&]8OtMϡC>c2;jY0X,>m;t8H&5“!ҴB&+WJЏ ҉ӎᡤ'c33;=j>5y nPlH62Θ0Q-Gc_vcmQNlבl4&^мVu?(mNX]wfsMH_ 8r_a8 UlgKtxMea7wJkdűZ;LꆍFMq Y?ܒr7T7U2W[CanL`K3SsBIԜH{c7ЩR%ǗL Tg@:B;p5NLHy!]BoA̫@WV#º+ RՈ+Jb v,azz|(@(剚ð4cD: ި%IFDy$mnMq)b%@`BBeM3Tix\緳J;pMӪ-w{"X~vL{O-U/MYm`쐁d#%׃6,Oa*lZU(@|6t8;?;:G+,ҖϚݯQRۮ(ƹ0lIjVjNPL !C[媒g&ʱ" 7\],~uEGZ?V=:Wua'6ʒ~h:T}z=[g/0@I5T 'ճqS26xt7s?JaB@_H'uk7x޲.Tt2TOZ.fIjN t k{\b[ t <)'x"RN($R{+4\(bR9N2Q&sXqJtP2Ym_O&X9X]*/|~7R2k*V]M#IM2 (MlxȢYr|dPP Mj15L}Uv1~!d]nNBܢV=߶VB֧5?/joKn d歓dޒelz*?/(WΣrN"Hg+ v<6mfn˹ d?1KYScx.ԏ *ڞcy›=_?/&ͼOB$H$Y5_`ꃜvw0'9XЧ̢jeWoR_̡b_Ӵ|aBi. j?#[1/wWtTRbNE_+n$ض_̽E?՘2F\0BoY-/+7! z-ID Z:7BL$X&nlm)ɄNzMFEyu- +q4q:NjsG9}.:31ä%Lv/ϵ>gweTKU݅g3Oyx p(*JW;}u\ Qʘ}n qX$ޛc%cro\᱓lҟ<Š[hT\M0F4&cDV0Y1cR(rh<C)9P5&\n5ڴ[xJ&Xc ['GۿlhONt5 F,7A/`in( W{w Fn#_LtAc>O*+aD+vÐ֋r9`wX. 7fk]ePolm=E㤮v$3_zS`¤["MTYVV@]]UI Z6(hi_>KN<Mz߯+ ,;"&%uz vڀkKhE+"絯ǽCfe_}2ȯx4'Aq&PƒU8!(%nyhY!_ϟ4y8KBDj/<7N؟ڢFXREsTaҬ7+xK\CoE1FR_e rt軌{tiG?x3wEL:>4ByPj3AgbHR^B⿁=oOch!`}H8pM~y⩾_G~| $ 8>]GTAb_B:Mq@ ƮJ VQtC#eZ-T@J)%I_(!knm5'{ui D.C}diNӭaACjWJK4"$CJmW5<.BG#D ^<Ӡv=csAEřrR-Q wtPE'bLve!Yt닭(Uy{i1hQC"+Nd[?øV܃E/j-wӐCH]7m "+P&qC}&|Ā?/o4 !r2 ImT,vXRsQaSf5hi*]Wd6.VELSfPf*6Vp+;n/õ F`?tZ.(jJ/0V4^@y8s~\Ydz*yv>Q.c"D)ɲ+ƌd9[*G}ZęiLߩ416r$ÀE?P|ɮRl(XPoey p:y ):p/%1ϯ@'Uq^NfDV~S% KX2tXxٿ_ o'%&*r*l1i~WmΉZUp}!١cwt^.NkJqTBdy\ ԡ2UzL$kt?Rҭ;R it97Sj1H]F$l4' MwK@~ &sĪg4$mTIy$pꏒXBVbm*U~Dk |<;ÓX 2PݏDеK6k\#Q~:oDz/dUӕV|!LȽkzIWSI.e*2 w2#_>o;5 QQxs3-pXeE (gCIyr^υ0*Q%̔JsLr;[Nýb PyOM7rUW"O^R=^D%)*UF-bsg 4Y*~4qv^gP{UJsaY2͕oY =I4nnÑ(DQ;6"*N+ &eq7R Kre&јnlf)S}I#_=}o OUI6 w a׸| էH(̐{}uRtTTx́$8 v좴j~\*dߡZvJǃoޯgM`Z+ّ,F$=6E |U;U wjGdM/PdEH'i" ֮a\G|ׁ*!H{ N |~޹n#@KGObb ynԯEߣxw B[t.s1~&1<n;"Ev"*\ܺjzl<vLx] <?G5|Yӥi(B$Epyǚ7T` C_MՎ1NlVbB.3t2ۊ{@(luM'l޼63?5{3wV[~GG+HU& !uOGClVotl p"Fؼ!"հOKO5½X07Jc/15]C塳-ґ"s"hhR(NA_Do\ir^픍P=.ĝ/FHW ۹b"LE_EP|%Xg"a@^9OܾvX-[;q ֵj*%YchSj3qFJAgΧ#pF4뻂3ND t3o5^ɁV| 57}7H.36,Hn^ښ).İP Ɋ:plF3]ŜH&(R`ݯ담n`_!W"*7e\ҏK}yR);Y=y bőo^|qԑ*Q|,]ԚfK>]}Sż.-[KK~,oAxrKExi4`:BTsji.цۏEfjg< VB*[ Z/bVmEob}Uo &+IJ6'yJ'F{x}u?oBzgN:R}vwq[o7Z[۹pr;?;/ڭv˝.Nn!H\`n=;A LT R0v}|;fy-x)Mo5K2}%҂4~d@N*F9\'{daV5qhή=VZC=v%㈲B:s&-Pw[ߏ ˅}^ĥ/HU?suw@D+.U8iqC;<,A2'Uz(MjKK)wzޡ@NԒbi\ihV6`6*ae"ݗ#%䎾twrCnSr| k+;NſGNěX}:Jhأ~?'t'Ob9T ?pmu[8\iyfiZ AgOsul[u뽩s*bdկ-p$r`R}l:)}!+Vf:-1[k✰Pɥ8 ="AɪfxewoWyEF̴xįl^FxZwj8,#_(;/'cMnKs̜D<ь}PUaO=)j=c[Y?"]B6Y c?!"m8oocWȉQ]OT]4=bmM٨|ynj_z_W{n&7Aw.`3VqUt|P$pv\d~!!uo]z9ODqh`t1( VT5MSJ Fk 4Q 5Ӭ{2Xz8R M3kj|.MP" zΊ|!AN MlWXZ=>Q4?)^)M19WR},D939Uj[{|z6dTid~\Lŝ%܏5~}0:J޵ӏZg 5X)0H uS;sF|3GZ?:1ޑjZiQ!q?L㋛.VCs?KI*,*Y={^7h?8f_`s6X@S6T*u}A ГiX1zF||k M7X|N݄m%\;GU_=2 q?~张H&-`NZK-S]ſ.g~>=^[Neq(P[ >7ӝFq|>xw;tKwɽ qʟJpm&b}Mha\OΞOX1DFMn[xwZa%g]_Zֿ1;uӇ(k=C6ȮFSs}F+S%ܳ "ds$m / uj~\`C]*NHẙaNU I׃P#H_؅vUձy{ZݦR?jOA_}|u V*yg\}g  ƤՍ\AbjVgLty6ѭ;lvJ(j4,Wl QlJߴ;7FެZoi޼$aq-'VG\!Y@CWnLMM^{[x|$#I%h$ř6MH &p;l9׏܏C/%Y9hx/$TY}<GzUjǥ8I!y2L%xv+~[*:Jeu߯,N/׋S'7{Fzۼih]m#% 4, 6R tn]c bQz˶s[J`EVsqێRt1%ۅ{ɆY{lu֣7lP{Fsp$aU*6ghZBa bRDD#y;q gQfZ^hӼ^)[ +p4tR^5Fs^ !"V"@zI`u$oIy/zVkI7-y76bopvk•h+fL Ĵkv=]k_w?<ğXXp鬚*&?>t(NK b6 : \'+"Ej6;BDzۿDmou%)y/ƺ#꧶Ґ@ gMYAoVCkRU*G_VZEs7LaAeKՍj %k2,b҆mQUZܔlsJzFq[33O5mNmJ cLc%K"KFdڐFBq\m&Hih>zqymܒ;Cr=yYǴ#k{mtLSɇ߭RY_ P%5_nԘe PHSA ,1+5,cgɷ`Z韰&ø}9;F@=_7@dadb*t_'gYOfg["ؐv ؓPli_yiPMu#w4Q ݿyie9rQz#v{=\.r|'mc.gq\0fiYܥ+n QU1Ax#;ڝjFɏνU1ujS5[o=isJ7p'.LA5?|Z}_ogz7Lm}Br 99ҒK/j1=%3^K_,$UDmKbEsʹPGLU9YK˹ÀYnqDkڛgxXC?c"qr":vϽj|nՃ"1qoZ~Èٕl~羸Ƙ~̘e1DAk(xj1K@ONi~ʷJ;¢w 9+j}s[Fx@ݘF{4TIikSIM0ym \ҒyM[Scr/EFZı"-n+ԅށF*mCY.&DSnX 2מNW`T#'k|OD6tfG PO:(h=sߪ" 披Fޗ[UBF3+[wcy>kzz:OY|v*aMIx cnҥN)SOt9Z<S5U1ȃ1Ho=ƏD$Qsz-N6s;>VE rJrEž!5!Rn-׮^]eHm|;Ţ?(M ]70s*ڍ^=^=Wj? A$ji4l˫W=(w6[ℰ.-66?7~yꗟ9W [Y1ǴgهwP⋄L5 .99gUs6 wm=}DZʤn pfu7"ώsC,[dv~n2+Y1KI2gS'fIsٹg\>m"10#Q3Rj|aAlT{+7όj!>X.v+N?͞Etޝ~)zq85A%"^=/}t?^CS^g_o2<7~Ϝ=a">g Q40c8jӖ4}GiD?L&&2 neiͷCUe:[1Jb"?кWȰ? cr@H~NQ/hH*J=R {W)H_RQ==<- NAWeD*!nrYȕxysE*§+x R]bA 1BfWKƌ-;/)`u0v6ǭa^.浻q;IibX"JLPL!wY91 F&nKbkyTz # DP$D|zڔvmR:,}-^&`d%7GKNKbDrIxc$sW(/+#bҿt*IMTO5/>HgF.$k NtYkG#>ua'>\::7OWUK.ϺwQ`aEŏҧctOn<]ízbRV=i>VԞۃ4ψ:o )XruIP!{SA DO.&Y>mTsg>Pd=)?uZGw?w;MGcn]M"HV6`dÎp>:?!j)W>v &);I~DWLcFrVi(3k)I)$׽@K?f8SNH{`b KotJ#7f; ve4ZzlOSO&.֊ 2r¢3If Z/Jߩ}V!w-['`}~".0><!U5"~?cl3F2ÝK8&Y.i~|ן?Êj<.kQ=D󕓵nUSs}bB<&,^@,@w_hb:Ƨ\\l^gxb' ùd^ת]~nVK6~9J@+ zVBNY2ʗ^&ݤ+q$uDTorlK6>9f}}3o`eD곯k.RҫHe +5ǥS\L9n~@vR]bZ"("_<),;R"CQߧ0]Ù~@g+ȲtJg1mN/w:t00(I݅5_3z/>3kA8Cppc ̈́`F=Spa*>rM 8ם^T_rvmT w{;"bͪ7}!{bo+>[~lS[nW Ў6a둖AOl$5Y&)WE\zN'Wjo8YJNXN+<+^Iƣ8"ҕ\ xU0ҜL{щ/3缸* Cy oT4eM4hL ͽ(lpE4&d^/ߖ[з^omԷ">o[ &s >x~Q|}>tZ>l?ևs =v|ȡX Z/ S=ԩM[ҡnySަu쐧 :^A.=ݹ5U%@zȫ]{B*V%8ATuNo- U4u^Z2T$}xѽSA4y@ҋEd8SC]4/NGj۶õ;ѫgUSKDfQ-/z)v{4V,#b*dj(ux$TۿO,싢(̯&>-3-մcHzwܩ_OU@0pvx 9i>}{of^z `G*rkUҞ8βqƔMWfiA(y[!cy_e~K'd09/j疨7(w<>)-5$]KqwP3'x .}!=Q.<ͼ!p>JF<"V\^ini#$qI`(XCME?Εґ@6:V:Y:64} e3? :rO$qTwztg Ț0И9F.kt5RTf^]ӯSHď*ACQ30@}]L!!wr|14#&[A##_(jm+AvEVS\KJe)7Y(lw>*m~iI5O᪽Ҭ XeI7k?mj'4-bf?0;*mEő۠wnëygЭIzR3r̩{3^RY<9Pt YJhDҩ?rh3kQg+Oig3TjwhW $L+jݵiEcJ􈑈 n5 wz;!Q !$S#\O[:yx2s;ߝ [xDjHF2OMPBj8uƠds蓇O_6ڲ`iސn%5ҝ*7ۇcJ:o B81at!nt*'S{)3 'v;ddrYQ܏>6ָQq|:}[Nx$[FI!,|*g߆h=@ 2?Q XMM,+z7}\[RF ጻBGe֮FLى) +ore tr)ݺ pӎ;Q]'I`2A`vi_3F9B lz$h:9l;#WuMn,\Vw_ZF>e|Bf~2!fq8dzpủvpb:9 LYl;zDfҗ(zIZkuOէ8l6dV|9=\Zo}}gdǹ[JW&J KGNwಭrwXDWSg<4P#6fqs",j{WӦбkͪk5=VW7^4Be{Vc2E|qKV=@˦z"W7fRjC%PQ^o;zEpջ g<(v|^Sx>Ʈey5{ 83&[]v@87(37@#TRt!l9){x F{NQfs-wդcbS&sUP [?X ,yhn?tۤxbpxA61$_;1}Ģ:&W\cT\iB^30;VMXS2‰vrTڮoNM$1LԢ) \FLD*078t.p [M`-۟|p|X;\/۳Qn]IG t,Fc1;N#.L'j('ZRr8-*bBuzNa't 9,NnW"Sh0]7:] 5rcԙT%KG:4v ]mЋωSS\;nrB.^MS!s2 tڥUK'v^I7Jj )TI3/h;A.EWnL{kK!߰\ b: KlG_KQ:HvɈC+YjDeF,2\_K2"VZRR,Wjx U7p[/G˙j9wޜvG|Kl:hΓS"Y&ˋk1lN.JzbG]$يs^ OUՅ :ٰr/#& |Ϝ 3&Sh`8QϿܴ􉎴0 Jԭ/yE\w(NePsu&dg;&Oƴ[q%Z9`xd~)/gp/}_oRfJ]Ė"7;o Ѻq$p Vx :,`&29 A#yњ.fu+f6 #[G@PFфM"ó0FmXxsm5fX|]tW?D_b T +Qn3.ZqN;/~RN^NX9W1=Z?>~^{Czm"aYLuL+w{a"X𩘆/&p&vg/" I'4_}DY7u0fVSRs.$a4z`Zidkk ~d~(WqPqh6&7$$kgbZ&wH?g=<׍NжOiT>jZ ?-t W9jwAUkMh&ߔ}_Tq ej\Zl T@0`V dIq UWRch-Som#unqn Lt [\P?eÊWx]ryuР)Upv k#f'p 3j+m0?ŘLBJTkTOɾ&IrX=\=T : |f3tg(аG I@Is'޹d)F&fQUA6VV$h8L=У:+H?D"86Q'^_NNGcjUb5/O ";"'㩆(nmQnΦl 1x)=GQZNNe2y z)jBWBuqSnSNR;Y čXi"~6!|5 NQA%t"QD^=5ZEH9yݭ|rA븎wU /|nN!!7Cĵ#3P5^L;6,`wQPvR,?rE'F\׋\Oś/fxLBp!}:Inh~ԹYUMDuȯD^x*aL>=ֱ>C?,؊~׈+gX1P#5K~|]ӈN X!jb}ȃYBdƓC:v%-LaxU]Aԑ:TՑy\ Z~EJT2.P~WJK.9*;QP"՗û r;I)9""¡!`’cg4(gTЩCEf ݰ50G\T5/ڈ" ;7WL1' f<گaӹM#7Odz[EOc'aa3q^-'#=/~IKr.Hx틔g0 Im`6ƹKMcBs釱O GVy1O{xlKsMWCQ೪+)"=4jKQ,H%{s R Z˰U_=L6Wj4?K1o6 ʺXm..Y? >eP?^R8bAk{rf$yq,4_ 5_9=:[ޭhLH]ċVHWLozfթ7{&wB1V-6Jx# !q:\֏xs1OhI.JgJxTHƣUi)yo&oCqdՠPL}uuqe"ʧA |ï~#z(_+= :y)9ȋ+D7/ujCuudX+83oXSMMjz'\إ U\b)ƣ(1nPWSRUзTx&2H֋ Ej*D44+7pBqj!+GTvq*A  ktnA/ {7%\iPc\xZlD^0%(1Z > FhSowdL6]F%@xtXJ0ǽ?Ϋ5*0ŻĪ~%ؗ)۱ym1פH׊0,M9`E.^ Xjl>d4l>IZ\F$Uf:Ⴞ:`]s I1:bD@B$ȆU Nk>1 .L)X ? T2,X'Ld ~I([N$U0t:d|}]B[mEmgrt| 5uyZ+dFTL),r&]/eLj2'QoFՅ"OW# uj)#)CIOfr$ognL4+G9=t ?+Q0` 8x8<ͷO@){? ^q䧃)'Fb9UHnIw](PN(C"&)IqϘhOlw+B1)/M` ~>nŁR$MG1ŝxQH7A+_h, X̬E/\P&C~>h H :Gp zwl.JfzO!ȜfWxmw2oi: >6#wBc}Tԙ?D}\ffaxX*UԣOkH. Gݡ&\BWt?SW4pi 4%lu0 M!b655&-lkɗ[j1P{O"c> V8q>"ͪ >\ HZbOiX^ zo(衑xϖ:1+Ev`:oRvA`A^a`# /Bf&VL `,g2}*s˥3ķHV>h( %#.+BddA4w>2SJB+D!w֍/RM8Bw 5χ@ }FSי;6Fv%&WW $|Y!gY9;5>@QR |hI09E\QK"ցHR``u<SAL\p@U5EPwwpݟ*u%Ko9i*U:ihWW9BCp4_VjGۿ:}ݮ ,MOw|x`jhNN׃XBI49uqw~@g,u :uaWً-8c34*JjY.U] hMP(+ | P"uV3ir,u`ۯ"䩨Qn_NU}]X{+ (%ΡQxzл,U]Ol^rrY+4 AI\hǴ”?yIʳퟤ"?nT"M"CJ c0HW.A_=wծz\58W1x6U{8c*mUONvt{+64Mb]96QblsXqmKt2#yYmOC6 +4r`1LU^U ěC:4fYv /I?RW׀1MTv1f s0 DF/fyH&#ԏOZs9{ -ߘn&!Aܼz{@o7y.;tw16&De;:aZ&bۣ:R7/ |v״ew|C˥LUDJ͝vrƟ/'$.0RDJOs-@9!OI,l+Fh&%jJ:PB) Vt!:vncA(Aexa-6z`xbr<[O˰ʼYJg(\[qOI$J[qڭ \|.DW\ sNX{.9~NjOOag[O%}rO5J'GXZ~ݗ0-1@4:{y>rlΐtc. /l7^K&JfZP=jλb`kɛʿ#i.T%9a0 <d#JhTotN|%gz6ǏHśԜ #_}EߛOH?^.GȘd% \JJi"<g2%4wlGD@FΪ$HHԜKv<:J)7\4T!4XF3OOT^:<)_'rwo#c0Og+y4\2/Qf'6,7>'k,_NhSy$DV")IgJt%=mfy%%O-_(䒡[^|,dx H]̘/əkfg Q Ƭ|Lw7mvζ4h5$IЧ̢jeWoKf~1>-Oj qr(U.đgÆvgUe:Q1X/W\Ja1lsG+ K1$GӰqegͺH{\}SNF0._`2 p;VH|J6~SKu9Ӫ2ʘ#vWlƑq%qF$vI%}S#KCѷ9\# Kv(;ײe'3gtY2q*˼9G^p;EgĎ,XV c; .lx#N81/3ݕs=n쯁7/k*#xUzwsz?lvy/k< ۆv%C{wD l4j"HU"؃" c!O/;~䌮P5zv5φǺ ^ /VTE^._(ùa>>>=>KE x6Ox i5C룒ct~`1Ô]ʾW*@xybپf*3#_y\F1%#~ pZg7͍ى#1mu}d|pߍ8:=fDXfhCQqXBۣ"ZkMwyd!T`?Y5d$#:^hA )e`@Tȸ}([C/ mA6j 4˨r$ "2,8[sӗ[\l,A1K`PRzA!. kf*т\/XdD9g5Қ>|HCL ϽӒP WJZ'@?#HR=(4qΤ x1\ ,Iza(yE &l3?#Y=Fk W0_ WXws)!\O;y05?CEaK. U*ӫQĈyU= ޅ%ZO̯S0$( Di+M`:>u>A`G37 ;LdPIc|r0G4YՄ~5 #!TN6[ B)9ϱWԒ%R\P=%^W7t/(.zfdkEi؀a~SBΟ'ړc;`8`ܲ!T͆9V$g, t<">YrQ>1Sͽ ?7noس)Ⱥ%8IQ6=FJܦuW~*ub)Gd*ݒ(SQYIPJjU VΉ$2 < 3J8'xщǡID͜])T%-iKoP_RQGz8Y_*h!K<?4 g~q-,|jxN0鰤}V-6ǂw;[dZMwVhy܉t2+DLTծ姻sgu61x)3]Q75, \KQ$ަ^ފu6M +FȣCe|ޣS>߯~]h}Zl(JS7aɳ6J~ppȃK'a`Ny DsK)U!U`L2:;#4 Dg rw~1a 3X^n*VtYq')U`Ƃ32e_ D/Ad3-Z`M곔=Dq_Q'c75NpKM>[ ˴ *E)&vqw9NkQŘYzua%FB?aNdHq (5++o9VBNǖ8񕌯z噆 **",'BApAhU,92ʐ,Z:U{qlJQh֚j"ncrjEuW`>AI`TII 5]i.>N$xjوbU(딘>CW#L^e--A5l-ck>v??\Kਠ8&Iʴ5/Ѡxb6ߺ~0[O F3 OE8O1n8y Yo0 xH6T} !boX8{C;0 q {UT mS!wބG+brۇATbwP5,nq6;'N^C.>R`ZzLiwAKzlq9})f9QN*?¶ˮK_39u:7@'$ع `~#@/yWk4Ei7/#̢P~r&j3ftd\82S'|ŮRx=[ƚBǹ(3Z4vex.Przhנ9^Su_3ggKU=Kp*v* '#g>o> wI<ؘ3<߿8`Z_s(r*`2KϏHPBIOx31hݝ#I_;׸gvK[Lh 'Ys)Nb#D> I!-p ::mGϩŢMt"&1Ϯ>M\l,]q7l0D`V+"0[X:aNʡ[S4WiI&x\]r|;'ÓWfxa,.s˂i17μ=HPd;?%0_rW8uɥLSEF pLa%ȘH;1yF⋘Ued<̳y Kz#\7[KeO$3Ysy֥ 7] HF8h;hRѻmj٭Æ):;oT{(ʢG>an dԃ@3%7%}p,%a\:b}q"ij-b>|]9{xGѹ&ĵ 3d$a &5q3F}:XRUlXQ H%]Ƒle$gw :Jt\3KnSH*AꌙU"CYfFdzmhAB|BH-JdBٓ""=i'%,/w1R/#<~ʕ'"95r}LXxG+T UcJw4,'8|$lhY3C]Sas31b z7,UYC=7YKD5uR Ao%V3֪n9-f-~Hڢ ['yVjzFvj޴,:Cmq٤y"$ak?6ujʧ;*Cаal,b9 7P5v*;fau\1_J0Q4K1x;p^v < Zjf%sh26(bfT )QpˤÓVM-dH3Au`{Qh6Α@.JT L!/e e]7FwsbJ<ّcTkzlTC,ĩZ)A/NsC'Cl&8($$ 68|'ʰq0{ArA|OF>Й]'d{T* '#Bt$[{V͟y!s1au'c6y:4!>;F @)\H;9E5a=t%,;AKt| XP4CL D l1;wބ<6ī GoAظ @c/Y0<+=džMG&vBBq0U()Pu[EYx@(&8X x|:G׿0ÑwnwR3pNp敕Or/܌TiŌ3{tQKr/*1y▣Dyۛ^Hz kShjp-8i؃1ȑݤDr^mƌfg# ]{qwd 6J~Th"1ʉ ,x TqRquBrxFqޗB$= XGk"Śh[eV`@Pa$+ô4ئԜc㌐,ΎݓczdRK=/-!Xf<=zLjh_Ihd'A4Ý&.yp!"kMq}o:# 5@~ P]ry)_+(_KVadE=,Eg:_%^b$o\jք"ӭ쓻=ݝ\=A=[#r~_'t%9ɀzIMu]K yg]Zf!3YXmAxtK)u8o7S[͇1pHL팃xJȞXG|5I`uaj8uv|fgXWopLJL&83Ɗ'}BʥWkkkg%;_])NQk{t{tֿf'tNޥF,5r^ +ٶiݮuǔ]ۭU1}sV?Bfk4vU.[$(z$Y4MIO|ɳ|_)Ma~eP塥Ǵx;»P#CΟ0~h6Oe1C!qbv-.U ĭ y"w?ʢȬ q!$&u{?PGy?BkFHd N`gSs7TV2rVΉ7.\`0bZm28?j (\j8_&M~AO;h/"mJkb>?Ю t{^w6*rWt~^.Fb.tjq i{-Ⱥ:HݹTc*TE;^H="3e^%16(UK )7p9[tUkk;-姊ta](c=8۷kX߯D'p :"DEOp98) 輥Z2sЃ;aC=y*Y容[}Tqrvqx>"H-ت3\vq5vI>ɦ7MF3Mj8v)TQmP ,bFO~Gav_e)~adV•MV!~6X,!1~mxCՠ/ 8(9LsJRȵ5K&:}9;v_e;< wpvwa?1}yt5#f BCw'tY2 =4C&*/ <ȳpFmݥGo)%l"+$IH9#3^dBWuSyl_t'C:xQFF_ZU{.o3>OPrEʳ8uPɧy.=sz7v~s'9ّ!E€fh U@kIb#;Kp_sx1[FT7~䥣MS}֡g\Pv*'0k\d9Xǧ^r9=PA KW:By07Ň'A3sw?2״a6_ɍT6{ bP).i.md>ÿҼ~̳3Z z`oYU-b/ 9`)w#zetڅ~e%`&ק5x϶Eш0`g';p34IMUl]G'}>zqGh6_Ý]Z&%>/=d߼kWxlr[M^I^Frb ?Li0r5Zclc \ SDUwb&:!x+w\ҪzlyoèFܰ+`xk=3:0?Noh_U)4;kYQL 3 ˹`V <et$j5`IIqNI ] 8F+ćO5r&`KYG~M0.~Rg5tzV?S'7Rsun:'#@`Љ|]IL^jiuY%mht}^U}=+0yCl*6M-PKli x>>pŔSٺe ao߄%$wi<3kdAՅy`魂tl nKhR^pnwO-y'\rP`?w}D;ރqg$|>"'D9lN6F׮[s~+5VԦA}2[ݖac5GA(Ixa/%{{1ޤ?pdn.YV3\mfyꨳkY,Mmwi7X7V/GwiW\O-`?J=XdոN"55y?f*[|_6ފg oތ{(AxWd'{T[ /13rV#Uɐl 51{- mtFuݨ|nu NX 2D8HpZI2<U+/ɫlPǧV$LuO<|[[CV?-JD|[Z)N%Cz$+oyuӆɉAȩLʘ_pWI(h_ۆHJ!Drzұ<|kbWȂP.K ڶD>p< , qus6G VڕPP_NT;b.ծfuŏ1,}XCl-Fc|`>O3#L6ҀR:rbo!L+dD]|_oNZ 0Ad&iC߹aCI+p3ia g|#l9ywNSO~Ё35FTӇxHwhPL[Mn#O` Fk;~x34e/6gN;48H<#Xͻ)vɦlq&rq7g3Fs- ny=qz] $3x{6WJ(T9Wx}1g*9`e6]|f0*?{qXNxF#g+St\=%2#$'5@F_*&D홧nveO&9Qt![\(Pp0{sʏJKvnvOtt#adEؖ\hkw\]܂|j6 4 vB ^&ioҍ¹*~{iPח֟xzy?jWs8͏Z1Dh$VZ#M ^cUxdtID#{?ax7j;(k.!y!J*дYQPq/1fw#@_('ׅ UjuP 7(rm+%'#2dhPJܱ!NxDib5WHq}CPQYmIsKNcM X7ԵGgBŽ]ط\v{-~%FC_Vy9⌓!X,ȯ݋RB'Ykh htL ҷcgAOaHG?H;.!bո(jIƊّ=至ӟD@Yti@&s?C{;3_PTT0\$CF!xs@x <*jHUY݆w0zjп>hGySU0^2} u cuS&e^//t!LET vY%J%KY b sU;MLEμDrZ(%:PkW˫+ĝVVRo@ N+avM j;NuZnHCGxgĂnUiB74KUv~0MGsΥjE&r0Svn ?aY ΠSZϛο']P|{*_N,:5_v_z kHySec".TH~Y#>kBKR/fK}3Jw!ŅD`]6fЇ}u£9>.k@&(oƃVqo?lYu6(=p~P|p? %Oc8Ӟ<n#c7MRJN1oǝzlҵꞎ㏸wum*9u188ߦ $H9٦5-\)ًzY`@r+{j|JO :sHAs۳sF߅3ipi Y%:]⅋BiKCOP,hY+_9 ~yͷ< BGʜYOHP*&@H:4PWe5}OB ;}֩&})Of\llκӡZﵗ6Ê[?-BQ=D󕓵NUS@p8B0@vzV#dzO.&1>j67|6q!Ofxżv]}nU`?uIY]ɿePHUAREX'@OK7Zbϊ"]P9bRyD\zO"Sw!"\L{wyz#_/t"m%OHbHb! *#G"@D!YsI e 9ԟ%e|+;Yv-:rjфÐEa2#Y,HFKD౴o.'pxS$Z-,0G:]տNq;0 P]!Tlx3݊@CQ̈́`=ҍ9 "C 'Ĵ:SOhrgGo'ceFr[UmPrm3l3~SASWzy[mi5<}FOVmiݒ7_[y}{.ٷF,=l; mhڀ}}h7K}yU7 T[J&k{Gw0 ! i3V0C WE7xtLiqh8['9YPߩ^uA36,!Fez?%gtB ]FUN:QeJluyg[O $*zLUz1,n/`˼o_J t@;XD ?TԴn^N11_~8ne1+0|B.1󦣊>AYv? ŵX{t/1UeP!p^k6w:tiV=SaӬxR`9K;Y1+Oղ}Xo2.gJRBۦ<lϳ9{{;kΝ{'/숳-մ(C)Dej|g_Gw5.y69npf tf5}-߾~hjjPq*$U c?qԗ/oEO߷~ :ZVӯ#@bWMxg!M: yW5`o)O"HUX#wA6\Ӯ9(L^rP㱶H%?'[V 3qv_ɝ<gk ~thLušsJ2 {ˣkT"kTwQuڸ{!8uO[#s(C-cSI:wm;t(r2{r7^ j<=cE9{=$r e53~ 6&z`[s#K0d**u|392nff& )bX"Cb_#Gb%nsj(lTo4/A>]|fփxA44؝I/LrMh% 7^0|5[qKR+*-+ FLw7V8VzJd"F%Yzy 01ٰT*9L}G3#Z^ΆkX:ow Np#c"6E̅+=^ C=L0fXY@ @JNjѶr$]䩿m ||D/nYpvFEq4Aę ϼYyv֊: Ju;>s&q6yR#shۗ6ŕt:BTz#]bN+ô=a3I,NrZ9Q0-Cc6mR 2  8*|;޺]wi?{;0J~]N:uA.c$ʤpgO?r՝ָH\u$my;pLᛊʓSn?^cwfS;Y͔In&۔zwjc jHzB9RxMH ҔwD^&A?Y6^Owu`γ9Q Q7ofQaw* f7o.GXKk "r|߆+ m>rc']9^i]ؓ`}BRۨ3|i ] c ovvS9qΝc1e|ev w !&Q:$y[!BH[>.[^f5Wjva_0qO)O%ā/- >衄|åOwozjabC /]hk_c&P]܆bϯG;m4\+^Gs> =.!fd<w/[)D gͫO C//r6R.ztM J,nՕ 6 D"~yԴBe \oY ٗvݡNt ѽKn4Й0]nM>KܱU6+2b@}!j'26_AC7 DV)z4J\DXf`aIG [ 9h'N_ͼ}e~// [wZVD<ثq8J6=<-jF3Vw Wݭ!rp) g#4}m(Rqb 'v=݄@J*G9)qEYXM%GWrn?M?CHȜg(Q ]qƈ8U$`z T͍L|#BAoYCptצZB\~5COQw,I-B@u6n= OhD_E('>{fW8' nCMw8ӻ̂tqGB6E׈&2) ]JoQ8伥ĝ"rB"A$AR/ɞtam/A(PDս*He|] j Nq! .8J t K(9\Uaf\UFLCr71JV掕^ Txy VnL&wŜ +>,̄VQEfs6TD*ET 3)LNOP7גn ^7C\hҖMS UPA;#UE:N[G11u1Rh.3nZ4ZvKP0Q̓#V`ZQ[ْjV(s"Yfz:jk-M4yIz}-9;V"^=gsJ%>Nj5%6SK7|\^ߌBON@3Vl*˚1V<9T8ʝTTWrt֧a6sӈa mW6 '>89;޹,{KjB%쵺M_s >0Gr[jr>G=Tl6mP|GVG$~S{=qm5%`v$CϑJCUI$PCM[NZiPs!5׏3\vu*Aro4A[}dיsT¡VM!-%dnNktPii+A3;/?1Be-z|ѮCoNHgcBi!x|Oڥ'ID_XQːom6 x'8_[ tĺljoʳNf_=ɍvEyD뵺mhwfnvոl5Z7͞pzl7 UCjVMkv nw;]nZj:VMj7nMmvsy5]xM7mTn;Rvcloo-Ekn`llPTknvWͦUӣ)nob]L*mf歵-_MJrozfts<]T&TW:m[lVKoW MonɤҠhO,Tu~[V'u6Oxi^OUp)KB w%# .d̷_VZ>0C 羺^ދnlX!ٲ[}ؐ{av3C1QMF4L"ܫ)yg^C 2R7k!;أ֤Z"2K^sJs*DVS,@.W9 X܈ƹh8 K]9+X{[:Gu5섎]ëxN/Mp`2!ïLqT@\BxX–[,sөrnTM+xL?@b[1{HLg )Vjl0wըB,50u7ȴ3ws ߦOhnl=jFw8묐%M,s:o#f䑹>ߏb&8T(-N :W|0E$Vpf$ @+@bViSL3+I.S.\2ll'C+js$[iv 9M (ѤJT۬hsM -'VvWӗ@:ITUQh,X+sLAzI n7S +S0bWS4wϟHS}or=rf喢l|1hrvK' lSUDO]%^ _*̃ʊR)2,(ۍBuk ˊ+Q5xOŕ)d= ggg{IV# *8Cus.LfI}~<S đ Qoa SZ26]^l-쪵{c:0mYDž4miW;)}$tu❯Al%{@.>gbF/|АG5R̉ʞ17ԪsjD\_Krp10IM8߭x; , 4`Iz%{ aY0)_kY)QXr,V'M&~rӍ>,-F(4\Tq/'1WxnSG#P34&]|<ݖ6,BoR趘V_uFFe4@c7OHrhh'Q@ xQ7c3 7"z?F<< .pq 2-]ߒUAiA$9; Oi2+KOk='nhR]/@É.v!Su-u|r/k$VYW/.#YAS 4}lp1dju6(БW~z#''Z|s]Aw{\ßRF;6:0"H="J98糡 p 8HXO_=L E\ bd8B#3Ƿ; r=sߕbLf|nBX$HϒjNإ8zb"?^[vxep"Jupaʮ"^@J,16W<;_쟉)0)?>%Fٚ`}HO%t}<8-A#> W?/U eQ0[Y ſ.3m;V_*޺ `:?1p)dX~q~&)jꈏ'hO=c-9.''_y '=AjFf -%K.fށ7.c&>9,g(Xl=77ݧJ~$x*9; w19NeT@J1EV WGO\ !HIvQAXnq?)h;]#JQ%sY.ÊĆ(FOEiPiC͒Q]KJDq0+oC<"![tFa"pkPpv5&r6d?di 豾񙍉㎝e /8&a}v< {qNjKa 7{('"PC F{JQ11@ wn`f1iD5K!&Ft}Jg;li!_Ulia3Bl `BEsrq;wŔ-(ܢ0_iIr@fPhzCp4׳E,x}50t^niʹ Ÿl.)aLg'FٍtblW,萅toL8 :@m†D{VUݒohu8 *j.-s|V%{P I@ڙ~ /P&JG"ΚGQ4K2SITQ.vYqbafy-@59(O:RG>&e1x mL?l djcJ"3o sr tiWbV䂎^C_ <[LnZ̮D4שlvxiBCpt48.wYgXN H+JiYf% 07t;&Af^"vT*; ,Z 6&:^+ŭQ畝UXQ\ wb\Mʴ!؏elDnaaHgGUjC,70ZWc2\L/}K{/N瓝_Qsg<84XWDh)[5aQ3J5 .rӫTRg} v(GU$Q~sDOXyЄ {ix3xEVVZNgધ K/[R N)DDC@U6:\nSdQ(kS.٠62]6f\t][c_U̠1D~zxdnҳ) _!m#GIo1Mc,WMp¥"^):ti=҈u(FwXA/n0q@s`Wٱ՟ae!%%6~..PNѥE3[4 kmTϸ#UP&{ezxGLU}T?g24XH-Ʃ%S|"C $!/)ѮkF6<+|oXWxEXg_Z;D8tO'w0$azB4/7\O vI-9OƔ6ǖcHZ7n!Wǖ0 LԨU`r_&|`g8?m23Nt҂I'6dZG'ஔ388ëtIK1N {Œm<,ةlw:a V5-iHEgu2Dl>3qVD6pJu]lV*K)`uC#I8sj^1:PH]L ō0Ȭy!(s>-1AN_l̼F]>S*,">,1U7H/*yfh 5GEg<(yr^ 95ѪO1u=L؇=t.8LT>rBt*֎ټy jȞ%-u_vnRt4G9iT_Xs7D/adR $ D"!OsҏFB/#N[qULmkI%۴s`xa(MArwnr|2>c"SԌ4%N.WQ R4CmԩC7SB=Y8 u=+Yt @f"aG-3,?vl} dJ GЯ;F5PkOUD)їl3z9KQ ӘeAxX5(qfsr2{QM~;G\RZQJC)t`t`G%1 :(.L\x%Ulds>\)oS6mCANySZUMu\xl[2/% -֘\SL+);\,?,J4Gji8r9wIiԓcbxFȟFܕ=jCmνI9 "eY >l":T.\0MBY0/**FHbFlUPݘ Q1‚1OYg`N:)^$;kt;\+U^HbibKë 1Чc.ʵ*.MYUdopvah~c<̲ IS~&)]/9B[}vݙ%'&Vˈe |-e儁\)jG%c:g8" X#fS>S9F(В$.]n7& |$ o,"73+-֒[a^嬊-V?ӱ0c0죣@gGLP!*4&m#30c̽hIΛ# 5ТME04ť֜GċOQ2q!stDa}5V]VX$3k[v)Zk Nk֖-I~B`:>Z-f\:Ѫœ#?I8N#m^}X,ʐ_1JV/ zCjO󥎾K褨cjNQ HʩgAjDW@`>Xd8 [Zcce̿ǘhe`|=p "+ I' D, *Ye+2QYU+IsAW I|y"M}P y Po nOp.t/2`F7OOqE8i1|vYE^1-+&3 [~ IZ?: ^ \`>G${h靮$ K9p0{;lLס]U/89L̀vC'G(1 M ~^uIL44z 쾠&XhA*TY)45<w+F6x7ձjOy(ŰTNS8+X]tiu5~` ѲdJ8̥JZM}=hf)$d΂Vv9Z$k-A 2MyK)ׅqQ7 ]> .AxOߓM].wMQ'a -kx VEt*k:g5sTDuD*>]Wdk4`[bPvMv/xԮS >RQ>36,G.A*ju/qv LNΠIeaqyӉIȂ5 _[;m%4{AUW5><8 }ޕDf0_$d5;Y;mU"if&bG6AxC[d8S?2z#.=8倘sB˩EjwH܊ds@})l>oOqlcbRca)7OD8'qey}сIl<"TJBfWGV=B| \kV<fwuH4܎#tU͹#BY I-$ Jzi=.sxYM2rP+-j64Q,'_i@t"5.U|riHzAeVJRԹXR&9  D c8zhVz2]hVГ "1ˣ~Pf]LaL0^0 $H6^Arb,"I`Oum/M2I5E٪'VUAkL+O}2#<3T*[!~7i_R"uqUpqaQ㵃?nڋ (I 8r<,f`-|$w緓wuN4U(0g)0w\YgIǗir Bgg0&4֛ĽX8uX~j=F;[.]%i ڎJr.:o=zN-hI6VD%1tbV|x%1cUDy3ݲb"ͥM*7ɥ\qҚi @|-E0 (X((D! Tԇgy?wwxYŮ W+/`Pg Gsr,U rͯ){>H md>qy2|ϸ_C\ nR 0ٔך똛d/tm*$ԛ>ӏm2v%R*cn! ќf8W|ҸPxT$c!MV Gh:1FM A2z^t؄ byt8Inq<%hX Ps#DRA8w"mۄn[t$D22(70P"z ·`PMuF˪sC5䎄̧IN_%>%^ubl|M 1gnϚ RH㤹- FBp~CpΫ[L EM.w6F u'{G TaJ_jECHR=Z<\S}&|HK]_SAF즬롆֛,eW\.Bn n YӉ(yu;D΄uàbU璭' ':fA9c &b<2㢝p$_;QuaM.;^Yuca=tz;>-g_"qPk#)Z<:HAdjIlbI0]wg'/}PTa^23 WӦoF6acgjXEI21F,Uܬ'b 90 n /O)I޻1;tE%Cxg.ӁBgD wX:S9)>d|*N={ NΎqzu;Bs TE>ln%Xr(xD4c`\%Ƶ%Nz<w*ZDGOJNLBSuC8hh, ~ "@wbF^jldGɬ֥E8v;SXHNITF!lc!6L%n#B"f>n#đѶ&BFd*7,bn"mWUi?$m1GؔS,vh{'gg ;;:ׯ8oR>2m5mƏ:?3J + `{e<)eNdtLj4}Cx ,e2*?ˡ\Z ԅSy4|)qfR2P"ӞKrM[ꋴOwJg! *CՒv*g>=ݜ\dCh1gkDk '$< :"KsR3=$٭tK*d\ugٚY(mⶠv<.!p< K0E:YA6췃L9ث;o O~nv1'ۘe(e6.rLY_k:P~p2/*<)N<3{NCUet:7NUKh kHMyU9U-(tP[}ڳOy4m"yW`t$Is~rt~֮1RB6l6ϨATLv[ &f`s9ɍ[en"s-{s%v8?r¾-8#bi/&ѻ;=Fߝҿv`Ws9(hĕHn7unj;ASc. _H隴\oZjXǖ+۲v6-pҊ;z(4KGDB7a/pڏYs\"KYY/o_5B6Yrs?AZa|.Ҧnadžz|:ZG TAlzu#Wt垏CyIwA kE_ XI|x[  Kn(Uvxg\oDQIE=' `TvƖ e!o6&|pYFu]Cx F{W]^̉J-$43,1]8՟[&F9\*ݺT!=ij,VjT^U+1bi~fME6d3psbfp:*e,4A E19(=W&;<~BUmlOęh C#:8u5TC Вsp I qdފO7;&=T]l B75v͐9U 0t3*mU| r9]}]¸FfCOc1lhk4)PNQbj[s>㖻T4GzFfr.?! ]XՖ}diӫ5Dm&l\YLe;gWyj]ƻ`}R.imLj`?Ȇ+ m@_oc<)չۿ_?Sti#67!t_ %%$^Q*m_V7tfnֶ>c~x jr#_e2eq̣*Q 'u*=ͳ z"eKv.wlF C5^w1ݕglCV y?iB??8f֮]ڝ>=9٥]lʽf$G[|g.=6k! #|8fS"ZM[+y-23 qu@(ZuLv'7 R4qʕEWРT0ruKQΡp8TYQ0+09 [ L-8vs4y?Hak(4<5s#ĠUϕ(lyoFܰSjnIgwlG>ḱ܁ÁJRg >r G0%=@9}{HS[Z30`!MP5Heb奀{Iɺ,ob3QKM^qtрY{zԩgOWfB--$OP˴Zo {jo`qh*:UBbJ\nP!FzvFw;#R*Cf%[Jd`% K;Z:u=5,Rj#CCFD;y 8qW.U~nR'-lS ްJzdsPWpr<@]_fXѩ(%lc@*ٺsG}o\̝'ə(Ebe!1A@oSGQ4_~D?oc"a!ap|܇0Jm> Vmd1=nQn؋oZ,w| "x{ h;`rJ+b= 'W 3ڪxEb,?s?0˰ .F5ʨ.mSkuy- 0uRe_w%)+q _+QkB@s#u 2aM}^@$+v/k+BBB,9C䥺Eqˉ̀1R0/V}e$)8KKTJAlBEMh_歼whsFzs\3V޳2}^WG,.F?6&e+~ow(< %UwVa5N4yGDONft!|֏~EC hfRkَY-.wnRK3:9lʼ9Y5C}džҲ%k~$X-\9\{ݮ E6`t4ߎ_ZgI;qwǤ|Ec ꮛz3S!I(p0 4რuںԈ4d$ c䬡#_G!j/j!]viW4=~+QWc<ȗ끄IN8I9V$r%ޜ!<!s FWTm= $ysa @#* $]_$R^lپOtnђ peSQ,;Y,# _߭ΨJ"J`#ݨ1zZ5=ը̦1z}DG5:-5ÏվFg/=76RD0ؕ$n8>d/L*"#/_*5R#&:ي$VR^Cb|uЮC*HEGY &XcVi?ĺ1Įѕ8jOLuTn'6_WZ=,ܣt]%v6꣉uc olMz KzXj+Wrgd5ek:nCJ*[&t} 0ye{ ]7Zoպ;PKA=3^E8]KVotBe_R:Ԉʼn5n;k,S>`ќCiwf1pqe#֑rABZf^hg*hMhzDOy|C[mQv HIK1]9J+l{u=Ķ6|ZEw*<4VPMo< H7a 鶶R~B6y [<{;E*qqp,_|sv{߂@/5$hMF8 ,uRyE8IBlb>P@c_`i7/ԑ;B"Y\$$ǵg $BFtD77۝߬xx +Ѝ^nrvWĢu_brڸم>eE{_*l)١hݥی #) '~Jeԭ'./^M~yʸ_tΰ=0C]['u` S+bCbP]*ʩ-}bO#J?k <[Q-K8FNM6;z"*8ߍ Eyv,󦤛`]_m/)7˧0ڛ1s (mTuu飸Q #FܥiuߞѬ f/6HՖg`Z< ȯ.'Ays%He˻c,iO͊9 _oB[E:Ea+Kd ;bpۖdxi^g/ pSr )95ѕ}ho.O:aн˜p4>?~P85{#/΋|E}$Nc x^3l+f# x\/+غ%$1Ps?ݗ3Wʱo<70pV$)fY_@ ,>_:M@=-.?{_ZWEWU ey;-fe_%(3c_7n6䣑z_Y2p^=qCAX/ ê}l% {n1)%we:^lv,i]e%2Y{ϓÂ+uԉ6v 8>3>8F&N <:WCT }LuS?^ `Zg!Q7T}RWXMiߕ9K?˂|{H..~;%%CDH2`b".!}*<0) 0YD./iF4Cn 򝛢Pz ir4n+Ӻ"нIy+vt.i΂rr[dީuSIK4m~?ԣOo.?._,ZآlŤ RjљTTHXVF;R y[lqn{"\!?zv5Hb`:aң⾔ls# ]X&,%3NG$( Ji?K;O ,W}^-K+A:d :Mrya5F$2*c,;D;uӿup^`=FgmS$~O@_StHչxN|r](OГ݆{|*N#i([#j9^`:\C=&oW̾TSciLJAٸo9J9:Kfk+;A0?5O6_R oE3nܟ=ů5X)΂9~9 +[r7G5_9Y+T5|1{ TpQfV݌XsƱ^٨ ;q*Ϧ0;l~7ڭjt]UAM7CC*׎VqSm^6;(YԻ2IjS[ǿIQ.6-wp`ԚokA;⚍_`Xyo@4dUJfjs?5O3gJTa\cbes?< Y 4Lnju8)+IV}^epʒXZ֫D@˾΀iR劓ȡ~'t-~wh5YWt rڧ+KV$ {_틟WB`r1b+.{lV6tsGbCL!j"."rux)mٲ#&3YǼ3c8鉦~;u㇚o KBӓ2=En}?o"/eBH"Y0fHBt: ܌#KHY,Kv(.JX8^86|x/P*~$XSxV\x)Q7h oAV{J`pD٧)6Y:;"FAy'4.DD;@cg5QLtm&0٭W0^.ή09Ž2S3 nwmV팓tc<1~g,s)U6pu~mm)}|Pj g]Q9"cAԍm@lV~ErDH*hFgnZ!J |CTif*5ͯp*7_A% ї1oDaJU6dǁJ8k$CX4ܒH##ɴ7^Y)]p!f-6\V= i.)hY6_!1F  2SF;^Eћ>.ˑ=hP˼FRbAgP8pKq\=~ԄW#@U1V nlp̩蔉v1)N3w #'b0cu8Y"f83(_ Vg Mt9 V2+z}Hwȓ]L51z/fW<Yr:iDki,e`kg8MU*K FnWs+EkIi3f=[d<ø\8m5S$$䂙Tw8dMS;q仼QȪ]aKa5" 1:"wws,6:/DcT- g #6p2;ǪƏcB Κu2|S oT~9@ 5I!N'JQSi ;l|S&*nuWuZ1H N^ $TT^Xk`s_me"!QL]rVxc*M&q goʔ)" j P1c|go;l3)%5tɅ2G ;3,1| pd,_R`WERVXQ&WA6@3O&1,ůk2ZύUy3:aҤs8P۱&?[^a|N͖wJ(jM|yᚆ;;@Bk zN1 3˞_h7xKDW&|V?V+X[lMa`LhXaj8vc.^Ϥ"1LKAN4vΡT}ё y=,[Fz?lUWrĻs.T/ZfGunD3-hC{p<7@LEǶ5'v@l?nPkS]A؛,V rj+O0J=yG55 ɐr<0o'u87n|R|㬆rkM-0t!~p;B7tCM?CZ4l_/s,aBreZRF1X|Nun U %Jd-~VrPI8Se$*ˆ:@) YɚGu!S>3VA]?rhSg\pmiQa]Ϣ~2^:tWO,F7wDlrP3~S2 ]Jہj$ 9o'qExEYMQaFL`"i.f{-,0()x$ouYpz?]H>3NDl9bfqs`[ ѝ\l>X掕^$xy זcô3B*n9Ǵ!חlQ~m%֠᪤݌4QݰH 5a2L8eC 9a~T+hGv"|8bưQ4͝۹ADrhH#?:sEwЫ)oJH%Q2(ðy(B+T|&OƸ[a%Z9 6 P_H|7;Zdݦ%P ”ewZWUW93oUQX3 :.y3:YmL\TKD7}"nG@Sbo`,Δ 3a/DŞ@ßv6m~:kR̠^IL;m$+"c"DzjVhy ObvykƹŒETL( @|],4y&4a簿zi=(Q/ޘ؅fMMFݖ0J]/cIѮp h'yseh'}`;pZ{ YbUN3ϫWEg#asTmLՄ~7! .Tx>\nn/Cv$&6 ŌS<@]x*c$=#;̉rYo." 0'|o`@j Yv\KWp 'Dq>0Î1"5ZNVk.L/ݙjy; bx8;dF`GezSH`b7gs\>7sL;i2.؅×{rG-X!}}9=wv7܀P5I߂i~؂VJ ӓr.2AI”QoL`NjQfYFn!O*t56瑛@G4zu%pH$l̓&XKD}=>ndo@_T8)޼޾eՑ:)A/uRgJ-Rah0@_bM89z݂HM=u%} l4odx3gmhzBAjG˔ +Y ?y+BjyLny|~<vA5A'iP~?ofb5w7cG L~* e/oA4B !1 1G̱jXDu:P~>m CpyZ"SaY>PQGv6oFYnq7שT}nkby~ukjD(9--a](9 5t}moj&F.BroGb5az#戝b+[Ad7EѓnK*Ps4RkmlƎhw^;n9\ ^G.exE0Y(2TQAFiRa4GJUňVi ]~&ёˡ3jr]3J&m@gVEYQ=wL;A']@V!]ֺ-ĿJQuI7[0v\{fe"65M}Rq/֢st^ETF6)V韪6zWz&%@k6iE 89d.]qf 2rRNbJ{bi0߫޷Ĵ|Nt&Z8ܬ܃e! x hP,!u0m(6=w H ~:s!b@jvӽ[I|7TiFr[`ic%;`5Y:m4~خZFwn<8 53|*ޠː؁ۖᰭLA=N_ґ^ܿɳ?דsۻ!ǀҝޠې*w.j;zh.l4.6$Rǣ'N--8S;o8"%u.R}֥vНz^bG}u"F ;v./sMc͇y g`:H6: n$ #?d/">z+o-_PZ]-! ~iu˿.xUzs7xswɛU{΂1/yh5ŬXԇ .?_ ܭ.Q*5LՈ֍T z{}ە{TvP6(dnEݽ&8Xq@Ƶ!w7+tۥNT aN0­pT׊ -5SmKhouF_l5Z^o)M}il]\Dcs)߼i7=WS-ےi?9̍^g[4Zf~jٖ߻NӔ{&}4j7֦fّ߷V~~޶oy#o7Z[-۱Ԅnlmv͛n{u5Q;-_Z[Nzquڭ`+it67[6\z+no_/;qf/0p8h8i[:^Mn0W̭ʹ{z6aed{D)7$.m3D2% pXQ[퉻;b^D$RvlY3>Qܚt:^+}]DI+͹:@Zy9QM>AZ,eKs#Z`]piIf-= J01 >ëx(2D[$ؽ"QFeZG"tG>6#0tfF5x83/52w7t~_ߏ[ju#/lc8lV]U 4,>cqjpHV h`U`Q@%kS ̒ % j)!;*oQDVG0*ҳ+X&%@ \~zCuNl6`;:Z ʼСnhlyv&] J@MԊĮ;֐@=RƂY^<՗Ko"GKg6 _)`)WS*gW]Bۜ;X*f7/e@fxGJn0òygwg$ %>b3$R'=QϲC~N&F_׬ȾLűZJ{c1253[` L*9ٞJ,lPcɡ@Zt.QBMgB6=-!GCX|/1%HG,͏ ֏GM@B>漄gB$.OrYE2[*<5oJ%g7'S:]-S~"wXr{# ">o-Y練[et3eF|$LVPԥm̦:S y1źzt]+Yw~z#2(:ˆ&q@[a[+{%ҮKgHa\OUlB;'}waRgC6tw֢SiiAGb;r=yi:6+ٛL॰ i61K)M`l٢~6JDt+ (F|dw~ $X{)1G*@"6&殗 9:Vġ-(SRA]Q4|yr(J1dor๠cn!R ;?EX(G^I^Y?σNQ |&:a@q4,Q ,8gvqJUK *S ?*BD@XYv' ڒŅ&6El ^Dkd lgA4 I0d(Y{q7e]̏H???)Tt.'Yz?bPТQsH+ۓm[fCj>yx,WݑzA]Iw?rNW<B'=Kt`餺g$:x6Ybpwsl齵gO/[#C]+҃h3 c1oՈPpgEaHߏek'Q7$vkZ/pG OuBX  ̜P0"t$R^̤Q1Du%a^aEj-Bub̭ ӿL5MˬN~z80m|,؄N[yB4DWr {cK3[`sߏq>ph KzoF} #/&7+O%b~ S$]6^pZ' n%H|pvZYI}= ;(KVĎidgzS; ,Z vHt>4ཋSa!xWC툆dp< 'Z+x1ŠEZٺ5T$._QoIC%DDcdR3gGOTc2tV.Oƈ:)l!P|^ql)sLHhbRIF&a8pTyhc6JY$2ԋQ.:"q k0DtMqV-5/s$` J#~4j``2--aOW3(+&6#Z}KkT ̅7h8_%H@30#J }ʾp=]KYtmb_Ϭ642^O7]6.u*] L^Fܳ/Ͳ2tS7cW]ܹ,"Q1DMdww!8W^=-ePA1mvypv Y$j5}| 8'2P+h\ Q:Hs}]o52k^B$bB";l$Fo"!cܠY]Ac.l / FCXՆaK4vY o)X3wo mI^| [Hi*4>/?d݄Bkh9 cU?N)=8_ɶ#$bŘ1ͥP,M}p""c~H.UE+>v\E?j̏<<#uQPGlrH +Ⱦ.T'*MFq/O8}L ?_ =p cn K顋gSĆEQ?JlSP>ccT*ǎe]ǔ^#]sv|>Q\Z7 N,K*1c'Pߪ`K!; Z5vq]B{Ծ.j>vF&BEQx:w&YC@ 9',`9]QqS:>xn8<;Mn@% kc6? 0 NԨUoC-LD4(2ځώ-qBek%vZA;-%yyNTmȴO])g.Q5qlWlgbX4ekŒm D08gIZZ Kc#YلW"w REv dCG! ?iq!]<й~76<uo_ b`4r;)  =Kڳm YI~{`l::}' JWio8IZMpū9[z^Z"M,=D~JwbrY\""?9s+GtC$ϑ=MPMÛ$g#q;;6 fqN挪ҙ2o J nq#bi*A#rpQquCKHy_}$|PI*p-˺JOQykKNQZE*]Bn$zDX a"dVMV=S6;*(xF6mF8pqо:-tZzz*͠.kp_RUndD>`2ZIi`8uFy`'xO3>=~X)+t|6or. b:JK.!#}q٢}ݎ5vs&)MQջUq)M ]ۨ NZיJ+jX#œ+!>(g) T_(+x>adk/ bd&+&$t{M-NIy`MT Va`]v@oHL3WBH//F"IiFUPݘiQ1‚1fXYgj\YS¦'Hv,[U/_$VڴpOUkw2+tqԗ,͕kL'#k?Oιz%g1^dt\fSDyq1΂0\J[cVȔ爎mug%ۜFWI ݭP!a 2V܌nm$ 8|d x/bIdtʭ|.r[T2se*hgb6 ɛ0ɰso$ !|W)v ms87^Asg>fuL I{z-D<|>FoϠk:\V7ˉ=8j<֣fƅ~hd(?!U#|ٞ{J9N,CΣP~S+U0߯|v[&/쭧ebIcƇ9Pq֮t Ɣ0.9,`ju1Lh԰d5**v}w_TwEbp`Zጒdry[_d! ܌?Z7&П~ի_ӄ/<4ܬזٱ8J.uxC aIٹZo*KN== <F eYyYu,OYS͑pB`Nu@>-y(h54ZNfDd1cE_hZ8ו.z"kg.w''iO]tF* 忡1(eŨfZ + #"ȶC}%Vq"v'ɍ&Ibn+5l.Xl츥 }|b8a:cVWd?fpUW+9G-U-2e)1HuNȁ鱾ܥ+zǻ!̔|er W6nf2R̋psɑ0SԫyXzJI{qa ō$>y#0J[pPyP3c%LYq]`ox *μCߍY{R P՚1vTa72B?aOdL1C[Zy˺s FbE\MQھUOxpuc:AvZ#ҩGD9sEYrF5/ABzP "+"091FQ,SvR!C4"TM9* Ɍw]F.pF ݌}_6%H ac.GBƨ[t)Aeg*0-f1_3CUq˶{Q P+sc\2Aq [*ˇ ONX7 q!B4]_e k0%**6a^miB3s%h4qW E-}טZ*j|gI0YLuN@u3_|0AïH@4hL*FPZKϏhvu8_({( p(]st=}knHf+wEA cف.V'O>[Z%i7OYFݠ~Msr?{9DLcc9MrT V} pͬ}(:7HX0'b0ՉJ?!2C1Si[x2"+>.`$k @G+w~{r\;;#N9cL n\١glJdzfԬAIdh0(b{vSR-f1k> I-DIZ6 @S9A2ZEGI 3k9϶>QnjպȘHt$s]Mzr|; E>=1 tL!. q )tg^}ݝ%ي %$xyy*xw$_sL}"6leq)!PÿD>IM ?TR8#cj:*޺kb&u2(E#]x<:WP nXy'#1n*NEr8!*.ù(M( LF4^K (Yur蜹fܓ U@6Qԙ$tԇH\',dOurA>,|Is-y[Gٱ""=XUCɫ[L-tEH.wr6 c&zG+Ta{Ji8An>aĒJ"T)ak\Ȃ5Vkחw$oPf)kz&K$`%\⣂Y0м]ȺqP1j\V*_|k0Q|eh(93Ip$ Ab<7R aM.'o=f psTJ,Js-u2Xi[hҶfʹ3.qycЪ!(2CEwFm,N΃S(R-2\e½HԖMV'D](&Vlp75w.JSɎ|[4NG >gt񆱫d Ke+ '1ۼ3i!  aS/Rαq0&n9@M=uo;s࿠usN}JY6I\BbjOlthB|v*ω K]kgQ9BhcUSVֳOc'WA/@FcFssPC]^=L䘸ƿXqL䠗h2h%3n~怯L9NckOQCK,5ܯ'3bp-UPT 'wRl|m̮l:AӡwS'G.ȴѥ)5'IZ!;h?;=Oѹ~E1=p|6}κΖio3~qxYמWjh_I</8NAJz" CdzP{=o+m@gnWh^ZL).*kWu%kyX5=T$:+U_ݚP_}U<.ygPިS;,Y"{DA=[#r~_3>!ird#dv5*ЃOhEC=ar_wT!K,dFZ-(FvAĘ\Ihgy9R88`"e336{u_C8>_ G,Nnu86T)#ӏkGlcV[~|Iǫݵ?/N.\xolhq?/N3ˎ _<  D) tO!_+QD7f@.R3e"A\-zxgR'|YF׏VtWKC$Mi3ro;hWAb:Ī'.\Gl?˴^buC;j3Qܵiv.#8Nt11Z=3yUtpbd *6-{%*467H 6=p2 'n-٥sz 7{4LtDwg~=5 8ڃ&Te^ꕜ?োH]£˪Ņ(/:Y4^k eo4QUjݴ4y[?@W )({ɺѷ9L<@М؎ιivh}P olI`7I#› 2Geiiaj~$LOw! G6w"n c5SҲH'ٮ;Q"aZޅIJf/~=twřh׹:/σ< ?/qlҖSrI;eBvHg~y}+N&'+9uU}"(&ٹ'COR7}Oi_Qy69ғAoK 5-'Ilyqy6. ipKqxkwtgsz7V]v~sOX&2yX~'pgǧcΑC"?p!-i';>\+no`-=Vܔ}R$$Y^SKh掚2P[g<ҘliRg?n]Гg'{*1 \?~ P'WOR]b@k>fb@ ɽr ў&# S?p㘁ZϏNwis%wwvviA6r13q6}2m2/o%ڸkYFYW.2145q)VSfv QWezN;Y_YNPUTG.D2)8z3¤dAcgDF.IT>mkwOCT%etI94\W59 1L8vs4y?Hak(4<5s#ĠUϕ(lyoFܰSjnIglG>#.@B8aag&ڳetoQN;~|dd ɼp5אpFtI/l~g)9[\z/x-bʹٿdzG xg5#D<@_T`6仴Wgʢ N+):=$Xd˥N7"}5yQwtuD3T-"{_Nk |麟7UMo͉O#&ALqX NW~ujoB +X,Jq I1_c+Mkghs#Q\&8viK'CUWOV6|-rKq;:IB101R0fp^4-X.Th 6Ǽ^I~ 1߫aPQKRH]Zr8!Mv'D{rdn%z F +EB/ɅX7g{uK$܇`yMz[uEo^/X%h#|os@fNKrD 2U-%5۷`i.!J Hݬ3sz dR{w]ÁJMM]I,*juX"űKoE=OMNᐩ i ݀kbcL^* @iB DJ.R%:(ңiJ\*zDw.:F|.N<&qX0-( P _Co4[;{Ir+U 2JF;k-P*o2;K_ï%/jdTBJN;YeIZV*l^a}wq$~R+sHWᡱ b;lEcZ8v(`1p+"X$߽QMF8Tnnáx0 CIm/5$qMF8 ,rRyE81Bzlb>ϰ@Ӑc?vi6/?;BX\#ǵgH $BFtD77۝,pV@C7z=櫺 Ov]9}i#fi{_jk)١hݥی #) '~Jeԭ'&^G~yʸ_tqps>CE['u ӂ+COd!g%ĥ`JN ?Nؐkl P;SG-7KF@N;Y"*oxߍ8NEy6 Enub{ެf/{hoR;LSUZ÷HSa9BV?ډEEQS7JĤ.T9Ru3V3P.~|_T}FoʴohV~o1phCj30 f?E_WRDA;8pkTblRҁ+e[${b_0J9K}6NGey6{@"1kz,tzYz] P19vv8[F:Jg9n廿"{Ȍ _Y:'E3:(%k:TːE2X*д,R_rSv s+Y͖aKvz^ub[팕w,Lw>طR5AojJ?~0Dmq@V9CbdZby16H`ާT7uA!@uZu"TVySwEeϢ`(-_^2W+ЋoWi/`[hD% (=P@d2"}Y)4\p#/`#ɴWO|;,.oײ K8T#Bir>4j>C4Yav V/_#!pU0t=&#p3!1?X!J3sCQ+O7b9-"grt}/N]W-m;f^ "+R'I l%uOmEFԵʔy72WP zQwQ/Q*oQ({wSx(\;W-:"գ򪀅^[0dVb%/0F F@9v_ƧXA$9>0|R/n*WM,_ञzE *rBn[L#zwwtyq"V_5/eYm5٫}-nE?,C \48v\`sQVV%E|gQ^~c&se؃.dې(+EDZf$OhpK8U"X33K=gO?58rQZYsoW#IKOg; s V)SXEz1:"/OflrTW%biȃJ +/5qn+ ]TDaUDF5l7Do*17{!=(N5TOa+B+s#/nƮ eZ;K&Y\{둷YWLߥE ~}jKvܵg'Ag`pf4?ۜ/$mʻEO?SPLw6.Nh1:~)9z ;dG*5"@{pA7U ?j$ޫ˟K:p[{}Ɯ$v^#0;luHȿzu8zgf|zww=G Z1?V5yڵÄD;8w]T߫$5q`io eAYĆt=ބ*>.ZskA<> lmC_ wܰ@, 6`AC(R9оI %M r90?άLD0M>\p>M F++QЀz]Dh6Dv;bb::IxOٌGclyu;k֭EЍ SY5-pz3Ȳ;߰[m~[/G` 3:}\H@7xD# SST8r~껔#fgC,APԋ3RqntEr g;e;~ n&08aG󅡊X`pxrzY~* B>φء-DGPL ):>ӻ f }Yy-O8?g%@;uծvMHRdɗiQl>/y07zTZAoP6K4r'@|ڼ%rrI7"Bpewn'G*zAY/d2d.M|fq4"jG=h 蟫+ah%<[g1`0oo)#IS ԶAA g90[||-\o{a8*2ˊPUiwҨrCB< 3!%lm9O"V 1lA@xʼo eK$fZwĥ0dAL:p[y&B٢|a yGڎ.6'tqny9|)VkH ^f;:o2~Jn`ǜuR 3g]NBEgqBDժu\mC}1-p|n%ۈj[kG<*L:x.&flYκ"t _ gSh^IZ P](Yd6}6A~}8}ĺp?g lɡgV<""iiimƞ q7Wtʘ1ρ?K φNxr>[ }ѝـ%QFK-S@BU3dY慣!tߠ>(ayۼ*T߁ob"-3-4[YLG #١tд EF͇N4;Sf%681塍EI kBTȯXlR#9y:T\Q@@0%-X6flϊ}\F]m/[ggfD^-tZ(3>އ5;8ҡ5#3/jq SR9mk=f1ǁ&0i3MϾ[w{Gv\%@U@G/#{ٜ@F.`) p愰V\pX5# c M>Ye ? p.]d`/Ep_A#B.9[ʘ{0'uo8RtY48+JtK%/2(xN(酮WaV~]'e_cܭ8̷aP23-Rt^a-2h'l>a$_tNES$v}\!};nH:Mȷ^:y(c暥ȧM[[ͧG$v<H993v;e@_ C==?Oʜt"._n۽__N5#~E\f\,ԨpzTfZ?"Q|[P]a5%:C)XDJ)Ksg^ˀu<B4TbVZ@aM\tI|xUoy|Ĭ7U, ҩǐ!)>sDCsQ*rCay8r017e:ӎDUf㉮dXYW72< B#-~{? b"mQޭoF\pgu\ [mHYC!/k=h#2S~?euZw\Y=TB+V^ReCL 7]Vp"={ZsxVAʚԜ*HRz^zRBzªٟc4ss)PtPrؔe x#a=A@bۙE(`}# J{D]Vѱ>;u"+ L2`kU|y*Q̻vq-`M%re$4(G@IOSP.I -P<l`i%T }nG$'tNheoGeW0:XLJY(]FDJ !,%^t(9xi6v7$Ÿ@KFkUԂIj.r#ItJTP2qȄ c}ntp3ds5z qr'UˈϑˇgHW!2gvӮQJԸxP̄0+go$sf rdz!;1']sUJlWSUUm{<&Ȅal|[dXt8Ė\3q ;>PI׳H H49uzSBn Ћ N$5 @zez̢7nN锚$1.FB'[ùO=ZDr5.Ͻy=_$"34! DS#XRT[ rFFrGmNKNyf7K"p:tФSa/[,8?gy#G#J&OfZ89kGYĆ'Y $l"|Q_xy+ 8c06BncFU(M կ5Ά|o4}1#FYsvZ >Ccѕ2:;C4BH 2qJ&b,mAT/+su|Q-,]&(熵L?譊Y~ vi ncWZ!Bvp%*Uػ4Pϰi0oJ-. ll^7`?MF-o䭲m/d^ Q]E]w';Wn wdJy {@wSR$>Ii6y#IPalRq(Fh6>9N=r,,0\Όhb/R <\UzJܦڔäR#S[jr2LKp ,XX.BL:=ਜ਼+wrGA'7`FעN.oYɎO\ҧp,[C^jL\^\'7ݨޅ&x+=PNsWŸ_䷠ۭ5Тjrn.ðXG]j8n0lhj9W46:h.3UG8TIqjvPT!h=IeEAfR6Z*kU7KNRi}*)@Y- :8(blIsu{{Rګ4dBTEUdYwy}qt[1~kVD,<1v[a8yqQmCD^otQ#?FA$l[ 4Z/;c܂/6p\ZT+fftPyhZ^Xja/{xO+ vk^sOZnɭt'}r&OF({`W}e:du^i[C|ߥ >hUfR#ޱc9wzNە~r}Ȓs}1%VloP'L$}|٤ZkT|q#G E7cЃA\u06AW3`KVN^\xxn.!3넔ݰt}K<% mo (w *S~ \VUՕrae׺0!_zR():I 8g%KqdW[zNn p? +y=Qq&LhP}w4vwηBCU'5㫺~A {M ˩^ژ>>{!pArjRf`)duk7j+msRv縳WqJb -z$lT  zT;kwjh#_0WzmJLHTUm[V[\vu~(E:D'szf{~oFyPk~NQ;{{͚|s@+]\Sѐi;J7V%4zf7ڇ;M^MkjWk[Z^߮m-_mmpg&/ijݴ[Z~k5VtP}vmtK7=k{uo=OaDN,o .Ep`Ԛt:^+ y'Wq8 bZy>UIAGF =U 'bIZ~x.@g'J0 =5 ,qf@i1 P8YVc b50|GYc#:=W@-9@Kwn>=vm45$sT.f 񍃉0`'4~U1-HJud9z؁tC#^u͒V1-.̧wVmdžR[=8aA juu=t{x6ש_(B@eeREyH=.T:5]IJP0G\b]CTE CMs\e?+-Gh؁ B-uJ=n|nZX udf8s^q;,qxbC.ۧ: }a\Fp`>ї=ͥGc3us +˘cټMū5P0ada'/(gş=z{Fjf3_Cv0òbpIwFiNݒQJεDKA 5a@pi2H/9/БzfŁ8,%*`bfPj_EV@#O{gg[ с\4>xϾv{RWl2LPGXrE|$P6֩w31L;tC| |VPgG4w;2| ɒ0 j ϝ#3:≫rtj=5}sМQ[5z':pa.{ͧ}!=nހӧLaՂkei%G4Ij.B3o+? LikXn{:FH{J ܁N'Em/ w'l?2<"(RňD/$Z>98(*m'JDL!& P̙ Sب[hҩDG8 (1*ԑA8W!E3Um4V*$ h(Y՘>Y&hFۙj6ۤ?4>}:)=wZ,t=Ё*ܧM@%"PgG%o'qyVz]/we,SS9W$X u/U3Uh.攅?!BX CIþyKT)RXoYg/¤i* оrؓE0 ᥬҠVψ/K*(*ԁ,e|45-㨠\4cs~Zȝ_Nnи#3&!hNLg㠺©K1Rח)b.I,\Q6PՁ4LSÓ+bCtC`!P6C'M9<K(Йn80tPf0p@^y\s}Kp`TQaW2؟T%Ef_m:p4ƋaNl9 -gpDbל<s!)wkV"Hq*61^ F/r8ۦ!FҏFԆvSIru74"4>%oAV1$ۙ%}Sq5C(!s#7H+iFcR`n=Kg9h^``E8 2XQssL> W}fl"~LdmcJWor]+n(k#W"XʕMQ#&]2O@0D,JDB/]LB{(Wt4ZgXppS4,(N# O|Y yɊخR]qGQ@Q =BC!uOS<zpQOi_.L )T_喝NFPFݭ'wJG1C5l Ǡ?GKIğ&@iqHf y31Vj'aa\ېAQmܸl@ u:E8~ke"3`p5p% U@*ıԷ C,Ǽأ'T?qϢ NVb6D>W>ư.~,%tizŶQFmMLh"%i!Ij&^hsBpzcVs$DxHr80m1vbH5XC͚-J#Ep vbI%:U.frsmW,c5Hɻ+t\."3pOA/YD̢(z\Sӑ1!m(MOTWXM#Z^}pfKɅTbQQß%H٥3/gPvB4( kTevrJ\Xw!0w\$;.&=1wb4W;Y~QO: M,[4P8)a]kOXvę͋u?8؆uB 5,@ GC炎z H Fu;Pݗu-BQ:3Hx;0Tުf.-mE6VZ_)_H9o'1B~yqآ 6&rv'tC;!=O\Ϣnd}dVwd6 l[߆n.E-$Kji7!CZ$n5gǠrlUKODS CW GNSㄞM~?!BMbFO|ZhcIvo 7[cbxgϧ݀wKSCB@\ yC[b:~zTrW{3L *)pphϱ _yn+{s2Wg`~lcljV_J7]~ RȉV8N-4Rہ@2WA\_5B)C㻊`l %r]oE׹!X%vgkG!Ɯ֘ +Soy}[-ohwl3N`$I \hÙ͚.'3v98Ɯ7#]颵c9 %!G}Xpw$=RV}6dDw2,_#)_ i)+(D3-t :Z?Qw%'#1^Kw;;:,N'dÿU-x> K]27 D HX/#B[qULOtԙ>˘2N71&Z fjhL ,[ &25AަZr\G?̤ҤN9/Z:f%^)' =QC}]O)< 3 hjy@ӡwd&Sb8D$X5;:=cXϞ^WE_>k/1H%Աb8)^&1Q"FCG1!,,=ֳ!Nj5 0wE6$p#GCh u'z\$`72D2dך|>||2K`+W.o-)aRq?bj Gw.=J+g|#(KM0/0DS--}N<r,kjo %TQ&Gl{tUʪ~W%!j93Ytw"`8u}rϫ%-a &,&L"jy|~8Y9AD BKnBKkS!%䕣 &J d]*P}Cs2uͻV1 9/,EҹϲM6N2. Ǎ7+B5I zUww*m0!_`}®;v@^3?zȻ{~p>{q'.QAqIYo!*.a-z]V*nܖc,O EyXŽ좴@n^FyqQxګ&+L)lL;I,>gdfD a0*<(p_h]:i)N [n=flXN$,wrB1Ϥ&ԯQi4L;RHY:sヨY1ܚY xzeϗ;X|zKΡ97HnyyOx i*3"|Z}*y&W} oG۪$maat̢'|:6%X$a@htO3$Xvq[%M7ŀ;K$jd.Z~iB誕+泎h4Q27~lIܫ*oxfz#{ U҈us`S@.rH{x}2m|"pFmH,DhxM_6yjt] ra6(}}:g8\S"+$AJXQ4H o2sU٩g@Y@zY 0V'F KH.w`u(NS ¯ uSN[Kt1N}|H*z8b+D!@bšTτ}d7+R9ГYM+4um|0ckQԃjLv9!7Eٚ-!`Vv1H3>n.>H?|L{N??^5vϧ,.QFhߦg'~Q•5gikdnHP潡+џo9/&@b J:xc2ҍ`?ZBӌS&?$B7ХSgj+" ֚>d"QA&2KSƪ B€,<9 X4xxQړ7_}/jKpGS4F%kVm찰E-ZO1 T5Ҹuo3/A^cXFT`t%iiէ #9צy74OcM+P? `sʹ7y.hY46m+vz =sxKFv0esjVxdH<4J:_ ]7Eş# tSr%=+l"D8hX7AZZ{f5=i'k_qjV|,E C8vyG}Ƕ}n8ɹN;+).ȩ!gXIIGpj":]sQ`TZq)vB fV' F: :rPwOASyN*VpR`AA$B%hoM"{][)F%E,c,A{;UQsF扤s@FB0SE4BT($Yg%cAE9uA߯pu2`xKTTy7v0B7؝fGVoX.wE,^z[ki܍~}MA}ω Hhl%>tخ7ʂ}x y?%" @LUFJ4'C:orǙ~DZ) ™$(L[RKA[GMϤ@مn4ώǙK;zҠ}K# oMkft2"jEV,JN8v/,r+Ub7 {Q.p1T,jt m#ś# rĵNq6;ႸvŒ̄D@S} xoxE'9n$F=FA(K$LƞC10lE,gTPo <c[CdYqHԀ mf hkϏwPnݸw_Y q2&5ð.rGt c'!=<;#jZF)HT^`w{﯂hxZ(deR4j;@$TƼ^ϩ*^ qehu<OegAWXCmzu w&8*vV36,JhLngP2*_VrDqAQ3U#kMtA6^\Qغj 0YPV̥}=uϭ}U7k.=Yt?7:{rD$;3@>A^%>HdwHdK^ψ hϑVv95VӁ#U!f8m e9;%Bx A>瘟[b̷ҁ%*T+!dH2*`Yv9xgwQ%-J,Xœ>0q/8OyxB wrU/f9U%SQJ3 #nb[eRe%P2@q tzٔf0 )}d[QzE+hK5iԽ$ap9f`_ %,{1kk m1˘֩?r>*F A~#R_4$̒;-VҫJmPc͜S= k0ek8 ;&8 k؎qZ/)p4W͊i.}䫜hwO,HtTmn,yݽ#f9S#0L_vBȒ$bV:avĴ*yRIȜ%8gVS65Sy+:}:-fGiqUvzfA.7B>u>prM? oZg<z38!qD(qx7ɖbffƺQ xZf}wjOkL;R Vb$ٰbkd15?H'"Kk=O1t@XDrT%sW"QF A)?$8u=Y[^Ꮨc6sYUEc^|L: <'K~$'1/|.إv?Z0lexI8'ʜt.߱V;q:%k/[EEFqv\^CST"\_ +n.zJԮ#Khgp3x _;DEDO[çrk7ǓG'/_9YYNbQ?Q&UmpH$SҚ.4E`':_wM0yet/x.QgEcTa/UpN|y5n&dQ$[(u_ab͎mihTǟ$[P\^YbMyHSv`c㘥1,A,RH졃 6Dw{T+ DKB3&`"€;+ $`p/1735sR >514JVE#"T=Fd9]7pD7\Hzeq:$T+AJvJ1C \ d+r0ޣ4'9FoEt~IcUPwFO!3u>KkZ?3{0.Opx33z>O9uMn5/*XG^Ζ8cRnĕla1@| Bi.&2*Ɍ]sRC8yǍgwN] %{]d.HB_c$:&ͥ A՛7t~-;wuHѶMYr27v;'mc16f C(-tbVT3in.}p73߆_(zA!Qq_իT#$7Hu$ )O|я 6{M]RGcKjŒGq,y.Y@TYF5^ 6,;܏gZI[mըѽVdђj"]D$wsGU"A<9DFyc\I*8agdhˣeE1m!X! 25u ;R!4y%T$:?;]TtŽܤ #)l47h?0l1\; +EdB0ggj|\.E_N\.b-#6Bw rꬱ$]wC>o=aB9gXJpc=`sZ&g{;T}]nn8(tR2$P@j;% %cgXMKD<#uS"Huh(۹S=ށ1KP1<pe{0~"z'.d}ɭ> 춊7MK#ԥұ4I" |BK EEi8w(.-l™6Gijw,N< k/=hb`jH9ӔfjnxEXoh1a= EmumsȦԌp/?v~]]t7^v}nˋ zvzҥ_bQ=yg-{ʣG2*ytXrCdV Z(w\ X>&=˩Hq b|sYAaWZ ߛ)8&K,rf2ܙbN%jք"ӁQdݹ 1Q);:{w{l8cbv#뾎ȟӼE1A>J$^qyXC(O<5 $=$tP- YFc%k4ܻpSvƆCHc&-bj b $e⑋lJ#aFXİ&qϯOloo_!{s{yX'\\cz(ۓ|ѬYvi@̲Ӧ35J&vrCυ$XHtA^"J˿HbqtĝyZUCfbAe#*s$?^U*92y$7y3]?8;_=4 +qe{t|v~-.+θ,Nr' Ep/wեsq^%U)Op[\Dxr' iMߴsM zxxGd,ӱϒK%Yԧ8U.M̒\$.j*bbq\,__~ZxD>E2-awhSv'ٳC̙/>8sn*O ݵ_zqf $4$(!np31V쁻 kr!"#Ffz\9:9 p&u} |0Z Wj:V8?F6) X1&L;vF %ȝ oq|#TɾR;6jW!2{ۣۙxJ:QUW~\?o8 ''@?.5|1'M.9n~; 惖潇{p aʍQZKu4yWU8z.p}rRL4: hs3v}?ʏO5{zb! ׄf`\_,h; *58 >fftKO>weӿ\~4uiF.+j/~@CON7=8S1J~;yKMǚ{q1FY_vtOszt}ԡͷW#{Yb+m ! ʐ[KV"PW*w6wJp/y86>oaZu|ZHH7[u)B†5(zk|TQ1 l|'蝶N Acͦ퉂Dډ.j^{O*{WFK$0.s΢uJ̹fX7-]ϔ2SL.&crN~~CK?{7^HoƑHy;>=V^/Wvky^}Mǰ=y#cیqܐ`8 Yd%HH:, O2"؎jM +>H + ].ktV2R'"SQ0\L_kjՕ6^u8';Sx?`U O }˳Tax=$_8iL_w4rG/s8> `z6)"*>0Y؄y%J9gq{[* ]/T$dNWoyxO%*۫R<\ ʴ}FQK'K}^ ,WYU4 + {Q:-d To5{O$8Tl0g.$ABq:+D\0gA-ͲY"DłBje8_a&$E, `bҬpf N<1=N-)#@&/޽~jԔ¨5D2TZ +WbJ%/ϓ K sUJ}}-`輶-E7`~dʡv7JXZ?By ,5 ;ȪGc+'4&b޴dsÒ\F\rg󒭕%1Lc̄EIL'M(CR5[5Z$W[1#b,VeDsmtZc=r]&KDlqH% T uSXg-2nݞ^S K!ߥhbX=)KhXN_i%]'[:wXjƋz#)h{9r}9}vmLO oޣ 'EU,p{> O#}z==3J 3nEQ5Z0zh{]o')uyxATyf ;0r$_/G'W-p%꣹9eٕ} OPخ;de!gI1>1\l,pv_B{m_&qVcؤ]0cIA=\4^ݴ;9".L!s7CO;r$̣e;`M{!?j]<)&΀Ʀ`xk7a_ .#NehTPwc.EEêSѼ"ajQL1(ϳ5*swI~Qp cM8TᱣoVgIL^'\42X.HuV-Qn ֶ{qp{Z9Ve76=p=>.KovF;h ouKm"# vQxBtT0@7Y/] >V:)?wN7xDŽz[߸^v[J;Φ#Xݻ3}gEz E gNpU7b@6kF^^'=YWdc_9FKlz|SGVp[-sZH套J}#&^*jbhWe´IlǶ"_)~K[udG ~Vf>3 v@+/]Ey7I;6x,tV_$]{B?q!~w#Ja@NՇBAg fF/OU)Hpʼndإϱ#Ȫ#A&RXz6"m/mUUnj7N>0,Q l9%꘩Rtҧ`XHN-_dCWh@%{j5ĉEJQ]oOOnf oI1/4#YDޠ!cc'\'/^ z6t9eN˰ď F0wZ6. BϑT-9Sa/0Lѩx&%4 onƗTbpۦ@HH#RR2H2l:4eyf- |*}PO%x/pgG)wēSlg,,r̈́a>O-!8OEV,mɻg+َ%!aBr&lO4Ox֖n#x)g{[F@7s#WNuS*q(DX5 CA>8I`wvwز>D ?4'v#u/ ';MF%C 7EMF-y Fv)o$W[`E׭W$}Svw7^W^9ot&BK'J9sgjěᣂ$ŠŊזd Uӵu:<-L[h}mF)^.<\C^SA2opf+ཅnQw'_vhٷw_ud85EF&5jGƛ94K I4,:4SͤrSOkYe>LQ YӰ{a^״ʴA$pO$ !BVlY7zGuX!F 3a[3(>i": nG)i oyлY)N4p2~vvx/pbXFd8l]v+AFȨ yEUcnO0, Ֆr88>O6 Jk8bZz]`P #̎DJSÐlfcop6> Α^pc^}$t ]*`@J6nL^=^m~Ȫ@Vօޙ `H|67Gݳ/%9$ jwcwù}9wZݝ"Hn)8HQ!-3Mƶ䓎,_Kߙ~/n"?b{* kH$vuק5.xuuCwN6sjSצ/7,ۙ\q@s!w+w$v<B G4>KBgPe%l>yB5?lmZC,z"vNF l7piXΆKq)Dɵю[ TK/擋^j~aBEChApk@ǽ<]bzfG"!# G{f7aY[s5|aZMbmݑcZ19 ~@33suvqkTK|DN^2 D EZk)qp$9'r+[;KOMXUEaBd w%Q[<P f̓&ׇ>8z5}dW'E:Q%7+ I(9ns5h I1rg~Ù\8p9+ ېA_U&n%: vX(8{?;kA I+^{?xm# "+Lߒ MCD_"zH6{='[h5, 夺%1$qIm@5,6!9@H1VhOʌ$g.`#4k0 n?- aGULy=,d_ n[R%~dhGR2{Z9,ܷQEYQ0Zys&pڗ|KTA"x=Q5MPClKl'3P]P*Xh%~iM܆G&?8!q0ؗG&@<庙-LV-}*Rv؍dZN鳪[X&20._vsTS:viS&QpSXR eMdv#,H4 z0EGe~a kM(/xг%~2r>^y+r{{Q[3soЅ-"?ȝlLɧ(:i}Rnc5)K]]xI+%O}%@ٔmy?<䇽?}?6ڿ{ot l9A^K䘵II[r\Y adDQ;0S7;So{6M6ՖYD"!"eV.l +%Ta_]"Rigݕ~8t Gn| _Gp\f'Y5C0\DhMhǼD-Yƀn:G/0"ߡujD}7|/)H4`ۜ)N5C!\Bzy=ohr7_NmͣԑTU^ؼN2P%>=7 fnq;ķb> ☳Ȇs9k3xoZ/1_<5{~9%V zĈg[[V\p6$&ٔ} o)дyI.Ԛ!+J(βtjr,bF?=k3ܘHXX_K lj䢉+gkUr/+ 8a&ј# [!kПRUjEeXo u L{Mj ̹FH4P]=/0.f-๿Yކae v1_6}6p]u,Fch(ȷ}.ݦ- DX[r 4φNa띳Sl|RoWx/l%D{~[/ݲm |#7GF %}Y{4\#/`=%ɴWO|;,ZpaU +h ؋+2ǔ.3.1ZFʀf7Vs2]äQeH+1$=j^4,y#m _f楪U3Lw9f[v7A P&kMIZGPLֽaؽ:(I6jmu{ B'ۻ`%K\sH!=Y!wywꪰWe{fg^WإOvIo.K-Tuw(Ull,3)ld鯯rFXfXJ>Ʌ,neJkj?Ou 46]\uW^x^Tj/9??Cg/?\:j欀ХXqf:=[fY3tO0 \ӾU>z\̽YʻN+|͸ʿ'4P2M 7;[+E Wج8$qhhDה L[vc}$;bUHckkp)H deSolve/inst/doc/source/vodecomments.txt.gz0000644000176000001440000003716313136461015020622 0ustar ripleyusersKvodecomments.txt[[wH~_Q_$pbi&Σ{W醝ɬVj׾j>_<|Zg3չ,RK/-5_>Zjw>i0U{͟ qanD镥n4`8]`1v[5k9[Oo oO ;!B}v g ibv5?7PglQ:˞EWVy{:@19 (o˛_z?˕ZL|(UO1 Udض* z$nuĹzH7a'unAG? ?Y /aW[EM;UQp;g k6I1 a&4zrP!#G-N砶IH*cwv@xJ]z.fFhkszjɭSWY k,gILZ fGؕ,l8]qmxvU'}u_]V~l@O7{21`qz*2ynuF`n,!C !@fL][ Edmuoi[[])&@Mmuea9iԯĔUR WuUOD~UOhu?*ܶWh79!0S(K#no1Isjqۛ SɘDu@}G$E!98)E.F*~ӫ;L}K&OEhyyNo2"= #ZXp:(*&'k:K}SeM kt}d4\!Iǐ, f/:i[D?~iST"eXKM@ouZ-ɠ$0'Y,؜i9:"_X@|r `ҵU|g>0Xv(J^ 'qnaQ=%3s?7õĒk/KQԷ Mյʀ=Yߞ'5COVQg80u[juRQ")5C)6 lr0,x]dM%/ #/[2W1vd.ҌlmNjMA&1LN* Gq`'dVBC_l`/d×Ô5Q )g"͡c>Cq 鞚o۴4 8dCHx_vyIE`BtHP$DZj ?%_DS-C1@< V:hYF柩`;E` 0% ) *Yr]kpA(3CD qH "P3=bAxpxW^0g߹.]!)sR\dV/% ,5_d^ѶG^ &Sw?_&pA9:YZEyofu8!~3ߑ\)RlC9i-a(>Ye\b.VD!fbB"NI,ad?ujk]x*`e^~dfl1mtb\ES֛s\#{!eApiBU#hp3_?>ǣZxfʙ,`%)҈f:T8ǩ7#k4B߳ j!J)m#W1Ŕ&7EcȄnU +@߬53Bv‹ cpq&̣\ y49HF_#3שQ:҈SD" aDby(A4UGvScʨYݖt@Q7HjyJCPs+bEvYgLV9v.Q~᯲U3f,utj:)Qn#^:o9 f-{<8u@t,5"+fе J+ @MjI cT4#o^s[tJΒ56A<"7nUYQ`"fM1(sV zUCi%$= _a=zDEÉӹw&iikƱMY;} :ӍȺAjc~;j񷧓M3oopk ZY b0h"śۇ?+P#7겑t 2 \9N@~^evju@Rvdʣ/CRڢ|Y$r` j~|qU H2xS Nՙng=W>MKG%@Ѧ7.$RTj2(U5J,^,hȸ@58|n*.BD<?bAԅqmOܶADKgYFdH9QQi0 x] jQSR)]Z D rҰFHA2kH2lA;aԠKJS>z3g`*ѬotwxP՘7DL\5*,|Q&^U비_q? fڊm23XHmO?jR-h8ytI?{'L??T)m|k)S}uz##ގ'H'5N{CDEB4kkv]:48ej C5P4_~= }^.fחk5;3{s-?-τ-&4/^6;cH ?^*ezU?6rP վqk߸ɕ=“#F [mqz8dt-Y>e鯒,v)+tV)͒H/6gx#.P=:~x9|]؃ع'o~?áqmwz2 _Rbri;ñ 㱇O#98c5 2as 9N}23@{칠@M%}rFox8m.r(@&;- Ê7iG@&A!d2[@F(fX]]"`@&7x e; tPޔθāvMP{ GLjf%\z ^+ a2 +] 2 w*ìN) !yxɘᜯx=bt߬}5DRgV7~StQl1nd1Fw\oR5y\MOZ̍LJY*ilo~A[ʳfT ZNGdp뎧ʟn@"ȫcujȺ PnZˡg*Bip>-Qu1L3%c}Vt*iSЩ-`D0 s,J fۛf"ɼ$=R6 {H-B59Sz a fE%fλ!H/!B{0MbP}sK][Ιc%VVNH@L 2)׿lfTj֔%?"'yba O@*GմZߑ.q nF, |t]DG/kʯn55՗|!R=]P΅:x-?oƻ$B68JJ?#/f+ k{I/ѷAn)nrg o7Ț;$Wˎ-.3Һ.bz W g(P6w;:e3$%9RƔZ(!!U3SkѢX߱UdMӑWC$Pk)H7[=C)֏)-=+Y=an: eF(/gY׉.`+ZnI#QRi^zibxWwmM$#AWyAVc ڒy,[-ڒ<*|qKe0ìu֚ic22####v3|3Q>?,'ӋV9ԱД|0@<ޗԂ ^ݦjmtu͒Q WՂ#0$a+ρ̚WOiu턜}hHۓgx 0:h֮D/TZr|S&#(*( c סY§5AnkRnǷ2%d2MSVZҠĆWz1܁\&fu2e!O3h ER$ī!;# 0-fLm7R;p^rAH5=db|!r*pT!ǣB y&z `a~GfÎS/ $Wf?], (ӎ)\TFw71#dE6t1M9>`A[CBռ7j$dxRݤDxah"ˢ-o2ʄ.z:ɘUF BJ8ڻ4FX|D"0njvN{ t4]3p9!CD3KEpsiv7~&e=zR7ea]GI!f;}7'J+&s8MzonY6 HǰnItCxtJa%H3V+։]褔Uƌ'&7&7ݒ г'rUDB˕gx2l@'cZmgAG?g23̝p[:;5S70#XS0?Icڭ_1=»{1itEG;.8h}8hnN:S$rbD˦qJ_$^uNAoKRK)ͻ)S.K԰Y-a{7]VܯEEtP?W뎻C_{v`QУnd4Ż A`<5i8rm`( \ώ=JJy#1l#软)8K`%2eFWopyTs5]b6醄BqSupǗ>%q&yόWtWBѮgDSq9f@uF] 2]P2Ҷד ~`̯oyi;ڎpk0͎YLEwoNe0D;3Q@BWtܪP⌰䍤Sc7/zd_)[Jز6[s>|FqIzYG˟;7dQF88\5QgNUFpLҐvFc: ¦!){`֒@SS۩AXh)S*+"9bhdٶ16/zȞ.4B7Nk.&.D$6v巊x;Y(vU$pf]Sb@T*J.&+ v̈/*QI5p@؃XK?a(s2F?mlw$HG& ۊLՕSkAlzdgҞ)rʩ)_?eBZƎI*b9) Ӕ47us C S{d[Ҋ0$v&mnR|U_uuF!ERm\3,FLuv0SZ:ycfr 8@#C& Q<P,G@TMKQ]5ĀNCHLݜY0I\ӈ(Ӈs!ؤtń{,I*06;cK7y`//kp~9qjg)K5U3IGF`aZ*RwΠbǼ<^ht>q7jFAg6BݬÔzE--PN֒52+_5BY i]y5nHo}?>i"ӳ@v9 w &s9k4>zxvm"Rd ؃>` P,1Ic6ux̸.-6;6=Xai@ʨ$K<`I?6RnjˀI܇k|g|p{k`YH r ]򅁧뙕O2rtAK+-XOG!{K\NIxR 7$NE6b9K[SjݥfRMp$_h5^%isru8 1jʩT9qNqp+z I;NCMw4>H.?P`b~]QkaHZ4aml6\}x5 ɶ&Nw!'i%8|5CҴ[.n>2ֱ=l89#(kfV}}ԔMe15PrŹ,,̛!v_ējd lV{Cv`)I f]PFNDWB,m؋n7oiY#D^SRgaWwu zo\a]Mgd9=p͈W%8Hb0DNa%LaCы\©gGAfmVk#6ԡC11,p$TҸyNHaxl,!`?dҁ5l9vȴӲs8YAiXpY@&=28q"I4S2`z,y7 ?c'_@`&= p>qCu/}) }i@yO wז#FyKJT(54#'5D88l}k\|jzK]t\IHVё rg8l`"hKZ-4aNw'_88Q9JOhy"1A@)'ceT&V9[`-J߹Z]֫j5{TM0ң9% nHRR^AsJ-ƠM߱#X`g3+%^&"i%VlGP$2,"j'?Q2yib*GS|y#eMqzDVnYTZ1P `_=&JFN(׷j!_; ?fɷEH) ܽfģ4>+[h$Q:KM'8l>aCdl B;QGw 1EV^<*1ӋJ' 7ݒ[PgmӷlJ[6y-v|8g-.J^kܔ ik%m5HB/C%wR=22s{gZ)l>vGŕ'mwlT->*8QN] |u_'[/dJV3$ lZSI#D*cGP9iph]1H`MˠWif&ia.ΌNoW6^jYG+N/C kQ̈RKp IAS(XJt/lQ_;^ _1y˿mCSˢ1qxFWTg(l$MP#%y*bk 7ǨUN8hhsRxv|{8}wOp0ã?83'8쫮[(ÎZۻ&ɠBy4+#c=NufǪ%í_,C%KeZd(N1Cݖjg>Di\蝙=`n.Onx T< |މؙa u35"E$ Kk zҀ`S5o1 B&>bȾfA(,sg]Av#rd Q ^F@X!!&=T{GIGY4pK1_=%#'J)n*-2s}%51dzTGCJեp?>Ҭ׉y e~[b)5#5 <8 7ꔍGQn71Ȕ:N9)qbUMMX +c̸}nEuG1[`t( RFm:*PfWo{gW@֡X=3voq lRΚ0ME#&DJ&\^)[E 8;> K۹\ZO[2[`a/a -Zu'+Di7YOh_GA tUQX`bdt⼺qa2mRP}L|1n¼.T OHQѯFǦ_\@3pX$ÌGR{#CͅMqXtFtC}kP4ƦFvF|Ŭpu\tZQKàV^ʘg8謡V1rP^b#P^!eiUXiˆcɜUJ{? o$tIBMo2YQ_b \GbMtTϏF#ã=̞¿ߋ*bQw> .[( /Gf1G:F8n]RhԺʟ_nlkdN?y7G |m@er6(Yqҥ1!?]{n^кϐa cΙlt~/0唰F3}:f O/N zJ45: +S|~&H+ R1_ɫĜ)?C\w"dG P1]^U\uqUl|F,8hQ ]G?%GS!1o|/l=HI{HljHk4e~ANŞ+IrJ^*nI9{R-2ih f~7{vwzʘ#Bb{8zp+9R@ʮísHU#ٻTbVMqZRg%ޓ8Es0 ("!^O?G!}rxcs z~/B `^_l.be휏tQEQuz~|<`IA`(Y -W9a,_&?ڎ|J+wXآe>i;Vg'VyBY@d1mӈE* A|wC!IGb0O<3lN=]$:jNBs>^ԇr/_ ^Z>y1&d#TA݃sǜי|6$ S3c_.7a%SnpstM.÷b`uJc{=r! c[_3~mrL5tgg y4\ҀlJL'ol@L)y JVZ<"/GZ*>sCuJؽݸ3(GRwmqOEdMH'_96=ER˜7t"d,~7MC ȔiIw]׈U=h!SJSbuVTDZ/[Zx;h}7“Y=idNIT(g{Ή[Mq!;Ѹ[-X^v\0"]ߊጓ7V|iK&unnA;eTpWiY}Xt ̵֜$?n6qn RaA^? Ml#\ rBGQk7[jIwol>z-v 'U K`lٵK=J >OTTRHgk_{RaӘ03MM\$>ՆBMmW2A.~fلOFӳ![\PPc0=ŪN ͕1r5+QT)kLU] 8gmb.e/ڔ_"W7t+יˋ0eUs)G+!&dLNWziX;)EqTǶ" ~a#Ð\yF_JKu>._6&~~`DbY)l6׮VlGn3UP:\̽"甐495۔`h> wПsHm2niMϑI1\!x%"#uHw5*5ɚ>0kx4 :xhA\ј/%CPNrNKZкL^;tJD8_F"&UtӠxe͹|tpZbBGp5i3N.J'J JKt* Q:f~io,!ѧ;xxK|߻l3trI:n_̺'D*:N0ܤ6݌9C[Yrv.fҺp2#UERoRuw"c#W`~IeN0K%A)_z ]OiGP3ȷ;TT#$M\鏽=[ve_|bn[ 4c9*;:]jPy ;:(D)J̵~aXӘA|А^ԎݐZ7aYM6:r~Li]k \$qQHA4FDœ\m ql34K00 3-"jHa'mYAI('YCdHw]!=@,=InG( q-ÉGykV $ ms',h=HRp<)3s0"y=Pԣ17"xR[: R&9;30Wn2RrUl0.\MTg4+%3ϲ+7)rҰ}K O8}V[iS*(7tڕ %0xՒWߏh4i˧U&#t0|?x+6ACH_^:XfzfWpe!].@Lu 8va;-:=|ǥ7#vl|9y 7aiԵ-iR<US'PĊ a-s3gT:'UzaԇIЎt&#6ǀcP[O}`t4-5e_X +/+}qy'3u,[R^9;65bfNP#BDsgAkܦ7l9uܺ1C黾SIn侰C_<`PBإdeSolve/inst/doc/dynload-dede/0000755000176000001440000000000013136461015015756 5ustar ripleyusersdeSolve/inst/doc/dynload-dede/dedeUtils.c0000644000176000001440000000132613136461015020046 0ustar ripleyusers/* File dedeUtils.c */ #include #include #include #include /* FORTRAN-callable interface to dede utility functions in package deSolve */ void F77_SUB(lagvalue)(double *T, int *nr, int *N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagvalue"); fun(*T, nr, *N, ytau); return; } void F77_SUB(lagderiv)(double *T, int *nr, int *N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagderiv"); fun(*T, nr, *N, ytau); return; } deSolve/inst/doc/dynload-dede/dede_lv2.R0000644000176000001440000000441413136461015017570 0ustar ripleyusers### Lotka-Volterra system with delay library(deSolve) derivs <- function(t, y, parms) { with(as.list(c(y, parms)), { if (t < max(tau1, tau2)) ytau <- c(1, 1) else { ytau <- c( lagvalue(t - tau1, 1), lagvalue(t - tau2, 2) ) } dN <- f * N - g * N * P dP <- e * g * ytau[1] * ytau[2] - m * P list(c(dN, dP), tau=ytau[1], tau=ytau[2]) }) } yinit <- c(N=1, P=1) times <- seq(0, 500) parms <- c(f=0.1, g=0.2, e=0.1, m=0.1, tau1 = 0.2, tau2 = 50) ## one single run system.time( yout <- dede(y = yinit, times = times, func = derivs, parms = parms) ) if (!interactive()) pdf(file="dede_lf2.pdf") plot(yout) system("R CMD SHLIB dede_lv2.c") dyn.load(paste("dede_lv2", .Platform$dynlib.ext, sep="")) ## 100 runs system.time( for (i in 1:100) yout2 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dede_lv2", initfunc = "initmod", nout = 2) ) ## version "derivs2" (different if tau1 != tau2; respects individual tau system.time( for (i in 1:100) yout3 <- dede(yinit, times = times, func = "derivs2", parms = parms, dllname = "dede_lv2", initfunc = "initmod", nout = 2) ) plot(yout2, yout3) # identical if tau1=tau2 dyn.unload(paste("dede_lv2", .Platform$dynlib.ext, sep="")) # should be zero summary(as.vector(yout) - as.vector(yout2)) # can be different from zero summary(as.vector(yout) - as.vector(yout3)) ## ## Fortran Example ## system("R CMD SHLIB dede_lv2F.f dedeUtils.c") dyn.load(paste("dede_lv2F", .Platform$dynlib.ext, sep="")) ## 100 runs system.time( for (i in 1:100) yout4 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dede_lv2F", initfunc = "initmod", nout = 2) ) ## version "derivs2" (different if tau1 != tau2; respects individual tau system.time( for (i in 1:100) yout5 <- dede(yinit, times = times, func = "derivs2", parms = parms, dllname = "dede_lv2F", initfunc = "initmod", nout = 2) ) plot(yout4, yout5) # identical if tau1=tau2 dyn.unload(paste("dede_lv2F", .Platform$dynlib.ext, sep="")) # should be zero summary(as.vector(yout) - as.vector(yout4)) # can be different from zero summary(as.vector(yout) - as.vector(yout5)) if (!interactive()) dev.off() deSolve/inst/doc/dynload-dede/dede_lv.R0000644000176000001440000000312113136461015017500 0ustar ripleyusers### Simple DDE, adapted version of ?dede example from package deSolve library(deSolve) derivs <- function(t, y, parms) { with(as.list(c(y, parms)), { if (t < tau) ytau <- c(1, 1) else ytau <- lagvalue(t - tau, c(1, 2)) dN <- f * N - g * N * P dP <- e * g * ytau[1] * ytau[2] - m * P list(c(dN, dP), tau=ytau[1], tau=ytau[2]) }) } yinit <- c(N=1, P=1) times <- seq(0, 500) parms <- c(f=0.1, g=0.2, e=0.1, m=0.1, tau = .2) ## one single run system.time( yout <- dede(y = yinit, times = times, func = derivs, parms = parms) ) if(!interactive()) pdf(file="dede_lv.pdf") plot(yout) system("R CMD SHLIB dede_lv.c") dyn.load(paste("dede_lv", .Platform$dynlib.ext, sep="")) ## 100 runs system.time( for (i in 1:100) yout2 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dede_lv", initfunc = "initmod", nout = 2) ) dyn.unload(paste("dede_lv", .Platform$dynlib.ext, sep="")) plot(yout2, main=c("y", "ytau")) ## Fortran models still need the c code in dedeUtils.c. ## However, as long as you just use the lagvalue() and lagderiv() ## supplied with deSolve, dedeUtils.c works as is. system("R CMD SHLIB dede_lvF.f dedeUtils.c") dyn.load(paste("dede_lvF", .Platform$dynlib.ext, sep="")) ## 100 runs system.time( for (i in 1:100) yout3 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dede_lvF", initfunc = "initmod", nout = 2) ) dyn.unload(paste("dede_lvF", .Platform$dynlib.ext, sep="")) plot(yout3, main=c("y", "ytau")) if(!interactive()) dev.off() deSolve/inst/doc/dynload-dede/dedesimpleF.f0000644000176000001440000000136113136461015020347 0ustar ripleyusersC file dedesimpleF.f C Initializer for parameter common block subroutine initmod(odeparms) external odeparms double precision parms(2) common /myparms/parms call odeparms(2, parms) return end C Derivatives and one output variable subroutine derivs(neq, t, y, ydot, yout, ip) integer neq, ip(*) double precision t, y(neq), ydot(neq), yout(*) double precision tau, k, ytau(1), tlag integer nr(1) common /myparms/tau, k if (ip(1) < 1) call rexit("nout should be at least 1") nr(1) = 0 ytau(1) = 1.0 tlag = t - tau if (tlag .GT. 0.0) call lagvalue(tlag, nr, 1, ytau) yout(1) = ytau(1) ydot(1) = k * ytau(1) return end deSolve/inst/doc/dynload-dede/dede_lv2.c0000644000176000001440000000520113136461015017604 0ustar ripleyusers/* File dedesimple.c */ #include #include #include #include static double parms[6]; #define f parms[0] #define g parms[1] #define e parms[2] #define m parms[3] #define tau1 parms[4] #define tau2 parms[5] /* Interface to dede utility functions in package deSolve */ void lagvalue(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagvalue"); return fun(T, nr, N, ytau); } void lagderiv(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagderiv"); return fun(T, nr, N, ytau); } /* Initializer */ void initmod(void (* odeparms)(int *, double *)) { int N = 6; odeparms(&N, parms); } /* Derivatives */ void derivs(int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] < 2) error("nout should be at least 2"); double N = y[0]; double P = y[1]; int nr[2] = {0, 1}; // which lags are needed? try: (0, 0) // numbering starts from zero ! double ytau[2] = {1.0, 1.0}; // array; initialize with default values ! double T1 = *t - tau1; double T2 = *t - tau2; if (*t >= fmax(tau1, tau2)) { // time, lag ID, number of returned lags, return value lagvalue(T1, &nr[0], 1, &ytau[0]); lagvalue(T2, &nr[1], 1, &ytau[1]); } ydot[0] = f * N - g * N * P; ydot[1] = e * g * ytau[0] * ytau[1] - m * P; yout[0] = ytau[0]; yout[1] = ytau[1]; } /* ---------------------------------------------------------------------------*/ /* Version 2: A helper function and "derivs2" */ double getlag(double t0, double t, double tau, double ydef, int nr) { double T = t - tau; double y = ydef; if ((t - tau) >= t0) lagvalue(T, &nr, 1, &y); return y; } void derivs2(int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] < 2) error("nout should be at least 2"); double N = y[0]; double P = y[1]; double ytau[2] = {1.0, 1.0}; ytau[0] = getlag (0, *t, tau1, ytau[0], 0); ytau[1] = getlag (0, *t, tau2, ytau[1], 1); ydot[0] = f * N - g * N * P; ydot[1] = e * g * ytau[0] * ytau[1] - m * P; yout[0] = ytau[0]; yout[1] = ytau[1]; } deSolve/inst/doc/dynload-dede/dedesimple.R0000644000176000001440000000273413136461015020222 0ustar ripleyusers### Simple DDE, adapted version of ?dede example from package deSolve library(deSolve) derivs <- function(t, y, parms) { with(as.list(parms), { if (t < tau) ytau <- 1 else ytau <- lagvalue(t - tau) dy <- k * ytau list(c(dy), ytau=ytau) }) } yinit <- c(y=1) times <- seq(0, 30, 0.1) parms <- c(tau = 1, k = -1) ## one single run system.time( yout <- dede(y = yinit, times = times, func = derivs, parms = parms) ) if (!interactive()) pdf(file="dedesimple.pdf") plot(yout, main = c("dy/dt = -y(t-1)", "ytau")) system("R CMD SHLIB dedesimple.c") #dyn.load("dedesimple.dll") dyn.load(paste("dedesimple", .Platform$dynlib.ext, sep="")) ## 100 runs system.time( for (i in 1:100) yout2 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dedesimple", initfunc = "initmod", nout = 1) ) #dyn.unload("dedesimple.dll") dyn.unload(paste("dedesimple", .Platform$dynlib.ext, sep="")) plot(yout2, main=c("y", "ytau")) ## Fortran example system("R CMD SHLIB dedesimpleF.f dedeUtils.c") dyn.load(paste("dedesimpleF", .Platform$dynlib.ext, sep="")) ## 100 runs system.time( for (i in 1:100) yout3 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dedesimpleF", initfunc = "initmod", nout = 1) ) #dyn.unload("dedesimple.dll") dyn.unload(paste("dedesimpleF", .Platform$dynlib.ext, sep="")) plot(yout3, main=c("y", "ytau")) if (!interactive()) dev.off() deSolve/inst/doc/dynload-dede/dede_lv.c0000644000176000001440000000320613136461015017525 0ustar ripleyusers/* File dedesimple.c */ #include #include #include #include static double parms[5]; #define f parms[0] #define g parms[1] #define e parms[2] #define m parms[3] #define tau parms[4] /* Interface to dede utility functions in package deSolve */ void lagvalue(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagvalue"); return fun(T, nr, N, ytau); } void lagderiv(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagderiv"); return fun(T, nr, N, ytau); } /* Initializer */ void initmod(void (* odeparms)(int *, double *)) { int N = 5; odeparms(&N, parms); } /* Derivatives */ void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] < 2) error("nout should be at least 1"); double N = y[0]; double P = y[1]; int Nout = 2; // number of returned lags ( <= n_eq !!) int nr[2] = {0, 1}; // which lags are needed? try: (0, 0) // numbering starts from zero ! double ytau[2] = {1.0, 1.0}; // array; initialize with default values ! double T = *t - tau; if (*t > tau) { lagvalue(T, nr, Nout, ytau); //Rprintf("test %g %g %g \n", T, y[0], ytau[0]); } ydot[0] = f * N - g * N * P; ydot[1] = e * g * ytau[0] * ytau[1] - m * P; yout[0] = ytau[0]; yout[1] = ytau[1]; } deSolve/inst/doc/dynload-dede/dede_lvF.f0000644000176000001440000000166613136461015017646 0ustar ripleyusersC file dede_lfF.f C Initializer for parameter common block subroutine initmod(odeparms) external odeparms double precision parms(5) common /myparms/parms call odeparms(5, parms) return end C Derivatives and one output variable subroutine derivs(neq, t, y, ydot, yout, ip) integer neq, ip(*) double precision t, y(neq), ydot(neq), yout(*) double precision N, P, ytau(2), tlag integer nr(2) double precision f, g, e, m, tau common /myparms/f, g, e, m, tau if (ip(1) < 2) call rexit("nout should be at least 2") N = y(1) P = y(2) nr(1) = 0 nr(2) = 1 ytau(1) = 1.0 ytau(2) = 1.0 tlag = t - tau if (tlag .GT. 0.0) call lagvalue(tlag, nr, 2, ytau) ydot(1) = f * N - g * N * P ydot(2) = e * g * ytau(1) * ytau(2) - m * P yout(1) = ytau(1) yout(2) = ytau(2) return end deSolve/inst/doc/dynload-dede/dede_lv2F.f0000644000176000001440000000375713136461015017733 0ustar ripleyusersC file dede_lf2F.f C Initializer for parameter common block subroutine initmod(odeparms) external odeparms double precision parms(6) common /myparms/parms call odeparms(6, parms) return end C Derivatives and one output variable subroutine derivs(neq, t, y, ydot, yout, ip) integer neq, ip(*) double precision t, y(neq), ydot(neq), yout(*) double precision N, P, ytau(2), tlag1, tlag2 integer nr(2) double precision f, g, e, m, tau1, tau2 common /myparms/f, g, e, m, tau1, tau2 if (ip(1) < 2) call rexit("nout should be at least 2") N = y(1) P = y(2) nr(1) = 0 nr(2) = 1 ytau(1) = 1.0 ytau(2) = 1.0 tlag1 = t - tau1 tlag2 = t - tau2 if (min(tlag1, tlag2) .GE. 0.0) then call lagvalue(tlag1, nr(1), 1, ytau(1)) call lagvalue(tlag2, nr(2), 1, ytau(2)) endif ydot(1) = f * N - g * N * P ydot(2) = e * g * ytau(1) * ytau(2) - m * P yout(1) = ytau(1) yout(2) = ytau(2) return end double precision function getlag(t0, t, tau, ydef, nr) double precision t0, t, tau, ydef integer nr double precision tlag, y tlag = t - tau y = ydef if (tlag .GE. t0) call lagvalue(tlag, nr, 1, y) getlag = y return end subroutine derivs2(neq, t, y, ydot, yout, ip) integer neq, ip(*) double precision t, y(neq), ydot(neq), yout(*) double precision N, P, ytau(2), getlag double precision f, g, e, m, tau1, tau2 common /myparms/f, g, e, m, tau1, tau2 if (ip(1) < 2) call rexit("nout should be at least 2") N = y(1) P = y(2) ytau(1) = 1.0 ytau(2) = 1.0 ytau(1) = getlag(0.0, t, tau1, ytau(1), 0) ytau(2) = getlag(0.0, t, tau2, ytau(2), 1) ydot(1) = f * N - g * N * P ydot(2) = e * g * ytau(1) * ytau(2) - m * P yout(1) = ytau(1) yout(2) = ytau(2) return end deSolve/inst/doc/dynload-dede/dedesimple.c0000644000176000001440000000256213136461015020242 0ustar ripleyusers/* File dedesimple.c */ #include #include #include #include static double parms[2]; #define tau parms[0] #define k parms[1] /* Interface to dede utility functions in package deSolve */ void lagvalue(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagvalue"); return fun(T, nr, N, ytau); } void lagderiv(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagderiv"); return fun(T, nr, N, ytau); } /* Initializer */ void initmod(void (* odeparms)(int *, double *)) { int N = 2; odeparms(&N, parms); } /* Derivatives */ void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] < 1) error("nout should be at least 1"); int nr[1] = {0}; // which lags are needed? // numbering starts from zero ! double ytau[1] = {1.0}; // array; initialize with default values ! double T = *t - tau; if (*t > tau) { lagvalue(T, nr, 1, ytau); //Rprintf("test %g %g %g \n", T, y[0], ytau[0]); } yout[0] = ytau[0]; ydot[0] = k * ytau[0]; } deSolve/inst/doc/compiledCode.Rnw0000644000176000001440000017231713136461014016516 0ustar ripleyusers\documentclass[article,nojss]{jss} \DeclareGraphicsExtensions{.pdf,.eps} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Add-on packages and fonts \usepackage{amsmath} \usepackage{xspace} \usepackage{verbatim} \usepackage[english]{babel} %\usepackage{mathptmx} %\usepackage{helvet} \usepackage[T1]{fontenc} \usepackage[latin1]{inputenc} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% User specified LaTeX commands. \newcommand{\Rmodels}{\textbf{\textsf{R models}}\xspace} \newcommand{\DLLmodels}{\textbf{\textsf{DLL models}}\xspace} \title{\proglang{R} Package \pkg{deSolve}, Writing Code in Compiled Languages} \Plaintitle{R Package deSolve, Writing Code in Compiled Languages} \Keywords{differential equation solvers, compiled code, performance, \proglang{FORTRAN}, \proglang{C}} \Plainkeywords{differential equation solvers, compiled code, performance, FORTRAN, C} \author{ Karline Soetaert\\ Royal Netherlands Institute\\ of Sea Research (NIOZ)\\ Yerseke\\ The Netherlands \And Thomas Petzoldt\\ Technische Universit\"at \\ Dresden\\ Germany \And R. Woodrow Setzer\\ National Center for\\ Computational Toxicology\\ US Environmental Protection Agency } \Plainauthor{Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer} \Abstract{This document describes how to use the \pkg{deSolve} package \citep{deSolve_jss} to solve models that are written in \proglang{FORTRAN} or \proglang{C}.} %% The address of (at least) one author should be given %% in the following format: \Address{ Karline Soetaert\\ Royal Netherlands Institute of Sea Research (NIOZ)\\ 4401 NT Yerseke, Netherlands \\ E-mail: \email{karline.soetaert@nioz.nl}\\ URL: \url{http://www.nioz.nl}\\ \\ Thomas Petzoldt\\ Institut f\"ur Hydrobiologie\\ Technische Universit\"at Dresden\\ 01062 Dresden, Germany\\ E-mail: \email{thomas.petzoldt@tu-dresden.de}\\ URL: \url{http://tu-dresden.de/Members/thomas.petzoldt/}\\ \\ R. Woodrow Setzer\\ National Center for Computational Toxicology\\ US Environmental Protection Agency\\ URL: \url{http://www.epa.gov/comptox} } %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% R/Sweave specific LaTeX commands. %% need no \usepackage{Sweave} %\VignetteIndexEntry{R Package deSolve: Writing Code in Compiled Languages} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Begin of the document \begin{document} \SweaveOpts{engine=R,eps=FALSE} <>= library("deSolve") options(prompt = "R> ") options(width=70) @ \maketitle \section{Introduction} \pkg{deSolve} \citep{deSolve_jss,deSolve}, the successor of \proglang{R} package \pkg{odesolve} \citep{Setzer01} is a package to solve ordinary differential equations (ODE), differential algebraic equations (DAE) and partial differential equations (PDE). One of the prominent features of \pkg{deSolve} is that it allows specifying the differential equations either as: \begin{itemize} \item pure \proglang{R} code \citep{Rcore}, \item functions defined in lower-level languages such as \proglang{FORTRAN}, \proglang{C}, or \proglang{C++}, which are compiled into a dynamically linked library (DLL) and loaded into \proglang{R}. \end{itemize} In what follows, these implementations will be referred to as \Rmodels and \DLLmodels respectively. Whereas \Rmodels are easy to implement, they allow simple interactive development, produce highly readible code and access to \proglang{R}s high-level procedures, \DLLmodels have the benefit of increased simulation speed. Depending on the problem, there may be a gain of up to several orders of magnitude computing time when using compiled code. Here are some rules of thumb when it is worthwhile or not to switch to \DLLmodels: \begin{itemize} \item As long as one makes use only of \proglang{R}s high-level commands, the time gain will be modest. This was demonstrated in \citet{deSolve_jss}, where a formulation of two interacting populations dispersing on a 1-dimensional or a 2-dimensional grid led to a time gain of a factor two only when using \DLLmodels. \item Generally, the more statements in the model, the higher will be the gain of using compiled code. Thus, in the same paper \citep{deSolve_jss}, a very simple, 0-D, Lotka-Volterrra type of model describing only 2 state variables was solved 50 times faster when using compiled code. \item As even \Rmodels are quite performant, the time gain induced by compiled code will often not be discernible when the model is only solved once (who can grasp the difference between a run taking 0.001 or 0.05 seconds to finish). However, if the model is to be applied multiple times, e.g. because the model is to be fitted to data, or its sensitivity is to be tested, then it may be worthwhile to implement the model in a compiled language. \end{itemize} Starting from \pkg{deSolve} version 1.4, it is now also possible to use \emph{forcing functions} in compiled code. These forcing functions are automatically updated by the integrators. See last chapter. \section{A simple ODE example} Assume the following simple ODE (which is from the \code{LSODA} source code): \begin{align*} \frac{{dy_1}}{{dt}} &= - k_1 \cdot y_1 + k_2 \cdot y_2 \cdot y_3 \\ \frac{{dy_2}}{{dt}} &= k_1 \cdot y_1 - k_2 \cdot y_2 \cdot y_3 - k_3 \cdot y_2 \cdot y_2 \\ \frac{{dy_3}}{{dt}} &= k_3 \cdot y_2 \cdot y_2 \\ \end{align*} where $y_1$, $y_2$ and $y_3$ are state variables, and $k_1$, $k_2$ and $k_3$ are parameters. We first implement and run this model in pure \proglang{R}, then show how to do this in \proglang{C} and in \proglang{FORTRAN}. \subsection{ODE model implementation in R} An ODE model implemented in \textbf{pure \proglang{R}} should be defined as: \begin{verbatim} yprime = func(t, y, parms, ...) \end{verbatim} where \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system, and \code{parms} is a vector or list containing the parameter values. The optional dots argument (\code{\dots}) can be used to pass any other arguments to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to time, and whose next elements contain output variables that are required at each point in time. The \proglang{R} implementation of the simple ODE is given below: <>= model <- function(t, Y, parameters) { with (as.list(parameters),{ dy1 = -k1*Y[1] + k2*Y[2]*Y[3] dy3 = k3*Y[2]*Y[2] dy2 = -dy1 - dy3 list(c(dy1, dy2, dy3)) }) } @ The Jacobian ($\frac{{\partial y'}}{{\partial y}}$) associated to the above example is: <>= jac <- function (t, Y, parameters) { with (as.list(parameters),{ PD[1,1] <- -k1 PD[1,2] <- k2*Y[3] PD[1,3] <- k2*Y[2] PD[2,1] <- k1 PD[2,3] <- -PD[1,3] PD[3,2] <- k3*Y[2] PD[2,2] <- -PD[1,2] - PD[3,2] return(PD) }) } @ This model can then be run as follows: <>= parms <- c(k1 = 0.04, k2 = 1e4, k3=3e7) Y <- c(1.0, 0.0, 0.0) times <- c(0, 0.4*10^(0:11)) PD <- matrix(nrow = 3, ncol = 3, data = 0) out <- ode(Y, times, model, parms = parms, jacfunc = jac) @ \subsection{ODE model implementation in C} \label{sec:Cexamp} In order to create compiled models (.DLL = dynamic link libraries on Windows or .so = shared objects on other systems) you must have a recent version of the GNU compiler suite installed, which is quite standard for Linux. Windows users find all the required tools on \url{http://www.murdoch-sutherland.com/Rtools/}. Getting DLLs produced by other compilers to communicate with R is much more complicated and therefore not recommended. More details can be found on \url{http://cran.r-project.org/doc/manuals/R-admin.html}. The call to the derivative and Jacobian function is more complex for compiled code compared to \proglang{R}-code, because it has to comply with the interface needed by the integrator source codes. Below is an implementation of this model in \proglang{C}: \verbatiminput{mymod.c} The implementation in \proglang{C} consists of three parts: \begin{enumerate} \item After defining the parameters in global \proglang{C}-variables, through the use of \code{\#define} statements, a function called \code{initmod} initialises the parameter values, passed from the \proglang{R}-code. This function has as its sole argument a pointer to \proglang{C}-function \code{odeparms} that fills a double array with double precision values, to copy the parameter values into the global variable. \item Function \code{derivs} then calculates the values of the derivatives. The derivative function is defined as: \begin{verbatim} void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) \end{verbatim} where \code{*neq} is the number of equations, \code{*t} is the value of the independent variable, \code{*y} points to a double precision array of length \code{*neq} that contains the current value of the state variables, and \code{*ydot} points to an array that will contain the calculated derivatives. \code{*yout} points to a double precision vector whose first \code{nout} values are other output variables (different from the state variables \code{y}), and the next values are double precision values as passed by parameter \code{rpar} when calling the integrator. The key to the elements of \code{*yout} is set in \code{*ip} \code{*ip} points to an integer vector whose length is at least 3; the first element (\code{ip[0]}) contains the number of output values (which should be equal or larger than \code{nout}), its second element contains the length of \code{*yout}, and the third element contains the length of \code{*ip}; next are integer values, as passed by parameter \code{ipar} when calling the integrator.\footnote{Readers familiar with the source code of the \pkg{ODEPACK} solvers may be surprised to find the double precision vector \code{yout} and the integer vector \code{ip} at the end. Indeed none of the \pkg{ODEPACK} functions allow this, although it is standard in the \code{vode} and \code{daspk} codes. To make all integrators compatible, we have altered the \pkg{ODEPACK} \proglang{FORTRAN} codes to consistently pass these vectors.} Note that, in function \code{derivs}, we start by checking whether enough memory is allocated for the output variables (\code{if (ip[0] < 1)}), else an error is passed to \proglang{R} and the integration is stopped. \item In \proglang{C}, the call to the function that generates the Jacobian is as: \begin{verbatim} void jac(int *neq, double *t, double *y, int *ml, int *mu, double *pd, int *nrowpd, double *yout, int *ip) \end{verbatim} where \code{*ml} and \code{*mu} are the number of non-zero bands below and above the diagonal of the Jacobian respectively. These integers are only relevant if the option of a banded Jacobian is selected. \code{*nrow} contains the number of rows of the Jacobian. Only for full Jacobian matrices, is this equal to \code{*neq}. In case the Jacobian is banded, the size of \code{*nrowpd} depends on the integrator. If the method is one of \code{lsode, lsoda, vode}, then \code{*nrowpd} will be equal to \code{*mu + 2 * *ml + 1}, where the last \code{*ml} rows should be filled with $0$s. For \code{radau}, \code{*nrowpd} will be equal to \code{*mu + *ml + 1} See example ``odeband'' in the directory \url{doc/examples/dynload}, and chapter \ref{band}. \end{enumerate} \subsection{ODE model implementation in FORTRAN} \label{sec:forexamp} Models may also be defined in \proglang{FORTRAN}. \verbatiminput{mymod.f} In \proglang{FORTRAN}, parameters may be stored in a common block (here called \code{myparms}). During the initialisation, this common block is defined to consist of a 3-valued vector (unnamed), but in the subroutines \code{derivs} and \code{jac}, the parameters are given a name (\code{k1}, ...). \subsection{Running ODE models implemented in compiled code} To run the models described above, the code in \code{mymod.f} and \code{mymod.c} must first be compiled\footnote{This requires a correctly installed GNU compiler, see above.}. This can simply be done in \proglang{R} itself, using the \code{system} command: <>= system("R CMD SHLIB mymod.f") @ for the \proglang{FORTRAN} code or <>= system("R CMD SHLIB mymod.c") @ for the \proglang{C} code. This will create file \code{mymod.dll} on windows, or \code{mymod.so} on other platforms. We load the DLL, in windows as: \begin{verbatim} dyn.load("mymod.dll") \end{verbatim} and in unix: \begin{verbatim} dyn.load("mymod.so") \end{verbatim} or, using a general statement: \begin{verbatim} dyn.load(paste("mymod", .Platform$dynlib.ext, sep = "")) \end{verbatim} The model can now be run as follows: \begin{verbatim} parms <- c(k1 = 0.04, k2 = 1e4, k3=3e7) Y <- c(y1 = 1.0, y2 = 0.0, y3 = 0.0) times <- c(0, 0.4*10^(0:11) ) out <- ode(Y, times, func = "derivs", parms = parms, jacfunc = "jac", dllname = "mymod", initfunc = "initmod", nout = 1, outnames = "Sum") \end{verbatim} The integration routine (here \code{ode}) recognizes that the model is specified as a DLL due to the fact that arguments \code{func} and \code{jacfunc} are not regular \proglang{R}-functions but character strings. Thus, the integrator will check whether the function is loaded in the DLL with name \code{mymod}. Note that \code{mymod}, as specified by \code{dllname} gives the name of the shared library \emph{without extension}. This DLL should contain all the compiled function or subroutine definitions referred to in \code{func}, \code{jacfunc} and \code{initfunc}. Also, if \code{func} is specified in compiled code, then \code{jacfunc} and \code{initfunc} (if present) should also be specified in a compiled language. It is not allowed to mix \proglang{R}-functions and compiled functions. Note also that, when invoking the integrator, we have to specify the number of ordinary output variables, \code{nout}. This is because the integration routine has to allocate memory to pass these output variables back to \proglang{R}. There is no way to check for the number of output variables in a DLL automatically. If in the calling of the integration routine the number of output variables is too low, then \proglang{R} may freeze and need to be terminated! Therefore it is advised that one checks in the code whether \code{nout} has been specified correctly. In the \proglang{FORTRAN} example above, the statement \code{if (ip(1) < 1) call rexit("nout should be at least 1")} does this. Note that it is not an error (just a waste of memory) to set \code{nout} to a too large value. Finally, in order to label the output matrix, the names of the ordinary output variables have to be passed explicitly (\code{outnames}). This is not necessary for the state variables, as their names are known through their initial condition (\code{y}). \section{Alternative way of passing parameters and data in compiled code} \label{sec:parms} All of the solvers in \pkg{deSolve} take an argument \code{parms} which may be an arbitrary \proglang{R} object. In models defined in \proglang{R} code, this argument is passed unprocessed to the various functions that make up the model. It is possible, as well, to pass such R-objects to models defined in native code. The problem is that data passed to, say, \code{ode} in the argument \code{parms} is not visible by default to the routines that define the model. This is handled by a user-written initialization function, for example \code{initmod} in the \proglang{C} and \proglang{FORTRAN} examples from sections \ref{sec:Cexamp} and \ref{sec:forexamp}. However, these set only the \emph{values} of the parameters. R-objects have many attributes that may also be of interest. To have access to these, we need to do more work, and this mode of passing parameters and data is much more complex than what we saw in previous chapters. In \proglang{C}, the initialization routine is declared: \begin{verbatim} void initmod(void (* odeparms)(int *, double *)); \end{verbatim} That is, \code{initmod} has a single argument, a pointer to a function that has as arguments a pointer to an \texttt{int} and a pointer to a \texttt{double}. In \proglang{FORTRAN}, the initialization routine has a single argument, a subroutine declared to be external. The name of the initialization function is passed as an argument to the \pkg{deSolve} solver functions. In \proglang{C}, two approaches are available for making the values passed in \code{parms} visible to the model routines, while only the simpler approach is available in \proglang{FORTRAN}. The simpler requires that \code{parms} be a numeric vector. In \proglang{C}, the function passed from \pkg{deSolve} to the initialization function (called \code{odeparms} in the example) copies the values from the parameter vector to a static array declared globally in the file where the model is defined. In \proglang{FORTRAN}, the values are copied into a \code{COMMON} block. It is possible to pass more complicated structures to \proglang{C} functions. Here is an example, an initializer called \code{deltamethrin} from a model describing the pharmacokinetics of that pesticide: \begin{verbatim} #include #include #include #include "deltamethrin.h" /* initializer */ void deltamethrin(void(* odeparms)(int *, double *)) { int Nparms; DL_FUNC get_deSolve_gparms; SEXP gparms; get_deSolve_gparms = R_GetCCallable("deSolve","get_deSolve_gparms"); gparms = get_deSolve_gparms(); Nparms = LENGTH(gparms); if (Nparms != N_PARMS) { PROBLEM "Confusion over the length of parms" ERROR; } else { _RDy_deltamethrin_parms = REAL(gparms); } } \end{verbatim} In \texttt{deltamethrin.h}, the variable \code{\_RDy\_deltamethrin\_parms} and macro N\_PARMS are declared: \begin{verbatim} #define N_PARMS 63 static double *_RDy_deltamethrin_parms; \end{verbatim} The critical element of this method is the function \code{R\_GetCCallable} which returns a function (called \code{get\_deSolve\_gparms} in this implementation) that returns the parms argument as a \code{SEXP} data type. In this example, \code{parms} was just a real vector, but in principle, this method can handle arbitrarily complex objects. For more detail on handling \proglang{R} objects in native code, see \proglang{R} Development Core Team (2008). \section{deSolve integrators that support DLL models} In the most recent version of \pkg{deSolve} all integration routines can solve \DLLmodels. They are: \begin{itemize} \item all solvers of the \code{lsode} familiy: \code{lsoda}, \code{lsode}, \code{lsodar}, \code {lsodes}, \item \code{vode}, \code{zvode}, \item \code{daspk}, \item \code{radau}, \item the Runge-Kutta integration routines (including the Euler method). \end{itemize} For some of these solvers the interface is slightly different (e.g. \code{zvode, daspk}), while in others (\code{lsodar}, \code{lsodes}) different functions can be defined. How this is implemented in a compiled language is discussed next. \subsection{Complex numbers, function zvode} \code{zvode} solves ODEs that are composed of complex variables. The program below uses \code{zvode} to solve the following system of 2 ODEs: \begin{align*} \frac{{dz}}{{dt}} &= i \cdot z\\ \frac{{dw}}{{dt}} &= -i \cdot w \cdot w \cdot z\\ \end{align*} where \begin{align*} w(0) = 1/2.1 +0i\\ z(0) = 1i \end{align*} on the interval t = [0, 2 $\pi$] The example is implemented in \proglang{FORTRAN}% \footnote{this can be found in file "zvodedll.f", in the dynload subdirectory of the package}, \code{FEX} implements the function \code{func}: \begin{verbatim} SUBROUTINE FEX (NEQ, T, Y, YDOT, RPAR, IPAR) INTEGER NEQ, IPAR(*) DOUBLE COMPLEX Y(NEQ), YDOT(NEQ), RPAR(*), CMP DOUBLE PRECISION T character(len=100) msg c the imaginary unit i CMP = DCMPLX(0.0D0,1.0D0) YDOT(1) = CMP*Y(1) YDOT(2) = -CMP*Y(2)*Y(2)*Y(1) RETURN END \end{verbatim} \code{JEX} implements the function \code{jacfunc} \begin{verbatim} SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD, RPAR, IPAR) INTEGER NEQ, ML, MU, NRPD, IPAR(*) DOUBLE COMPLEX Y(NEQ), PD(NRPD,NEQ), RPAR(*), CMP DOUBLE PRECISION T c the imaginary unit i CMP = DCMPLX(0.0D0,1.0D0) PD(2,3) = -2.0D0*CMP*Y(1)*Y(2) PD(2,1) = -CMP*Y(2)*Y(2) PD(1,1) = CMP RETURN END \end{verbatim} Assuming this code has been compiled and is in a DLL called "zvodedll.dll", this model is solved in R as follows: \begin{verbatim} dyn.load("zvodedll.dll") outF <- zvode(func = "fex", jacfunc = "jex", y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10, dllname = "zvodedll", initfunc = NULL) \end{verbatim} Note that in \proglang{R} names of \proglang{FORTRAN} DLL functions (e.g. for \code{func} and \code{jacfunc}) have to be given in lowercase letters, even if they are defined upper case in \proglang{FORTRAN}. Also, there is no initialiser function here (\code{initfunc = NULL}). \subsection{DAE models, integrator daspk} \code{daspk} is one of the integrators in the package that solve DAE models. In order to be used with DASPK, DAEs are specified in implicit form: \[0 = F(t, y, y', p)\] i.e. the DAE function (passed via argument \code{res}) specifies the ``residuals'' rather than the derivatives (as for ODEs). Consequently the DAE function specification in a compiled language is also different. For code written in \proglang{C}, the calling sequence for \code{res} must be: \begin{verbatim} void myres(double *t, double *y, double *ydot, double *cj, double *delta, int *ires, double *yout, int *ip) \end{verbatim} where \code{*t} is the value of the independent variable, \code{*y} points to a double precision vector that contains the current value of the state variables, \code{*ydot} points to an array that will contain the derivatives, \code{*delta} points to a vector that will contain the calculated residuals. \code{*cj} points to a scalar, which is normally proportional to the inverse of the stepsize, while \code{*ires} points to an integer (not used). \code{*yout} points to any other output variables (different from the state variables y), followed by the double precision values as passed via argument \code{rpar}; finally \code{*ip} is an integer vector containing at least 3 elements, its first value (\code{*ip[0]}) equals the number of output variables, calculated in the function (and which should be equal to \code{nout}), its second element equals the total length of \code{*yout}, its third element equals the total length of \code{*ip}, and finally come the integer values as passed via argument \code{ipar}. For code written in \proglang{FORTRAN}, the calling sequence for \code{res} must be as in the following example: \begin{verbatim} subroutine myresf(t, y, ydot, cj, delta, ires, out, ip) integer :: ires, ip(*) integer, parameter :: neq = 3 double precision :: t, y(neq), ydot(neq), delta(neq), out(*) double precision :: K, ka, r, prod, ra, rb common /myparms/K,ka,r,prod if(ip(1) < 1) call rexit("nout should be at least 1") ra = ka* y(3) rb = ka/K *y(1) * y(2) !! residuals of rates of changes delta(3) = -ydot(3) - ra + rb + prod delta(1) = -ydot(1) + ra - rb delta(2) = -ydot(2) + ra - rb - r*y(2) out(1) = y(1) + y(2) + y(3) return end \end{verbatim} Similarly as for the ODE model discussed above, the parameters are kept in a common block which is initialised by an initialiser subroutine: \begin{verbatim} subroutine initpar(daspkparms) external daspkparms integer, parameter :: N = 4 double precision parms(N) common /myparms/parms call daspkparms(N, parms) return end \end{verbatim} See the ODE example for how to initialise parameter values in \proglang{C}. Similarly, the function that specifies the Jacobian in a DAE differs from the Jacobian when the model is an ODE. The DAE Jacobian is set with argument \code{jacres} rather than \code{jacfunc} when an ODE. For code written in \proglang{FORTRAN}, the \code{jacres} must be as: \begin{verbatim} subroutine resjacfor (t, y, dy, pd, cj, out, ipar) integer, parameter :: neq = 3 integer :: ipar(*) double precision :: K, ka, r, prod double precision :: pd(neq,neq),y(neq),dy(neq),out(*) common /myparms/K,ka,r,prod !res1 = -dD - ka*D + ka/K *A*B + prod PD(1,1) = ka/K *y(2) PD(1,2) = ka/K *y(1) PD(1,3) = -ka -cj !res2 = -dA + ka*D - ka/K *A*B PD(2,1) = -ka/K *y(2) -cj PD(2,2) = -ka/K *y(2) PD(2,3) = ka !res3 = -dB + ka*D - ka/K *A*B - r*B PD(3,1) = -ka/K *y(2) PD(3,2) = -ka/K *y(2) -r -cj PD(3,3) = ka return end \end{verbatim} \subsection{DAE models, integrator radau} Function \code{radau} solves DAEs in linearly implicit form, i.e. in the form $M y' = f(t, y, p)$. The derivative function $f$ is specified in the same way as for an ODE, i.e. \begin{verbatim} void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) \end{verbatim} and \begin{verbatim} subroutine derivs (neq, t, y, ydot, out, IP) \end{verbatim} for \proglang{C} and \proglang{FORTRAN} code respectively. To show how it should be used, we implement the caraxis problem as in \citep{testset}. The implementation of this index 3 DAE, comprising 8 differential, and 2 algebraic equations in R is the last example of the \code{radau} help page. We first repeat the R implementation: <<>>= caraxisfun <- function(t, y, parms) { with(as.list(c(y, parms)), { yb <- r * sin(w * t) xb <- sqrt(L * L - yb * yb) Ll <- sqrt(xl^2 + yl^2) Lr <- sqrt((xr - xb)^2 + (yr - yb)^2) dxl <- ul; dyl <- vl; dxr <- ur; dyr <- vr dul <- (L0-Ll) * xl/Ll + 2 * lam2 * (xl-xr) + lam1*xb dvl <- (L0-Ll) * yl/Ll + 2 * lam2 * (yl-yr) + lam1*yb - k * g dur <- (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr) dvr <- (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k * g c1 <- xb * xl + yb * yl c2 <- (xl - xr)^2 + (yl - yr)^2 - L * L list(c(dxl, dyl, dxr, dyr, dul, dvl, dur, dvr, c1, c2)) }) } eps <- 0.01; M <- 10; k <- M * eps^2/2; L <- 1; L0 <- 0.5; r <- 0.1; w <- 10; g <- 1 parameter <- c(eps = eps, M = M, k = k, L = L, L0 = L0, r = r, w = w, g = g) yini <- c(xl = 0, yl = L0, xr = L, yr = L0, ul = -L0/L, vl = 0, ur = -L0/L, vr = 0, lam1 = 0, lam2 = 0) # the mass matrix Mass <- diag(nrow = 10, 1) Mass[5,5] <- Mass[6,6] <- Mass[7,7] <- Mass[8,8] <- M * eps * eps/2 Mass[9,9] <- Mass[10,10] <- 0 Mass # index of the variables: 4 of index 1, 4 of index 2, 2 of index 3 index <- c(4, 4, 2) times <- seq(0, 3, by = 0.01) out <- radau(y = yini, mass = Mass, times = times, func = caraxisfun, parms = parameter, nind = index) @ <>= plot(out, which = 1:4, type = "l", lwd = 2) @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the caraxis model - see text for R-code} \label{fig:caraxis} \end{figure} The implementation in \proglang{FORTRAN} consists of an initialiser function and a derivative function. \begin{verbatim} c---------------------------------------------------------------- c Initialiser for parameter common block c---------------------------------------------------------------- subroutine initcaraxis(daeparms) external daeparms integer, parameter :: N = 8 double precision parms(N) common /myparms/parms call daeparms(N, parms) return end c---------------------------------------------------------------- c rate of change c---------------------------------------------------------------- subroutine caraxis(neq, t, y, ydot, out, ip) implicit none integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*) double precision eps, M, k, L, L0, r, w, g common /myparms/ eps, M, k, L, L0, r, w, g double precision xl, yl, xr, yr, ul, vl, ur, vr, lam1, lam2 double precision yb, xb, Ll, Lr, dxl, dyl, dxr, dyr double precision dul, dvl, dur, dvr, c1, c2 c expand state variables xl = y(1) yl = y(2) xr = y(3) yr = y(4) ul = y(5) vl = y(6) ur = y(7) vr = y(8) lam1 = y(9) lam2 = y(10) yb = r * sin(w * t) xb = sqrt(L * L - yb * yb) Ll = sqrt(xl**2 + yl**2) Lr = sqrt((xr - xb)**2 + (yr - yb)**2) dxl = ul dyl = vl dxr = ur dyr = vr dul = (L0-Ll) * xl/Ll + 2 * lam2 * (xl-xr) + lam1*xb dvl = (L0-Ll) * yl/Ll + 2 * lam2 * (yl-yr) + lam1*yb - k*g dur = (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr) dvr = (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k*g c1 = xb * xl + yb * yl c2 = (xl - xr)**2 + (yl - yr)**2 - L * L c function values in ydot ydot(1) = dxl ydot(2) = dyl ydot(3) = dxr ydot(4) = dyr ydot(5) = dul ydot(6) = dvl ydot(7) = dur ydot(8) = dvr ydot(9) = c1 ydot(10) = c2 return end \end{verbatim} Assuming that the code is in file ``radaudae.f'', this model is compiled, loaded and solved in R as: \begin{verbatim} system("R CMD SHLIB radaudae.f") dyn.load(paste("radaudae", .Platform$dynlib.ext, sep = "")) outDLL <- radau(y = yini, mass = Mass, times = times, func = "caraxis", initfunc = "initcaraxis", parms = parameter, dllname = "radaudae", nind = index) dyn.unload(paste("radaudae", .Platform$dynlib.ext, sep = "")) \end{verbatim} \subsection{The root function from integrators lsodar and lsode} \code{lsodar} is an extended version of integrator \code{lsoda} that includes a root finding function. This function is spedified via argument \code{rootfunc}. In \code{deSolve} version 1.7, \code{lsode} has also been extended with root finding capabilities. Here is how to program such a function in a lower-level language. For code written in \proglang{C}, the calling sequence for \code{rootfunc} must be: \begin{verbatim} void myroot(int *neq, double *t, double *y, int *ng, double *gout, double *out, int *ip ) \end{verbatim} where \code{*neq} and \code{*ng} are the number of state variables and root functions respectively, \code{*t} is the value of the independent variable, \code{y} points to a double precision array that contains the current value of the state variables, and \code{gout} points to an array that will contain the values of the constraint function whose root is sought. \code{*out} and \code{*ip} are a double precision and integer vector respectively, as described in the ODE example above. For code written in \proglang{FORTRAN}, the calling sequence for \code{rootfunc} must be as in following example: \begin{verbatim} subroutine myroot(neq, t, y, ng, gout, out, ip) integer :: neq, ng, ip(*) double precision :: t, y(neq), gout(ng), out(*) gout(1) = y(1) - 1.e-4 gout(2) = y(3) - 1e-2 return end \end{verbatim} \subsection{jacvec, the Jacobian vector for integrator lsodes} Finally, in integration function \code{lsodes}, not the Jacobian \emph{matrix} is specified, but a \emph{vector}, one for each column of the Jacobian. This function is specified via argument \code{jacvec}. In \proglang{FORTRAN}, the calling sequence for \code{jacvec} is: \begin{verbatim} SUBROUTINE JAC (NEQ, T, Y, J, IAN, JAN, PDJ, OUT, IP) DOUBLE PRECISION T, Y(*), IAN(*), JAN(*), PDJ(*), OUT(*) INTEGER NEQ, J, IP(*) \end{verbatim} \subsection{Banded jacobians in compiled code}\label{band} In the call of the jacobian function, the number of bands below and above the diagonal (\code{ml, mu}) and the number of rows of the Jacobian matrix, \code{nrowPD} is specified, e.g. for \proglang{FORTRAN} code: \begin{verbatim} SUBROUTINE JAC (neq, T, Y, ml, mu, PD, nrowPD, RPAR, IPAR) \end{verbatim} The jacobian matrix to be returned should have dimension \code{nrowPD, neq}. In case the Jacobian is banded, the size of \code{nrowPD} depends on the integrator. If the method is one of \code{lsode, lsoda, vode}, or related, then \code{nrowPD} will be equal to \code{mu + 2 * ml + 1}, where the last ml rows should be filled with $0$s. For \code{radau}, \code{nrowpd} will be equal to \code{mu + ml + 1} Thus, it is important to write the FORTRAN or C-code in such a way that it can be used with both types of integrators - else it is likely that R will freeze if the wrong integrator is used. We implement in FORTRAN, the example of the \code{lsode} help file. The R-code reads: <<>>= ## the model, 5 state variables f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } ## the Jacobian, written in banded form bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } ## initial conditions and output times yini <- 1:5 times <- 1:20 ## stiff method, user-generated banded Jacobian out <- lsode(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) @ In FORTRAN, the code might look like this: \begin{verbatim} c Rate of change subroutine derivsband (neq, t, y, ydot,out,IP) integer neq, IP(*) DOUBLE PRECISION T, Y(5), YDOT(5), out(*) ydot(1) = 0.1*y(1) -0.2*y(2) ydot(2) = -0.3*y(1) +0.1*y(2) -0.2*y(3) ydot(3) = -0.3*y(2) +0.1*y(3) -0.2*y(4) ydot(4) = -0.3*y(3) +0.1*y(4) -0.2*y(5) ydot(5) = -0.3*y(4) +0.1*y(5) RETURN END c The banded jacobian subroutine jacband (neq, t, y, ml, mu, pd, nrowpd, RP, IP) INTEGER neq, ml, mu, nrowpd, ip(*) DOUBLE PRECISION T, Y(5), PD(nrowpd,5), rp(*) PD(:,:) = 0.D0 PD(1,1) = 0.D0 PD(1,2) = -.02D0 PD(1,3) = -.02D0 PD(1,4) = -.02D0 PD(1,5) = -.02D0 PD(2,:) = 0.1D0 PD(3,1) = -0.3D0 PD(3,2) = -0.3D0 PD(3,3) = -0.3D0 PD(3,4) = -0.3D0 PD(3,5) = 0.D0 RETURN END \end{verbatim} Assuming that this code is in file \code{"odeband.f"}, we compile from within R and load the shared library (assuming the working directory holds the source file) with: \begin{verbatim} system("R CMD SHLIB odeband.f") dyn.load(paste("odeband", .Platform$dynlib.ext, sep = "")) \end{verbatim} To solve this problem, we write in R \begin{verbatim} out2 <- lsode(yini, times, "derivsband", parms = 0, jactype = "bandusr", jacfunc = "jacband", bandup = 1, banddown = 1, dllname = "odeband") out2 <- radau(yini, times, "derivsband", parms = 0, jactype = "bandusr", jacfunc = "jacband", bandup = 1, banddown = 1, dllname = "odeband") \end{verbatim} This will work both for the \code{lsode} family as for \code{radau}. In the first case, when entering subroutine \code{jacband}, \code{nrowpd} will have the value $5$, in the second case, it will be equal to $4$. \section{Testing functions written in compiled code} Two utilities have been included to test the function implementation in compiled code: \begin{itemize} \item \code{DLLfunc} to test the implementation of the derivative function as used in ODEs. This function returns the derivative $\frac{dy}{dt}$ and the output variables. \item \code{DLLres} to test the implementation of the residual function as used in DAEs. This function returns the residual function $\frac{dy}{dt}-f(y,t)$ and the output variables. \end{itemize} These functions serve no other purpose than to test whether the compiled code returns what it should. \subsection{DLLfunc} We test whether the ccl4 model, which is part of \code{deSolve} package, returns the proper rates of changes. (Note: see \code{example(ccl4model)} for a more comprehensive implementation) <<>>= ## Parameter values and initial conditions Parms <- c(0.182, 4.0, 4.0, 0.08, 0.04, 0.74, 0.05, 0.15, 0.32, 16.17, 281.48, 13.3, 16.17, 5.487, 153.8, 0.04321671, 0.4027255, 1000, 0.02, 1.0, 3.8) yini <- c( AI=21, AAM=0, AT=0, AF=0, AL=0, CLT=0, AM=0 ) ## the rate of change DLLfunc(y = yini, dllname = "deSolve", func = "derivsccl4", initfunc = "initccl4", parms = Parms, times = 1, nout = 3, outnames = c("DOSE", "MASS", "CP") ) @ \subsection{DLLres} The deSolve package contains a FORTRAN implementation of the chemical model described above (section 4.1), where the production rate is included as a forcing function (see next section). Here we use \code{DLLres} to test it: <<>>= pars <- c(K = 1, ka = 1e6, r = 1) ## Initial conc; D is in equilibrium with A,B y <- c(A = 2, B = 3, D = 2*3/pars["K"]) ## Initial rate of change dy <- c(dA = 0, dB = 0, dD = 0) ## production increases with time prod <- matrix(nc=2,data=c(seq(0,100,by=10),seq(0.1,0.5,len=11))) DLLres(y=y,dy=dy,times=5,res="chemres", dllname="deSolve", initfunc="initparms", initforc="initforcs", parms=pars, forcings=prod, nout=2, outnames=c("CONC","Prod")) @ \section{Using forcing functions} Forcing functions in DLLs are implemented in a similar way as parameters. This means: \begin{itemize} \item They are initialised by means of an initialiser function. Its name should be passed to the solver via argument \code{initforc}. Similar as the parameter initialiser function, the function denoted by \code{initforc} has as its sole argument a pointer to the vector that contains the forcing funcion values in the compiled code. In case of \proglang{C} code, this will be a global vector; in case of \proglang{FORTRAN}, this will be a vector in a common block. The solver puts a pointer to this vector and updates the forcing functions in this memory area at each time step. Hence, within the compiled code, forcing functions can be assessed as if they are parameters (although, in contrast to the latter, their values will generally change). No need to update the values for the current time step; this has been done before entering the \code{derivs} function. \item The forcing function data series are passed to the integrator, via argument \code{forcings}; if there is only one forcing function data set, then a 2-columned matrix (time, value) will do; else the data should be passed as a list, containing (time, value) matrices with the individual forcing function data sets. Note that the data sets in this list should be \emph{in the same ordering} as the declaration of the forcings in the compiled code. \end{itemize} A number of options allow to finetune certain settings. They are in a list called \code{fcontrol} which can be supplied as argument when calling the solvers. The options are similar to the arguments from R function \code{approx}, howevers the default settings are often different. The following options can be specified: \begin{itemize} \item \code{method} specifies the interpolation method to be used. Choices are "linear" or "constant", the default is "linear", which means linear interpolation (same as \code{approx}) \item \code{rule}, an integer describing how interpolation is to take place \emph{outside} the interval [min(times), max(times)]. If \code{rule} is \code{1} then an error will be triggered and the calculation will stop if extrapolation is necessary. If it is \code{2}, the default, the value at the closest data extreme is used, a warning will be printed if \code{verbose} is TRUE. Note that the default differs from the \code{approx} default. \item \code{f}, for method=\code{"constant"} is a number between \code{0} and \code{1} inclusive, indicating a compromise between left- and right-continuous step functions. If \code{y0} and \code{y1} are the values to the left and right of the point then the value is \code{y0*(1-f)+y1*f} so that \code{f=0} is right-continuous and \code{f=1} is left-continuous. The default is to have \code{f=0}. For some data sets it may be more realistic to set \code{f=0.5}. \item \code{ties}, the handling of tied \code{times} values. Either a function with a single vector argument returning a single number result or the string "ordered". Note that the default is "ordered", hence the existence of ties will NOT be investigated; in practice this means that, if ties exist, the first value will be used; if the dataset is not ordered, then nonsense will be produced. Alternative values for \code{ties} are \code{mean}, \code{min} etc... which will average, or take the minimal value if multiple values exist at one time level. \end{itemize} The default settings of \code{fcontrol} are: \code{fcontrol=list(method="linear", rule = 2, f = 0, ties = "ordered")} Note that only ONE specification is allowed, even if there is more than one forcing function data set. (may/should change in the future). \subsection{A simple FORTRAN example} We implement the example from chapter 3 of the book \citep{Soetaert08} in FORTRAN. This model describes the oxygen consumption of a (marine) sediment in response to deposition of organic matter (the forcing function). One state variable, the organic matter content in the sediment is modeled; it changes as a function of the deposition \code{Flux} (forcing) and organic matter decay (first-order decay rate \code{k}). \[ \frac{dC}{dt}=Flux_t-k \cdot C \] with initial condition $C(t=0)=C_0$; the latter is estimated as the mean of the flux divided by the decay rate. The FORTRAN code looks like this: \begin{verbatim} c Initialiser for parameter common block subroutine scocpar(odeparms) external odeparms integer N double precision parms(2) common /myparms/parms N = 1 call odeparms(N, parms) return end c Initialiser for forcing common block subroutine scocforc(odeforcs) external odeforcs integer N double precision forcs(1) common /myforcs/forcs N = 1 call odeforcs(N, forcs) return end c Rate of change and output variables subroutine scocder (neq, t, y, ydot,out,IP) integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*), k, depo common /myparms/k common /myforcs/depo if(IP(1) < 2) call rexit("nout should be at least 2") ydot(1) = -k*y(1) + depo out(1)= k*y(1) out(2)= depo return end \end{verbatim} Here the subroutine \code{scocpar} is business as usual; it initialises the parameter common block (there is only one parameter). Subroutine \code{odeforcs} does the same for the forcing function, which is also positioned in a common block, called \code{myforcs}. This common block is made available in the derivative subroutine (here called \code{scocder}), where the forcing function is named \code{depo}. At each time step, the integrator updates the value of this forcing function to the correct time point. In this way, the forcing functions can be used as if they are (time-varying) parameters. All that's left to do is to pass the forcing function data set and the name of the forcing function initialiser routine. This is how to do it in R. First the data are inputted: <<>>= Flux <- matrix(ncol=2,byrow=TRUE,data=c( 1, 0.654, 11, 0.167, 21, 0.060, 41, 0.070, 73,0.277, 83,0.186, 93,0.140,103, 0.255, 113, 0.231,123, 0.309,133,1.127,143,1.923, 153,1.091,163,1.001, 173, 1.691,183, 1.404,194,1.226,204,0.767, 214, 0.893,224,0.737, 234,0.772,244, 0.726,254,0.624,264,0.439, 274,0.168,284 ,0.280, 294,0.202,304, 0.193,315,0.286,325,0.599, 335, 1.889,345, 0.996,355,0.681,365,1.135)) head(Flux) @ and the parameter given a value (there is only one) <<>>= parms <- 0.01 @ The initial condition \code{Yini} is estimated as the annual mean of the Flux and divided by the decay rate (parameter). <<>>= meanDepo <- mean(approx(Flux[,1],Flux[,2], xout=seq(1,365,by=1))$y) Yini <- c(y=meanDepo/parms) @ After defining the output times, the model is run, using integration routine \code{ode}. The \emph{name} of the derivate function \code{"scocder"}, of the dll \code{"deSolve"}\footnote{this example is made part of the deSolve package, hence the name of the dll is "deSolve"} and of the initialiser function \code{"scocpar"} are passed, as in previous examples. In addition, the forcing function data set is also passed (\code{forcings=Flux}) as is the name of the forcing initialisation function (\code{initforc="scocforc"}). <<>>= times <- 1:365 out <- ode(y=Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc="scocforc", forcings=Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation","Depo")) head(out) @ Now, the way the forcing functions are interpolated are changed: Rather than linear interpolation, constant (block, step) interpolation is used. <<>>= fcontrol <- list(method="constant") out2 <- ode(y=Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc="scocforc", forcings=Flux, fcontrol=fcontrol, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation","Depo")) @ Finally, the results are plotted: <>= par (mfrow=c(1,2)) plot(out, which = "Depo", col="red", xlab="days", ylab="mmol C/m2/ d", main="method='linear'") lines(out[,"time"], out[,"Mineralisation"], lwd=2, col="blue") legend("topleft",lwd=1:2,col=c("red","blue"), c("Flux","Mineralisation")) plot(out, which = "Depo", col="red", xlab="days", ylab="mmol C/m2/ d", main="method='constant'") lines(out2[,"time"], out2[,"Mineralisation"], lwd=2, col="blue") @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the SCOC model, implemented in compiled code, and including a forcing function - see text for R-code} \label{fig:scoc} \end{figure} \subsection{An example in C} Consider the following R-code which implements a resource-producer-consumer Lotka-Volterra type of model in R (it is a modified version of the example of function \code{ode}): <<>>= SPCmod <- function(t, x, parms, input) { with(as.list(c(parms, x)), { import <- input(t) dS <- import - b*S*P + g*C # substrate dP <- c*S*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dS, dP, dC) list(res, signal = import) }) } ## The parameters parms <- c(b = 0.1, c = 0.1, d = 0.1, e = 0.1, f = 0.1, g = 0.0) ## vector of timesteps times <- seq(0, 100, by=0.1) ## external signal with several rectangle impulses signal <- as.data.frame(list(times = times, import = rep(0, length(times)))) signal$import <- ifelse((trunc(signal$times) %% 2 == 0), 0, 1) sigimp <- approxfun(signal$times, signal$import, rule = 2) ## Start values for steady state xstart <- c(S = 1, P = 1, C = 1) ## Solve model print (system.time( out <- ode(y = xstart,times = times, func = SPCmod, parms, input = sigimp) )) @ All output is printed at once: <>= plot(out) @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the Lotka-Volterra resource (S)-producer (P) - consumer (C) model with time-variable input (signal) - see text for R-code} \label{fig:lv} \end{figure} The C-code, in file \url{Forcing\_lv.c}, can be found in the packages \url{/doc/examples/dynload} subdirectory\footnote{this can be opened by typing \code{browseURL(paste(system.file(package = "deSolve"), "/doc/examples/dynload", sep = ""))}}. It can be compiled, from within R by \begin{verbatim} system("R CMD SHLIB Forcing_lv.c") \end{verbatim} After defining the parameter and forcing vectors, and giving them comprehensible names, the parameter and forcing initialiser functions are defined (\code{parmsc} and \code{forcc} respectively). Next is the derivative function, \code{derivsc}. \begin{verbatim} #include static double parms[6]; static double forc[1]; /* A trick to keep up with the parameters and forcings */ #define b parms[0] #define c parms[1] #define d parms[2] #define e parms[3] #define f parms[4] #define g parms[5] #define import forc[0] /* initializers: */ void odec(void (* odeparms)(int *, double *)) { int N=6; odeparms(&N, parms); } void forcc(void (* odeforcs)(int *, double *)) { int N=1; odeforcs(&N, forc); } /* derivative function */ void derivsc(int *neq, double *t, double *y, double *ydot, double *yout, int*ip) { if (ip[0] <2) error("nout should be at least 2"); ydot[0] = import - b*y[0]*y[1] + g*y[2]; ydot[1] = c*y[0]*y[1] - d*y[2]*y[1]; ydot[2] = e*y[1]*y[2] - f*y[2]; yout[0] = y[0] + y[1] + y[2]; yout[1] = import; } \end{verbatim} After defining the forcing function time series, which is to be interpolated by the integration routine, and loading the DLL, the model is run: \begin{verbatim} Sigimp <- approx(signal$times, signal$import, xout=ftime,rule = 2)$y forcings <- cbind(ftime,Sigimp) dyn.load("Forcing_lv.dll") out <- ode(y=xstart, times, func = "derivsc", parms = parms, dllname = "Forcing_lv",initforc = "forcc", forcings=forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum","signal"), method = rkMethod("rk34f")) dyn.unload("Forcing_lv.dll") \end{verbatim} This code executes about 30 times faster than the \proglang{R}-code. With a longer simulation time, the difference becomes more pronounced, e.g. with times till 800 days, the DLL code executes 200 times faster% \footnote{this is due to the sequential update of the forcing functions by the solvers, compared to the bisectioning approach used by approxfun}. \section{Implementing events in compiled code} An \code{event} occurs when the value of a state variable is suddenly changed, e.g. a certain amount is added, or part is removed. The integration routines cannot deal easily with such state variable changes. Typically these events occur only at specific times. In \code{deSolve}, events can be imposed by means of an input file that specifies at which time a certain state variable is altered, or via an event function. Both types of events combine with compiled code. Take the previous example, the Lotka-Volterra SPC model. Suppose that every 10 days, half of the consumer is removed. We first implement these events as a \code{data.frame} <<>>= eventdata <- data.frame(var=rep("C",10),time=seq(10,100,10),value=rep(0.5,10), method=rep("multiply",10)) eventdata @ This model is solved, and plotted as: \begin{verbatim} dyn.load("Forcing_lv.dll") out2 <- ode(y = y, times, func = "derivsc", parms = parms, dllname = "Forcing_lv", initforc="forcc", forcings = forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum", "signal"), events=list(data=eventdata)) dyn.unload("Forcing_lv.dll") plot(out2, which = c("S","P","C"), type = "l") \end{verbatim} The event can also be implemented in \proglang{C} as: \begin{verbatim} void event(int *n, double *t, double *y) { y[2] = y[2]*0.5; } \end{verbatim} Here n is the length of the state variable vector \code{y}. and is then solved as: \begin{verbatim} dyn.load("Forcing_lv.dll") out3 <- ode(y = y, times, func = "derivsc", parms = parms, dllname = "Forcing_lv", initforc="forcc", forcings = forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum", "signal"), events = list(func="event",time=seq(10,90,10))) dyn.unload("Forcing_lv.dll") \end{verbatim} \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} \includegraphics{comp-event} \end{center} \caption{Solution of the Lotka-Volterra resource (S)~-- producer (P)~-- consumer (C) model with time-variable input (signal) and with half of the consumer removed every 10 days - see text for R-code} \label{fig:lv2} \end{figure} \section{Delay differential equations} It is now also very simple to implement delay differential equations in compiled code and solve them with \code{dede}. In order to do so, you need to get access to the R-functions \code{lagvalue} and \code{lagderiv} that will give you the past value of the state variable or its derivative respectively. \subsection{Delays implemented in Fortran} If you use \proglang{Fortran}, then the easiest way is to link your code with a file called \code{dedeUtils.c} that you will find in the packages subdirectory \code{inst/doc/dynload-dede}. This file contains Fortran-callable interfaces to the delay-differential utility functions from package \pkg{deSolve}, and that are written in \proglang{C}. Its content is: \begin{verbatim} void F77_SUB(lagvalue)(double *T, int *nr, int *N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagvalue"); fun(*T, nr, *N, ytau); return; } void F77_SUB(lagderiv)(double *T, int *nr, int *N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagderiv"); fun(*T, nr, *N, ytau); return; } \end{verbatim} Here \code{T} is the time at which the value needs to be retrieved, \code{nr} is an integer that defines the number of the state variable or its derivative whose delay we want, \code{N} is the total number of state variabes and \code{ytau} will have the result. We start with an example, a Lotka-Volterra system with delay, that we will implement in \proglang{Fortran} (you will find this example in the package directory \code{inst/doc/dynload-dede}, in file \code{dede_lvF.f} The R-code would be: <<>>= derivs <- function(t, y, parms) { with(as.list(c(y, parms)), { if (t < tau) ytau <- c(1, 1) else ytau <- lagvalue(t - tau, c(1, 2)) dN <- f * N - g * N * P dP <- e * g * ytau[1] * ytau[2] - m * P list(c(dN, dP), tau=ytau[1], tau=ytau[2]) }) } yinit <- c(N = 1, P = 1) times <- seq(0, 500) parms <- c(f = 0.1, g = 0.2, e = 0.1, m = 0.1, tau = .2) yout <- dede(y = yinit, times = times, func = derivs, parms = parms) head(yout) @ In Fortran the code looks like this: \begin{verbatim} ! file dede_lfF.f ! Initializer for parameter common block subroutine initmod(odeparms) external odeparms double precision parms(5) common /myparms/parms call odeparms(5, parms) return end ! Derivatives and one output variable subroutine derivs(neq, t, y, ydot, yout, ip) integer neq, ip(*) double precision t, y(neq), ydot(neq), yout(*) double precision N, P, ytau(2), tlag integer nr(2) double precision f, g, e, m, tau common /myparms/f, g, e, m, tau if (ip(1) < 2) call rexit("nout should be at least 2") N = y(1) P = y(2) nr(1) = 0 nr(2) = 1 ytau(1) = 1.0 ytau(2) = 1.0 tlag = t - tau if (tlag .GT. 0.0) call lagvalue(tlag, nr, 2, ytau) ydot(1) = f * N - g * N * P ydot(2) = e * g * ytau(1) * ytau(2) - m * P yout(1) = ytau(1) yout(2) = ytau(2) return end \end{verbatim} During compilation, we need to also compile the file \code{dedeUtils.c}. Assuming that the above \proglang{Fortran} code is in file \code{dede_lvF.f}, which is found in the working directory that also contains file \code{dedeUtils.c}, the problem is compiled and run as: \begin{verbatim} system("R CMD SHLIB dede_lvF.f dedeUtils.c") dyn.load(paste("dede_lvF", .Platform$dynlib.ext, sep="")) yout3 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dede_lvF", initfunc = "initmod", nout = 2) \end{verbatim} \subsection{Delays implemented in C} We now give the same example in \proglang{C}-code (you will find this in directory \code{inst/doc/dynload-dede/dede_lv.c}). \begin{verbatim} #include #include #include #include static double parms[5]; #define f parms[0] #define g parms[1] #define e parms[2] #define m parms[3] #define tau parms[4] /* Interface to dede utility functions in package deSolve */ void lagvalue(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagvalue"); return fun(T, nr, N, ytau); } void lagderiv(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagderiv"); return fun(T, nr, N, ytau); } /* Initializer */ void initmod(void (* odeparms)(int *, double *)) { int N = 5; odeparms(&N, parms); } /* Derivatives */ void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] < 2) error("nout should be at least 1"); double N = y[0]; double P = y[1]; int Nout = 2; // number of returned lags ( <= n_eq !!) int nr[2] = {0, 1}; // which lags are needed? // numbering starts from zero ! double ytau[2] = {1.0, 1.0}; // array; initialize with default values ! double T = *t - tau; if (*t > tau) { lagvalue(T, nr, Nout, ytau); } ydot[0] = f * N - g * N * P; ydot[1] = e * g * ytau[0] * ytau[1] - m * P; yout[0] = ytau[0]; yout[1] = ytau[1]; } \end{verbatim} Assuming this code is in a file called \code{dede_lv.c}, which is in the working directory, this file is then compiled and run as: \begin{verbatim} system("R CMD SHLIB dede_lv.c") dyn.load(paste("dede_lv", .Platform$dynlib.ext, sep="")) yout2 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dede_lv", initfunc = "initmod", nout = 2) dyn.unload(paste("dede_lv", .Platform$dynlib.ext, sep="")) \end{verbatim} \section{Difference equations in compiled code} There is one special-purpose solver, triggered with \code{method = "iteration"} which can be used in cases where the new values of the state variables are estimated by the user, and need not be found by integration. This is for instance useful when the model consists of difference equations, or for 1-D models when transport is implemented by an implicit or a semi-implicit method. An example of a discrete time model, represented by a difference equation is given in the help file of solver \code{ode}. It consists of the host-parasitoid model described as from \citet[p283]{Soetaert08}. We first give the R-code, and how it is solved: \begin{verbatim} Parasite <- function (t, y, ks) { P <- y[1] H <- y[2] f <- A * P / (ks +H) Pnew <- H* (1-exp(-f)) Hnew <- H * exp(rH*(1.-H) - f) list (c(Pnew, Hnew)) } rH <- 2.82 # rate of increase A <- 100 # attack rate ks <- 15. # half-saturation density out <- ode (func = Parasite, y = c(P = 0.5, H = 0.5), times = 0:50, parms = ks, method = "iteration") \end{verbatim} Note that the function returns the updated value of the state variables rather than the rate of change (derivative). The method ``iteration'' does not perform any integration. The implementation in \proglang{FORTRAN} consists of an initialisation function to pass the parameter values (\code{initparms}) and the "update" function that returns the new values of the state variables (\code{parasite}): \begin{verbatim} subroutine initparms(odeparms) external odeparms double precision parms(3) common /myparms/parms call odeparms(3, parms) return end subroutine parasite (neq, t, y, ynew, out, iout) integer neq, iout(*) double precision t, y(neq), ynew(neq), out(*), rH, A, ks common /myparms/ rH, A, ks double precision P, H, f P = y(1) H = y(2) f = A * P / (ks + H) ynew(1) = H * (1.d0 - exp(-f)) ynew(2) = H * exp (rH * (1.d0 - H) - f) return end \end{verbatim} The model is compiled, loaded and executed in R as: \begin{verbatim} system("R CMD SHLIB difference.f") dyn.load(paste("difference", .Platform$dynlib.ext, sep = "")) require(deSolve) rH <- 2.82 # rate of increase A <- 100 # attack rate ks <- 15. # half-saturation density parms <- c(rH = rH, A = A, ks = ks) out <- ode (func = "parasite", y = c(P = 0.5, H = 0.5), times = 0:50, initfunc = "initparms", dllname = "difference", parms = parms, method = "iteration") \end{verbatim} \section{Final remark} Detailed information about communication between \proglang{C}, \proglang{FORTRAN} and \proglang{R} can be found in \citet{Rexts2009}. Notwithstanding the speed gain when using compiled code, one should not carelessly decide to always resort to this type of modelling. Because the code needs to be formally compiled and linked to \proglang{R} much of the elegance when using pure \proglang{R} models is lost. Moreover, mistakes are easily made and paid harder in compiled code: often a programming error will terminate \proglang{R}. In addition, these errors may not be simple to trace. \clearpage %% this adds References to the PDF-Index without adding an obsolete section \phantomsection \addcontentsline{toc}{section}{References} \bibliography{integration} \end{document} deSolve/inst/doc/deSolve.pdf0000644000176000001440000254411413576731651015552 0ustar ripleyusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 4927 /Filter /FlateDecode /N 90 /First 760 >> stream x\[w6~?oNH\ kN8vܦv]XF]N>~ /C;j;KI\oJƙbefY %8sL,g9T Z &rIQ oj&3L&@:eJ옲 s9%gZITLNq H)fܲ,7h1+(?g639ë%4(ɜJ\h4YU9{@L2 .-$Xs \4s$)0 xpx]Re Q1FHAP4ɕs3#!G 9:Oxh69rXbY[4dG6#RA΁01& F$/!~,82@sT ` g ȜGrl! 4McQjK%:A d8')?4:e 9d&stܑ 0\B$sZ0/d:',ЂcgXB| _,GYuփػ/{t7IŢ';&KfSd'uUMGvb-I]VI]H|%.^hQ;&/%Y,s?-~X-K`Zb^+~Зd(-l[NdvQ[LʳvnPKa2)z7+ rQMo wղ^-PݯYgrr,b⤚}(at+I'A @pܯn5i_!%$;?af}>M8=IOӟ$}gլ$E9P"L\LMߧ*sTiV")i[MU㙠-e,>e)rQiJoS{G`ߵA Ww^|˗ XO_~X з1q|rU lo~7;*K(^O.~--oL /^b7_댵i3Tpq 1?m*[ʙOʜZՂ ǔul@P8I:h9œ=h sH0ko~hXIP\q_nR+=iIA|+=BlM졆 Ep4vri+MN1}ˈ@HK0-{i%&ym#chm|r`"`y*En(OՀ}>;ـoND{H=s5n#S^\cDIi*.*Y)o% eQ1@e 6 QEKeKЀJߪC0"M+7"ݠژd(4w*w2M$唯r፡'O#4Nۤ7?; 7oӟ^+|B0~/C-&g uF0-/ʑ(2bvǂx+ "2-/jhӽ?{G1tl?5dΙ c:L9QDz,7^ ,w8=Jɉj0څrc GONO铮!kb&8 oDg4:y0 O(iiz-|M+2]Yi#;Z+I`{ߧ\y<&KWL4w†i&@\r›!~Mpinsh6Op'g7oFq|!&_[POP6Z^<>:x tQɡA9zЬf1Fto3ݍdh㛢G>(p] 7Mr#D(̆萏C,^ی61w9}jg?\5DF0,i 3"j@ p=V`d dsjmwDh&WVC)̫^K-п8lQYsEb 3rW༸w*)ŴcL-ƔzCTS=V=V'G% ycJMÅ-;_Hf6+-*@4mv DJh'퓽/Bd]D4=tX'|ƨfa?H:gef4m?jKp5딊ox`՝-z]ua(񲷨֏Q*1燐7p|)',z;)mruׇ?9Z@X?_XwbB_Of:;u)lY5ؚmj",UX-UѫjŴf# Uջb,/>?ET,%;-̧hZɼy3<gnr1sEnq4zאx] D0$c:4ɡq9%rڈ4[W I*a8S$SLDj4!\1ټo$^?;엙$X_kxOq\7a{5yu9餾fj6,vaݾd@oQtL(5j!L4bmi:5[0YH40\c28yvzzX;n_Yه.&6p>fvf,hЬܸ#DȭJ\$ p(2NJ,Ky`HYB*WI89IкX2tDJs ): %37DJDe9x8YجE,>=/?. iJPB1/~9rU/#`,i"'uD>9VB_Y&Ix%jNyZ=-Ӽz=[oo Cvt\$.i# }7"L"w+=g]K)0ڶHʑendstream endobj 92 0 obj << /Subtype /XML /Type /Metadata /Length 1815 >> stream GPL Ghostscript 9.16 differential equations, ordinary differential equations, differential algebraic equations, partial differential equations, initial value problems, R 2019-12-19T18:30:15+01:00 2019-12-19T18:30:15+01:00 LaTeX with hyperref Package deSolve: Solving Initial Value Differential Equations in RKarline Soetaert, Thomas Petzoldt, R. Woodrow Setzer endstream endobj 93 0 obj << /Type /ObjStm /Length 3712 /Filter /FlateDecode /N 90 /First 821 >> stream x[r6}߯nm-KVJ/%loMAkvf(= r=GlAFфU RNUV|\e+OTBTRDUP$Pc TI- 㗰UJz+5^RKx]J(u6sui*m%VpU ȐG!T((tdeD)H Uh<*Cr le */h ox%ZmX NbHue=öpcƶrЗvSP{F4%IPkG/16WKr-z$S9&I${FH ExaPyI@2W:FUy.*+T  m4̽`ԣT,1 )|K˖`؜,cX•vlBM"~f,HdY%@R NruF۪Q1UcB4=jxfqI1qK̓/|S5b^VKT'Ŷ4^xՍW?^p:ӣ<={S5fEWwgKM0y+k^$I_:hF tS>춢&U9sy9_3pەk65iԤyl&7yi7}?i6N4gy3mf#i Y\4fѼo>47{nE lڳj,ա?\?wnRfI-9Pb"o3ٶRwI)䚁Bay=sNJXp~wLM4n0e褤fFqhAyd^݅8'Gps)sbn,26Klq{54BPˍ486GA\`6@!P;Dʠ4v5sjΫMv7wq8@uNy `'cPpW}V4Z / m 9Y>&zN L6:ȕ+2ƞ \طqjDZ^P11<; f=U[]ׯ0q,ŝax+>`"A!Qy_G5(/0LPLߝȹgOVl6护**\;8֏MWBv.TmӤB}P=̐ئKs}ڟW ,?yv~ڰ5nW\Oͻy`[\Ccءxj?Sx^ʕ *8p}Vr}VIi[ޅr&y\MT;ݢ᳀~ >cƳ=fl ## VͧWc/>.w6yIǃǪ &؅c {`D6;(tVjo}J] eL=c,eƖF 3`v6x.\Nܖ ܀SW=OW6np.ݐt1&)<_)conA}If59w/m9x:w="ՐuwKɢFf[~%!d/L}OUDJol6.;zH&oM6 >IFF*5ccOY %焚 1bZ%S5hm>H)YoO e 1w>b- =btdq T:Fש2:AI(E{cOeg`u}R/}j],kLkیh)(ZJj "gٮBQ6)[o2^b[G]q^ fa$,ƶok,j 6 0ZcYHr&J$v[%eKbgR^|ק.,؁/ b&B mHcSj>Qyac+'E+DvRA)`"Ih[{-yVo (:׌z o-&YSBoO$q!giz2%$&C-xƩH)xLl" oA5[f.%hـ= vPr |,e2s/aEԗ ~e[84l)Izr´#0s[GM,,Į /sUu%%u9%h `97 J ]B" xIމvЪa v[be (V|=<,\A?~6CV ROBإVHr/f'pHE5dYJdZ?fPendstream endobj 184 0 obj << /Type /ObjStm /Length 2616 /Filter /FlateDecode /N 90 /First 805 >> stream xZmo_/{|ΐE`@r ZG2K>ҝuOk0%w3<$gcd#O6[k#ibGMfvN6 zZ]z'LIۨ=D'3Iۤ9 P#f P?à] Mnamc ' h䉵@g c61*ᤳ,X r^g'2ưNF'?S&B7 H1sK ě: vp(X@!Lg6)v$409Kvb w9`ՑG1bbt,L#p fB,r h (DI!`],;<AkvI qF!(tHRZO ƂaUJ]2NDAsBAAA%vƀ@'QY; i|2m>5"0cΦ_{;ϟ^C] 3Hdg̚W &i}֯/zRk~l}Q }uuY-lozŴ{GPEW?tT_fͺ]l;bbao_\\w˪uQi]wznéEo.n-[p>=p˪@W]l> ۺ{ ؘNUW8̢bo*Oڭ)Y&ϵYKK#C4sQs/3am]p?;L˜`gM r *+PIfm$͂5PxN`cY䌌 頝5; ْ/C,y@ɱW4U4I7Ä}3Mi_}3xaw5j8v3p"حg^۰{cn5;l|7RyWF͵`YOV?wM찯 :crzGg8a9x?eonh縖i8)| CKƑ3:biDMӴ};{ְ9;%&qm~1_P2|~Q/jG~)Rh'ڝn|XC!OnS /5)/5?NOޜ)D{'B]ׁ,:dze)| |YMNMl9Zh's,u_~A$>aj:CHճKH^y'>oVB_0xzd`E/{S/?]&'&gMSfojdȸزmR5n}懩dD%Rs l l`zb!1H=l&M='mbػ q%qěHj-x$]j>|}8~֪IQP0J>7ώ{9uD-[ =KhpKq;RHFck8#pGF$=2rъaXFuhFF)0:a*#쁭&#̙M'12 S& xpqDpFd|1[Ƃyg3N`3'8Jaz!!O*8n> stream xZks_ߒN*ޝdj[V4J<D$4$jr"㑹x=. a)218~=Z3R/gK fd *9]׌sa\X8Lϸ|ʸŌs4K x@ҘjZN<1?eLSAL9BA L*QH&ItfLq]“0S<))0+!0€"t34Q.$ЩKi.f4b`VqǴ6:>@J)EpW'Ώځ`su(cC~ ́<;FvO-Q<5a5-~ +[8p#"rԋnӁm:Pysth"a?;LE.&8=4W7w |iɋ/C&JH_dԷz:W|8'C 2tBEq^GR55sq-ǡ{a-?g3YIE4ipa4D\~v$A1#fgu"QbZA-AO'`:fRȈ¡Bb U.b$/MJ񆋂:Lv{~\.\Fi1(=u^,uc9A 5ch_+烰WE>p %zR,,dI$~Z[XA;,:zWa6U37m>tpn%}T|а ,RJEzɪqJf4Uج_itE*zz}SG#/i 7҂ڌ@8eo  YbB$`(,>aqYIh>(cJ-(oNBJ,l0dO2b4s{(",,hG#O LBbiB$&Q(OBizOB pG jU( GUIxvҺĺJ<(!a!,(d!(mzrۅ*wfSR3n("5gUBo[7Ǻgܳ`Gboa0Fh 0"yxS|PB{Ӂrd8*D99Ï%OѫL^/ElkCHzu AOzZ,bwI-FY}OZi 鮦&#]&_C~wbZ"_Nn`oyvW1J /d\+eߝ>.E>=kv=f-}_p2i`Ct@Qi6Mv*ynw?4ʮ'5m_vPf;^qŷ?~]^bY[_h5 ?uԞoF͛5 9 ?p,דl&I1YMvuri%^_]-!ڵ/<疁)}4M/UvCO(({8Vg).q-Փjiz> stream x\IwǑC2B9E7ΐek(䱥94 @g;j8OY|dF^QW|q)N_W8qhw_UzLU4z..~]Viج՘rN: T)W`Fը~?2fr6џp,v ! G' &ixF n؞:~m"m tU-zfCVf}̘lSguΉj\=Nam4 h~zGMb[Zg/ك 4:[#"O lakܤK̴ p> _H2,,M򢍸de˄L /)rUф: ^>3MD5h;G+.Xkniְkc^V!\YYwڪ$6A5y|h,Й1?#mWvvgCZ8M/Inڡ+v]g-$9v\SZ01Wz"8o[0x6aM˚1< $;zR 3+e2mQ1s;YjeD\*: d3¸2oO>e 'K%Fb]7\\YniO/ ":^al'1Z0B2 BFM_2t3ykdNADFaCa3{0?7ZyHNpҮ; A E10Rj.J4R@^3ċETy = F9g+s^) IC+\.:?)H UK 697& x+5:d32C\ITz%;QВqdRHi'"`%]dM%7].,X,.kw$Ig@/Lq6torX6ߛf$[ɶԩۄ3A)Pr N⦉Y/Y]OkӤWkq%'SKT%CtE^@?$Eyh}'liz[p:w:%g4#p5W{˴qH -UN9rib&7!jq^jSJfZvBz`,t~ցjJ""?<ƍwI û.Kjm8sr >lǶ8N̂1줲tq@(l7KD ֌矻jiXsI,) 4iOfoDZ жԗEu2McDt!趹;[T4'ls|dv+Y᫉< u#*#,r`/_HdŠvTJ\.J y/AĆ9R$*PwJ/`+3'[.ܧ=/bxἵ:YX8ӝ]2[N+==߃_if "Bzo7\5DQQQ4tRYRpngck|5ae*cծMFK\6NV>}Ng{Մu5>Յ-@ն+/VS;,3lTv-Jll1:8WhKz;tM#,Sf/ot*Q)7Y;%Ryy:(仞c2ɣ [L5|XNy%uw3k*T4voIr7IƧ9Yż{uFP (߶SL _7E;(֤Qtja]PhK9`)δy {l{l?Ul)[1)gsz7g]l\ S>įmF _w L> %DqMKy`}u vV=2 'ȍ} M@lC૴lc5}(A3[}`N twPt2TguM> 0JJ^{zJ#\,_- 5'gUhJSr]LjӅԩr+;=J}CM5F;/'ZJک d-\m3)rZb*r)GMGnaxSwyX,v֔ cMnFZJtL@+Km!zorMoUu.SVvq*mS{.-{*siIf-/hQ֙ϒuCg"}<{~)REd] ;עmidD1Q/2zs_\%BRSats(tntnу:kA;5>!bu.Usj1?dE (wOco;!AAJE;V^o^ wzSUqDt*s  IgWZ#NxM*RxuV ⡦}mk;1g;/ p vv|DM>*%`+屰cW7dw9@tK]أ Ʌo-YDtmYwz3j!H9UmPR0IsR #,lOb%:!W Ak DPHtLrC]3+ˀ:Ivp䓗>Se1pd6Rw Du5eҥǺϕ 5A<dῃҩbmq{Fwx˅lxZk땠 Eq57|ʃ+b9=da$ESV|ઔHF; Ksz[A肎=}b"#fVX26oP 8o6OMtFu@t=$k6wl:_rsuHrW l8l- τ]y;f/B^ڣ/aKi/R3W[[KNupf7U;&O|+g .؂<]TitMQ9ѡ)%ǀX1U춻)e6CI>pj\\vZCPnuaT| Rt{|WĶssoL%}MpEmg ґ]AЦ}o}T @#/,JԌOp预DH}l{iX/ .j#g~ȦK`+zߒ3csY%Yi1IܔwI8 ێe߯^2BCӛ}4س&ט%YģZ]1üCݚ-}nfAԩk1/b endstream endobj 365 0 obj << /Filter /FlateDecode /Length 3315 >> stream xZr M^7}_\Q\Vr*ryX^D)!Hɕ|A>;z=].T%h4pZtr-߳Փ/oWb}zuX5颈r}z~*A]v}rjT{wX+E䋝|y*|=klPGkmv݈NhQ\sJ[щeC?1qٵD5Ww#jIit‹oXl7.3]nJtk [}n֠Sh!8;| kݸP] Akz ℔ÏH~`X!Z$YsM=‚j[$L+՞F(ټphI3ޑBVShǭq` :R *n{QL38ZQ2tbs MB5?xbΠg'Vn3VʈGYM'zW5Rf/@]bJw tQ:0kpW0:==`);+mFvje˗K˳mg9tG>aX!qXz1e8Fm+&?ֲ7@d$hX2RCD>E7 ͂qx$ Sʥ1Bޙ;XX6 SSά.Ss~u~ˮR.S{@wt}F҂b ,,/iHlF ۹`?P/3q!/LeK d, E>q{eAU JGm7 t ULB{ tv5҄M6&xE`;[V2"WĈD"o ȜDh=!8kqNxI<,owS-_2*"A1eF`jQ>eS)vֹϿ푩s߶STPXo@/(|@@g#u'$9 'gb4.]PeCu2&s OCi3뚿f⟕% @T3PB1 \Mv88y΢NxLw.᪥6dQIPjYo `2Ѥ7gt!$ɉ T r} x -v c|^-f%cj?t(_d6 pG҄`4Dz!eh89R2G˵]Y|UЛN1Q2"r$qRZa!S mgj sے$|VpP$hs%j{E UXaS>rs="Z\IaʃnĈi6:\)^VNTZ^Bnp0bؙVgH..W:/%#-sy_>CF_ j[0Vi Vp3$oNL8J z!Yܞ2-=/I2GnM_D 4J?jRS ;v_(% ([jفZ!OԪ<SJnPoM JVenPCͮv\O/PĿ2K 6ymnM{UAEUy.DԒtcɀ+.v`mSˋrM(g3ue7hL_6O\Ck:ҟwCw戮G2Jh4IGp,qBF<aqFO-M.b3תgL|yJWv@+9aS7C}&ѳ/xRpk:dJ}iyK3}ntD`:@gӲ dDSWl4P^2KjTJi[M1ҵ28,KnUף<5s/IswXՁCh^mD dk kĀUkr5 Ʉ.~뛋{ ON;O2!w$13hKyyu%x*1L.+\;TtVͯRDmE4`;~;p6J)R-$XzFQ\ZŞi",?KN}|9oN$jl>Hؕr6_9ymyeْv> stream xnd9=GD[3$@b lHSIz;goVa@Ў>>jO_=1NM.ޞVh`jTҧ'>!'_])$7l`h3Iw3SL~Y=h{:=1W3k-?l0> ՙJ ڦh}aJX3l`c tR. nx;8|qNIÁo`&!oqڤc6;^n2 Qx88ǔiz ۻrK\QVìv Bagc^^[ 径茁d _1 rx)9aaH8퓕h=d {-ל9OϬ_pٗVgصR㰃cy%P* :WgaI=uCQWu]bwv]2;9Y0q=FTePWux__wy:kd"F5 Qo +K=7 ʙ`c7"[nZa:D ^kOH3HMr]+^[1:<xVz0 Ç֒l^#2 J\ cs ~&xp˔",?2C'G$9nW`N{TlT2N9u{#=KGZ7G-4e:7 pO}Ҍ~lc0ƾin3ONV'S( ?kZc nDʽ,*cU>dDk,ƣǛϮyRIԢ}&Jd8BNNџRC]kE0`Jd\VH UTr3Q"1S5HNi#p19'`̆9IL>)-lqr6.qjK fnyQh3YԵLt0 &5UC%>/d1 +#4 (aviOU+ [}$p={IwMtZzh3~I\*JR^WXZ3FD -ΝYP &2/-xE x IdfB.4On[iΡA pmmL8ΒΎT&L&Ku@6%g@u ڏ5ן4p{";C5$As9Uop"YJ%=14 5ʮ75&.W3$7SEau\R#)ouY#plk3#x>M^1FrPs0KĜ }(n>PAȷ g8Jhej)Am$ml /Nyg>M{z߰g۩t-Q*FI,2Bk9R-k]H ivxj ?s`(0N*G̿3Ҽ4W(~L/O G endstream endobj 367 0 obj << /Filter /FlateDecode /Length 3025 >> stream xZKs+#X{II6TUIack^h %"%L7(PTAF|A+Gx|s$fGduV,/g=QE㳣T΂y뇨3/0W';;Doaћ^HŲWnAu~.?sJNz1emKAֽLQ 7Bh^AJ*)lXύC `{խWpE:5{bd aFNjm?ƹ-VB A_}PC ZQ`'70H~ Ss0yH-JLDbtgf"H]<`G '6I0Vum 0Mfh&*⨶M^\g Cp./xicLGhgBL'Lt̚Tʨ2?w8A񕯌&LV8` B^yJoPt}?y3ˁ@nii4 [q! XVy;KZ)a'5 [[+ZE)͈B7Mq)B4+DҩwkXd[')yMG:y:؜]# w| 0(1p]?U_(pYV^+AHp䄉,֑dbò qiB%$QdƀȗD\y˗`@ 4)e,B̘(DRyyNQJJ!=1+aElJ0/mYdH) $햀ɺTOKns\&V7IݣDYԍ@*_#\Ǘ *9i1P9U ) ]V.Ca9 QS@g5&UNUÕڎ[5|efzߥJcJ-~}L[3cI'oa$%Q8vE[2vNώ8:/x835eȤVȗD" t皌1tZ'4:}BD_hwDnv-S|6reB}Oe3 ohwВFo"rpܘ1)]4]R7`I[8 "h2C;c{J9zEbquCIw^2#c¬ʼwnRx0v௄u>ȴ[$ψ|K>#hHi<<-ǒAK_#\=ryhn$2iH3HG?yClCK}ɠ=Zy8膟E2 !e ͓_#6eҲ oTM8o3}2qH3ږ9p Ш#UiHe ݓCa|piՄ7H& ѱg^֪TSޏ1RR_WͰbO LԐmnV=0|{=2ڥPql" v"gRiRX~B/`b*/ ѕ-oͲwi*m˺P5M+S]Lk^ད<0Er I(20L‰u,Ta|va&J1M(U;գ q^rLJ{,o4_HC)/|@IYXfj3'iOr8E?5E5Fk\S-sW׸VyӺ\tT5a.XU;^a)lޞe fk32; I,<0̒~=xݧ`}wxkRKXI<QFe"®p+U lPWcy;0WdR AOGQx2Y뙺>TVюzhK`'~YΝVQ1{z\T*6bFp+nv= 02U1i< "Cי U'3:Mi\t`HMFe.'gc= Q5gljXƵ.onG,u^/\& YZ{jTb _f`×>70[165VPD6s.ѧd]I]& >l'`EjK":M(3 +͘_|"AA8 O# Y9?-k M)[4\u 2{P_Htͨ%VeuaV'<[R"!Pf&w1x[R/Ty}ԸvXҠԆaW5@~xR۟RbdI[_ 7ىC[i1&iwWL`A^f'>:cw2<8Iqۑ ? %^ja (oB6O`(ɫ$vȾ!7H> stream x\YsGr~ ~qi}W˕C<RyTwet$AeiC*62<{_^W~u_z~8Q'ߟhjYe:{v¯Uҫc_]ta}?0W,'a7ݓ&v Ou߭>\oTosvٿrZC0zXbzqUO!!tL1uVZ;oiJeÖ~Y39'^9hv3`aEG{Y^k-ДŒ|OSnmr0}Һ:>'k),`:&AAfurO=aG2n`hU]d}:pJ6}A48et=NeO٤7A{ɍ/h_` &dpm_UW7@d_mS!yp9^=+|)"ma0C.lM')vψ&jΆsi|^swΪ.u-=d=up10 Q)K*׽᳀8j"kcsxˤi HksFvr=|- '#<'HJ8NAjx7Ŷ<@ dyaPt2\Z,X߯Q\ׇ b.66j©E܂ fJi9a(:JksT;;,^AU,e-A\NTד4AnXA*dR@#,z[q?>Ta/p*_%IߖQ7J>`qP*P~(]{@ǀ Fbቧ@u 9j,:pԐ>J;2j/\^4dv d5hxMOR$oE[?Jj݃i@^m=`pR!%H< {UBZ0ǒgr+:.Iat[He#/pXrb|J"Eq{p ]9qh"p9) ;!xg6۔E #Lo`q`e&B*G&Ba<;.AsCql32Bw|}ۭ Eh6\"BtK;Y}&wUQo׃XFUŗMd9(FJЫ Eߕ !4 2iԾbE,a˪ ">/r(@h#BK38"|m%Bsƥ5qb&(@%:•%x\ h[XaϤeڒhLW^+SN nOh8D`{AQdxk ?;Wm܋݊FW0{!]B,x,xt]Tk?B v-ԘaT1/Np±_ݼo 9+uA /b獱 ɲ8Uv-}o2s¨%hTNT>*ڍ/(CmY4$|Ά# ݣ^e7o+Bp3%Pd 2o%V#@0%&? 7m\pBJ3ox/:?z ε6L~ 9'c&;D?"^P[bQW{@Ƨ EVkCoocQBiK@mE0 N3}Y9+(/8[MU\ 4}֦?cЪ0eflg"\Y~ )࿫C~hD>R_eڃW`c>jg+R 4p%Xma =IS|$ > 'yqI,څE~$$N1^r A+pճ+f 5Oz@5f%ʫGHI|7mPd<{>u.34uR>a%PL/dꬱGdo,╙wf}Y_d+b|x˖괘pAcRIfI%17$K OGaE9x1pC^M_Wnt߶ q!/x2 j ")*=\ ȯw.<9n4C&oJJR דW﴿di23em^il΅8kl)6aeYD?=⠻AϝzmE5EmWSۧ9ڜ"@z_*{vi_Vuԏq,+I k%N$ U;vkFo˓fHk)Tt]ú!<2uiY;%g (ZCi Z?] }%3).tVR J`映]9ad2zZn=4Xa1"p,A4*!f( J0k M#7#ݼ3= e:F*T:@sljk.XbCw ?Mz6Q&ZNdqf3Z@ۂ+*-B Q!\4im(av嚜֡hb죴 /U{9[ټ1Œ >#]]^n?Rʢ˞UPŐ'ӍR)& k5a= EI-fŝ,2qu} ,L?Aai4ϖݻan~]nӛt+乧bo:>}zYL zYWuxY:+|Yfv:avW:D>yāvuu"~DE82H0zz["BչҾPAtG&ܛ)/[6~pǼ鿩#s;'ZsB8x Dk} , 6uf9w3ˮwTwۭQ~R7fFLXd&eBɇknG353il= bp?BW)=k)tJq֢BfQ>eFv,j{bJqtnL t_G5%!ıI|QS1ٗ3 vi s׸Uxa@1Y)-VL)xl[6{ bahnS"ʩЈl/^i rI&qK,[Gc<T4bHEzm#ζZu-"Iev:_|mt6 Z~`~9#U#xQfX*^)SúBK؛nɚ6}KtI)e4tҋJw2 {g ybbxE5)Hw=kj {經dxRj\kJ:*syk;-q`C얾'[&4 jYN/Fz=ʶ,~7,_Ћ8Op.,4Ic~e>+">w bC2'%P.2;-}h:^(<B׳TKN>rmÇÞk5DRa  wL -=e)lcSH+q#;Z HZd=Jw"̽`ޣRQߟSaĊfH 7喧dxSf_xtwݗ7\M &I@ xq`6&$fyF]1$2~H[Q[.t\4׏xVCpnKR0oECxA.4?P5֠:& ,"(%!ܟI!^T>J`4izfQ H5=^%/]fu)CKڅ +:CQY齝}:_ӻ~vٹ Er-jZѵt3[z}ĀmnZ{E^n*Wu(JҷOEaPL/': 4ڵ&xc^8tB(юi՛ד1՞M|WC1Ȍ|qVe?D犦J}Q3 5UJi{$1g/ t%Yb3iru:8/p(ImOg`)r ?F*?@Z$Knxهt\#8-=[ @}B c/)7R\N{iccr*hC& FʽVօ:Z[R\p]aH2[FG+}㸢C%.<͟C@#w+ K^ 7^4W1Qp|endstream endobj 369 0 obj << /Filter /FlateDecode /Length 6396 >> stream x\KG#9eQE;B7AF5i]n1o_DFxDevt[ӁTvT痤;C|!@` bzV ZYX M&l`W1i M6i Q [RAi_4q7pJ02 F ZugǨ5GL~q^a`-#N().4xYy{Fۻ/ x3eF˥ tb1(/; [4l7`Z]ֶvuA#*R^#*s>]7?Mtޣqsp@25|Lɻ+mV!ke6& rx-)!EJ | PkR8j _gErc'h97Fn\9-B{ Il'[ {L R@+-| 7V&mOLm77>uVy4/CO|Q4 [ɩ?%gRu8!jn!b[SC .y L9r!BӞq & StM@>b7MH !bIQ JY{,o9Vؖ{0bm3IP 2K} 72!L'jz4)AEzk/':^U)8a~%Rq(?w7y`SxLd&4[ ]A<<V+n07$Ow߻ί#lݪ{gSL`lAZ4"Ր `n)c]-"Af>P*Gi(80l y'O2 Za`EYJ;iG |!j?M4zx9/kqNP1Ҿhմ/!djaW؈ej{\5Mzo0 (W6UܬvB,O4Mm@rH@"r!$imT_ %w%B s*WИ$<+(_cI>$cc")E 1980s ˠJg[k3d߫2:6IbD nv)]mtk~Lo;'Ի!#WWPd7ƤC>㳉h?T?4CNf𜯚pSy FD>(iۉlEv>k-u7ڊAf.dmrdBc:~,O ." ^'; ΢L 9!.fHl$rHd e$%ig/=;kPg1Ά (]i+P~T"BdCR头,a2ΡZ6`w ab< :}P݄a'BgV%` &Hx sD1}Gj5h2HE Z.VwqDP%-gҏh;J# =k L ܽ.:#s4 +C~`C`Enku#Ш-:4q6?!oN{<͵^ --(&SO OG5Q2QA%3G'qw@fz.i1 8u^KC^\0bUMW=]4iSB(U&X674>JkYBB؏]0DA ޾;8d?)/^Q>$w4 @ I;Pcq'ϑr)*o/hUQJ jSmdi5oV:E(:`<)Rт r^[8,IZyΎ9 ?u;C1˃sb#Z=-v9 Mo+7( :8*mF:82Gz8k8S+WO_Rs>bG`;v6H1, [Ywh_#e|]8q̣Xoqq/n䀁4`}1&=yב8-INM*a'S2TjTRZK K 'ғm[` X䊥ȥU ۲u3(GhYw2MUJ$j2U֚61jyӺ{p*3 VSbA.4^8+- &oYDcI &x?Ztއh>7[]Lb]g&&(A^J}V[9uxO]>l6 Ӳ <%_Z68 xD *)M煵{6n-n# ja6?'9."$$IU*H}ƚƛrQ*#2L˻ 81jrj)VbғZFkNe;ɋ$ZcL ٫kZ%s8`tj)rr0:JzVvP͋|ŸG6q6# }f lg2noYM.\P.S,0^j{;ީ1i柖) Rc>~fm9jo_s(fڳW4}Yf:t\]{UNbF9.aI*Ջ+9^T|i]11K}C$OMXwuurSl"1udSdž8?`P"HfļE1`&: 843{ QV ŒKU3K% zM]I^Ȫϟ|# U9b߭YrٯJ[tܞ\4#Qm}: pO|ȓRE4/JϱӟqPE7"퉓N}[&:znU`j}f(@X4wφREW!nRWѾy`)86vpYօf>p;vr"gfc-Uzf1PfSSsyI?qEEJ(! 0;1މVs#7ğ뭉,%%qE%KRv!:gIM-(%X¼ͰּԌ`:?Ԍht(͍IxώP3ސ[ex\P`xp!4+cMpe&5aVhp-M 5L& /+~ɜ8D(Cy8h"~AM>Rlͅ^L$t4Ee"$< /~'=/umnj qź :nqh8,|c[1}zUW3r}K#]T,!%Yr$ΙнAQr^K~ XQ\$qS^ƅA~)tUlqV܅ O2Jmd UWa |/|4P>⟡t>H Zok.>1ƻrʦ1"pIFD9x 0ToS!_6Ulw _9,&z*W69߹L&u%y;NEMhz{d^0QmQהwQ^ZUq ŀݔ؅zZmjS42$y.DLsYΚd\4 XHKuuNɔ+(&]s ~AbnqB٦2x! &P5&*nme ㎈, dĥsoŊ:O1EU\Dk!L[=3QdO|}w=mLFH 8|k'o`)5/۰enpi(38 $N_m$)з &?UnKڜgQrl?oFi|͇C,ȌqSUG5&'а ?tR ^>\j! 4l{] yJxC둿~g@VUÇ@,(x64}TbჵtwW|Lُfwm Kfу$6̰`fQEx0:݂3MQ4]@*k>H6K j|mQO1Žr#-nL噶H&n rtb{x+FFSkߏS`0]!])?^*-~g泴6/ひ oik8^>_rHGoP;omʏљW=nDW*o_]}G}(wVz᥅%Q\Zb+N; 0WxO/ac\B[Avy&J[膳ʹ.D$ҔY+l_rǷ(HI,"x>ޘ}0>b<@G}gmQU/U}> stream x[[s~go`i6~QUb[>R+Ê"))1XJ> hL_y/F//> njOړ_zRD<rx/VKF+~~ GͰPEVk1N"C#a8ZN8\ʏB*IĨc 1CD6G1e" iV3ܡ&%> X6Wyzvv"H8ʘbt鱷 g彟ь2O}<"qz*h,!-m6&&`1X5U*֛ii1>%Šװ}FW?km=~:o!Z0bt(ZGU;SwCY հk5p _W!ƣ q^#Bas=B5Si-o ? khթYO+_$dEg߮H1dt2nȻ[l#$Qz(mEG .# d$"Ǥf5L|>M T8>MNXY!J:M֛2!e`pc䘭qTbUzU,V:ԣ5QeŧA;c)ß+ygHG=;Ak<LmI -ؘ{o{鄞5 ,72O (mXM 3zp, 36p3fim+^tzneTFz0}ۮ 8%/+n -tie-9HqA@F%尫dNXxzpX9\TjBoVR޾!+:iywXLX InwY>Oaݹk_EXGuxXpZ)nC9c$ vIޭ×u:;-vTçu+q^YgG[n(!0ynTev6R4gM oZ@CLP_G5|9HOMwNP}vejʄhl)#Zz a*gW'^aFK>Is V[4\ VQی'"^vY*a2"0vWC|ll[+Ku٧s&a}OFއȖj624I>Z 3QQ&:Q(&OB=nOrR|x 櫦|ǂ`6okVMӸ' Ä1`oN2ڲ ˢL(Wf!|ܩgՏrd䰮u<5gsƹjR.Q:ӚE _ұL*Iy[M -_b; fvZ¥K ړ my>3r">N{BOGI\0܆Ǚ)mL[3~|}Н |Pi͒n8G3-< Ÿ`6T=&=mSvg 5~Ճtإ xsL ?zKejb5~4ubDmN6݊eC{좗 DO|"M~Cl6e];9T)"ktP!|?>t>*L쫣Lt13P;u JZϙ(&rHZjmf$+"-[pnߦ9-wmJ:1kc7Za0h8@,G:5xܬ.*#ЭHf0 (?. n2HT|f(J-;\kSkL{8SMpC&54TgJ2Dا#!n@m'OF*QVoF,d/\6X@insy;kn_*ȊUӝbrp(B%Z[ז%Lmӭ`B^TXϦN :_3y4d=y7߂ -YyjsHvFG]舅v@G,|UNgiWXwV"QD[&01%W 3$11y\ZW8.m3]SAZؒ X͗=I{ժk3=dl{{uÃKZ㯫@za,O<3"_(#%'$nim wT¶^ޏy38ڋ™kُ$^tEܮ̂F.ِ] Wwß7?ZݎޕA|,agޣ|nw+$P Z;v&F\.9]cKAʑ'6cgP'2ZXeg tw8-9s̠im(Ɔ2wtP+|ʃS1Mn7%T |Ve'Qz<@O(a"|@3V) ߅0C,MLj^6bSɑ?>TQIe'MXpjofiJ. UNЧ/޾}.Bhԩ<]àa12#CG$yϖ=}S:|V,Uw.0~1_Y73mwM_XyuلFޭ /iweOغD]b-^vD\wEu#TE n_*Ǩ:Ibmm۸Y9w|Rk>F(h/Bڶj>v!|İIdޖ,][y!뿯vIQ8, y> stream xXTT־0srbahbaEQX& lz"("2X `Xct}&Ky?0f1&L._ukҟ2~Hf.+#-c@>dIKFyyxX۸N>gά֯α^omBv prwiSy9auW`0w7k~ֽM$ooh{}{?0,ٻ4pYPpȊЕaΫ#\"]{f-o̚=gxSNm,Ufa3c 8Ƒlb&0f+lc0ۙTƉY1rf:Y`V13ƞŬef3KƊyp3`2!P%gLef|xƄcʖ7sZyJtB(UKYêF2]`7gm6 8gnqlgqj}1xCB8uW/m~)K=Ɨ 3{حYRZ],mrkT9 AII$?Y&E& -(-BT+C5Ҽc>Ȇ;eNف,By* G Nf]1GPJ.ES (](mo[^)ɂDn*rNV!8Xdnv\:VP fZɍY=c>Z qĴd:5s4F?q8D :': 5*O=h[P[ #`k-帪] 8JLoww #TxkՋ$d,C\pC-д$9=:>⴪2[*Qxѳ,];}ҍ'gd.!]&l6X8QQOãdo5AÑ?}Pzpjgɢ_ڝǤى'cg:a$cl]VWG>u{d*țݏF9,nDF&@" G8 Wms)?zϝ+g!-&Z%q3Gyg4ɫd7в-vU|oV8ӝ:Fb38Vkd #, #ҩ|PՂo;Om8 ϵ(1^# (uBi!EgO,qI s1쫩1hri~ow|ߠPL ucX.eh!5-.)%-x8?2ȰWqPh}6Ő A̽i a[? ˵ aH*AqpP Vgqp>Z 4\x7[gA˂tBzL ȨRY+iwF\X.Bp@=ı<118ؤq_zvԭ[]:+}*g9-I#{r-]]F?A]O GIIN;,\7ZEE w]VjYZų/T}4 sH0Ip\%В"ixƁ&Ff<8g(3"pFC  lmeJ)*ҟ(!eC`EvɉХTU1dr9\'t514.#6RUb=2X@Jcf$LH Ф%i2>DYI`G]K-P_JgRZ0&ХgdGh\$VPc;`2ʑrn=\WTT/O0TCpprekdn"E.ZmʊlH5P Ůb8wd?@!i+YE/q. /'Xu@Po*Z{0Ӳݦof~AVq!TP o< ^v/ȒvԵtU^ANWW+/Zy5zUVDF9(Z^6|ʢ-@gIIJ͞頞P a!=+[('#je2g^66J' #U?ZؒgtƱ8r}2aGL{i }o+w=*_>_3/vJ @^_}I&7IiIKK֦IMr& irkK,wMknB,u3Wyhu>傅Fo`-GS8jcS+y2 ptó:5)ZVUDC|d_MES[o"v˨`+M8,>?->9Cy$MSыBHM6JyT=! Lm:Trtk:/],%*ku}Am/HGύċ HOFь**q\\#Ns@z,"OeyKѢWيr+I}7G=H ρrA4Sv2qT#y!-8wZΎfq35 :{p\EXd>vk dЏlR՟W h4A&7c٫ ŭWpҍU-%EX2X?I8hHҦ$W sc8✪Dw"xEcYJ#mbRئA=pwU7ȸ}+Wk:>8ul}='6qymT/J SexvO#~4VS峏 y:F/D'0ε!`ecQ DN8a"u󟋑EMѫ4 }To9u >{vsĉv%fz-=5]EK?km_'g{MXC8M8jh.^VZg=s6)!2Vǥͫ$fDhbma.'>F'w$]'\9Oc#"1av&)^Ķ r '\|N7ԟRvyT't<g/NfKm]1K\T]Bdxڲ>a$Ҵ z{PŶ)_^8V4(ܯjr(Yȓ|MeXAL]la :m)db9=='W)yioY 4.DMјh> >> > Ys TBb +͵1@Fy1=_zHSQEQu ?t] 'rsP}edZySįo {VGj-;hqy9H"P{ !wW%&RIAVq QRj_2[_TPYeV"Z.>SSA!j(qTHߴDa~BE] /̽\QYt/}I%Cq)-s'>INMb/f99bI蜌_MZe $(ЇwV%9D'&-h*ئ)YQʿ rhj)W'o6FW7VjOudV% 6/qQ Os%j8qpRKsV-> stream xe}PwwIVBوR_EkE{@֗jB@ @m $y* JUϞyÙ:w'ڻ{67ٙݙg>,M(mr|\)FIe` T!,9OEd<Ѵ&Ŵœoȳhg/įX|數"9?;˨fYEYPɔThʳX%Ɩ/**Yb2~`<ߒyK_7s4kLF&-H i[Zf֔7)dJYZR>G1}SMSs%mj+JPqTE^ \hW@-&r5=ծ +"뫜va*P3.<\n9kK#.L&F 3A_CpWYrS|t(Hu~q ݇q#NhpvwžBbG8 #~5)&Z.'m>j빶 Oa[ Z :Z_k1Rȵ C\, ,sAkEQkSglvM"H,NH LfN\gDP T:Zp2X gsGn݁owp?okmy} 8Q=xt(Z&&+9LGm_ "G6zB:$TQWOP$~H`-]* yxJCE1?|HG 2u a á: M5G*A̸I$[`OÓtvO (Id>Y7Pvqfjkaf g1vA.{]m ?|pds`U^[ >L|c\7fK!1?.¯չ+lIpm'wڃP>2"!Qc`A o_9&18$_L#K1I<5KFbG/3{}w|:--o k)do KE^̔)a$>H/O2<ҹUY魸0CvzYa"R'"&HGLrE(Ө/endstream endobj 373 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1459 >> stream xukPgwIHVm6ͦ7 x *"F5CHE!p-//("kGkvd3jǞe>~Ca?۝9e~ ˲Cbb&JOD$wAw a"}Gi8Xv}#Ɣg0X4ӂ4aQQI4szsf.KFiLizKfLŒ==4f9!&sA[ŠV}f)ˢVgk |1s-z&֔7g1 e6[u K1"&Y$0˘h&c3)T&Ne3r&~~QvO#,9P/tWP3Q%x~Y]کv:SQPZ+3* ZޝG\||^K4*Vl<>+P:]xthk0$:L%a0RMJH8Ox<07k2}ieT䙢Y.wѴ wPS}RL2H5!_mU04\=/aL" &8ݛ_;an8't.|~23mI]-1-P[9/[**}Nu~|84'7ߛzolo^!e7BE.OPWքޏa A<ڮ= ԡ~:I\6^$Uځ{@0{ )|jtKN*Kڝ;9k/qݮސbUp뿺Y*,rBH5(.I#A!H =El%4ֈ"xq)\*yJolMڦXGdy D[U{4-(ʲ7Z?ޅg(?nQml9T(I1o+B~Q7 "Sf`3Z/|. ǁROɡRJ EkCuN<ǻ} fkOCօ֡ lxV 8C-1Bk\RעLXuN%`O:j7 _񘋣է,۴ VjxIc1p X>Gʚ.vnN>Ka;]ǣ<RѼs8wp$JmI&]v~?f6k8ձ&"V]P6#?hJֿ3[}4qPG> {xXlq2l}o'厓5|solQ&Fu zӺ?>)u| Jl(#2=1 aendstream endobj 374 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 8407 >> stream xzta2 ddJB' PB\w[.ʑދ,[n )`5%@脄r\'ￒly/Bܙ{g}P={P@4oz$z`KyG BߞȎwZ^CA`Xb^PpTp&Θ1mӤ f8 =+=wZ+zZKQ#(j5H6Qsfj5BͧS[wj!5ZD-&SK)Rj*zZNMVP){ʁr j0ESP;^՛CͤRTՏ >l 5?5@Qbuޠ"},F0PP(FKX$|s[/mۜM=U&kd/}ϖ^귵_R۽-Fnxɯasَ7_0DZ㙁po :Mq\$FriSӽ!ʡLJ^ݰ>o |Q#z83HlusЎelj*3b@)O8Dm]fr>m#]U>wjir4ZAdo@t(rP8`Οn]=[U%QJ˔3߰R-&ަUjC=."z2Eȍ4GUPIE28 A.?w6wk7B(k`o+ީ_ s-h9#3liKY)[$HV^E'}f/Q(߃Ej^ơ nXeJ%OK/Wop=+D׵2Ig-G% j5,̓,7Y<@ʬJug J`TEwɢGX`1wH̺kYpa/_u>i[/RWkf`,'!0 нBtTZ0&_X ѐ-E2yB.3p^>N-;p&G9<iܵ%Ȓ oHw/j]&{ Qi>pe^ ZOvxKMLvǟ~ F{{wDMI2'di<܌˙rWvo7vkڵPGT L:Ni]0O!G{JOgkB5Gʙh/}K$ 4glyLF~Qf撯2"9DpD2,12Mm4HRU\w%FT**MD)"k"4a c!Mzuً/ۋї,AcG~jڴ ml]Un'tL-R!LPYĘWW_ƉEqnHm&t:#F sc&y * R-wc!Aoss 7etWFqmH<'3C?FQ'wb`c4_Fr|uZ"0%t4k4V ڒe}~46!O3=0E'6TG='k9MR6&K%?X :U RPzUoXrz^UI%u!H~RS,{q,,/m& %h.7-3BguwGg:N-YJpO,N Z4#q6ןD<_c#I)x2Z#^[OZq= 2zO@9p 3ahYH=#i~khړ՗q'By/GŜU?5& GQ{0|sxkqNOA}5D)UpmhR6s!T -{:y>ֱr/pת!<4B< !#NCP#5D=]&A FOHk7I=1H$:?^t-W"8KR;u ^ ޗУ5z67Ò.HkXjCy/Uj0)fPM0H. ȌS"}jXZ kAc]qy~K6A^jt79ΚmB~ʇ4ص^MxlG{0eg nKWe;9LC+iܻh+038/GWV+Ri$U r:tsě;IrY;B7+гyy8\Ƥz.[7.AJwi,Zde=r[hC~>vXnVgC$&&]_(y4b^2!1Xb-t9rz=J oltyFQ[gϡJScKa!u9 x+,TYOIO/0$-plez*v&zȗ@n[=f>[WRGRkTB *>@KɇB0ԟY`sR95۰W]@6 0nqcѥ.g!'FZ*jcć [7_mF}EgsL1kE,NC)hr$@cHWvު.vk"M%Dsl{y_岡"[qľ' p&r'qRVJRBGdRghEVj=(4>jUjX퀅ȠQ*lRz@dIht!5>n<^.hRHBk%,1EVg[NlUD7No8]Y4NjnRLHIDu` ?׿I:I%aP $1a>4UbrdW]9UH1M2(vT,*YtVa{BZ'9lҞ9PfSEk%73]j~FvLbԚHkDW˕5D2qtzF&v>uNШ3)R -h}~ٴsehIC- 4q70s O NŢ:Ae߯Jyg8 !h0@ҜdmjJ|OD Myh$QH+;U {t}.BYǐt ^)x;u-Acd/p5xwIcv/#?2 SuH=D\rmU8J92ⲇ`[>+) j:Lf⡣{𗦼 [ $*tzȆf]Y|[U;j}gB&:dHdbyY; ;悦kkFbr/ZyC9F4w m+u3'B/2#ӕP "WyhooX39._Ye5%/Ä/ؗTjMI:|2$ptvLG3t^gCGfXZ-hy>^^܉m&4ݿHE|XCQmӮOǯAH/1 7'ēBNܹ7EleP|]Qmp77=,:M\7l"6GFȲ2o `mna[P+JPN(l~^f 3C$ҝXo1r cij *&1ߏ*6mP̜sܺҗ3IJ7jI'&xo(K3j$d|uԵ#q曻4xre19K,zmVud[pS}zdݹ/8N+燛ӿ1$ˬm[^;۟USl +$y.:Kn#GL_nK%>dG3Z~?`c`jpA[YS= w-m's :v +ؔ|Uz4Cjqj&9% Ҁ65( E&F^/ho57DaP-^_>4"`/WDv YBԳII&;R2)o!FuuoTpHHqpc4.Sʴq?ȄHuwY4ȈNW ;~rҝ.6sh7/kx`&Coz(ٴiAcdhbjZ)Y7eۆBBo" _;uC35L&v Y7qW'N/Rckk8 Tߛ¹ -/ jt `?=v{wvB%ȱo'옇nGB[Q\$DDBo` J:.~S`^R !F}s+Ϟ;֝C}ANq:ZF~)-$$_fD܋!=BoU{oȯe+|"rNR .Juc2SReg++\5TUrh2[^ ?)Dp Kd^] ;?8@s54 & moKՒe@3:6B~67PJ#" 2.Dމ R ?<`+"*Ҡ V_YoTK A!aaj&}~h-{l6]~8{03~{? il6Q|WRA وimcbۮA 2Ժ9qMXa?trH=]EyY9VkѨpudW KݼW#^fׇDhjoF|[jBW+3 Q w<*H1QYrpC2#oz|6eDe~n2_a=a1[ix :V\6B=*f2ҽ,-&b L %_ Іs˗N?`i=U{%YHjD< 뫮=Qdu?\YrhNgH46sޙ0Z**}#Qrk: ̣}xu%x)3J?͵ &Ʀ$/&^F ^z)qb?~NHB읪HL>>+g4D֘˙oWIPu:L5$2N,;M G ]>,>+iH5` sd1 G~ȣβʬ FM;pua4bvvh%] ugV$d|si\R|/Zf@wՄ"-zE}fn;FkWz)RFLrxKlwZ?;T NMG"3 &*II`j-»T눌A<[ɰU(G5yGl 8܋h@!w ijhH > stream xW TgRNѤ(K3]4QQ@ۅ-4"{ `ݷMPfSeJԈ[dV3kf gF2yQ2c)R`&y)LՠHiҧ QN"=dCCdh0~XFlm_=z{A\{T*VD (]RVBb&iS48ufgC1hTA[WDTڡCc,y&(QNd$^nkOأ;QD%\3^15< ˗c ]NcwCכ]l+!ÒE25踚*;ETX$;RÔ8z+2HF,Jq/(OTht9uM;{ H.tZv$̼*e:CA9pu8 pb{\Jq/6$o~1]F] %=Ci$GYG1v\fWD<& q5l4) biYu/(Kxqm|dz?4"eڪ_ ޼dAVydA"nC}ʞL8BԈgbh+ɿF QMFZ#5[Vn03T#D5|~@[uɯ?:KlK0Rk,9.[hh)f KA!5+KgR%D <_5鏺̚}@ȴF~BJH_?S9&#+k}Ţ %1>#C9c.T%}y yF0P@ "㗦}CԲb-I]%v"uAJ?е//"i Eqy[9ӵTغ32@-5!CVEDAv%tD ]Mא`P(]+]9kl Y AoL.ȩ,F!*8<,>[rՋGiaP"i GJOLأ4-.o=Y㳩8 ?:\~I2K0S2HKwQXUUZZ9$~Ԯ⪟[^|kj5L;8Q(_骺j &lJ'i8_Ӭm "TQxdy4#*TQ}n|d9H2!lSz$2{tحBVg:U5 65 5--ECD7FX$.!:"פgZYؾbq݂\Il9^onm ?0DFtlԿݲվ;JqJC?RnP΂pctvtSvFWSSjH::~l:hg@E&ԔUU&6nKRgiv Et=q˄ktbGCRΖ%yw/B5߿|xOO) ø#? @aΡUve:(`ylr JTe@rAIZQvx=A7T6"xZq,F]yLmp-]*^7NhvlԴYN&.%Iq, ^m}(%: /@YܽU-?MKvtUqP89A޿N ŃCFޕ_kzj۩ԟxkU~;rPtoQq "ǻu϶H>@ xpԫlv챜558 sP>Wrs{*KJYڠ+Ûj^s&\^#|R0unMq߾4U)b`#.^kJ/hN?G"xRb\'vODk& Z!wsL@)M;_r 2rdt|rc+7`{(X-%BqVyꤪ@" SXLGuzGŷ?C_k)|."Hs;Ad@.? ?{X+Mݤﾲ]Ӹ-Y$T;o+_0@&O2=&L|ɓ "(`cEʝstSGՁsEOnVIh/Q98\Z^р?_93uu[*Μ=V5sŢ+ܗ6⛲:8q1ztEYm|JjWbKӳ0_+hsr^y_5og]DSGuKfcm])0N }>ҊԄB8Ÿ&{a¸H[U uDxxx uD)w_n\Q}nx'LV"!lSwϚ~y֔Ӌ. ɶ|VasmؠƎaWm endstream endobj 376 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1011 >> stream x5mL[eV*8lbQ l# uMhB(%]K ڈ $Gfp0#beLp:pN̝{}i]{s($ 䥕55Gk&,oѸ@p6VX) Ꞔ4DS]n4tz9m}[XhToo*^eոN[zۊrr~:s{dmM^'W8;2wc7QvWnpxZB){J˪WX_G(eQң|DJ '")2A4e’Md@rU : Ni~`bJd?0?MS b%R #,gbPd~1ϩ Jx+ߚ 0]$3^L BҥNUMg[dČI% zH X!1qb2QQ8@X`* 3a<7`qX`T«8"<.YM'iIӲ@3u_9;7C`ڝjϐ(標8 N O6IHe ZDF5#WY fRP<$2RNj "*hTB?ܤy?o*W$Mky XȢ,ά*F Syhw_ LмCбqɽbW͎,-dk.9lp}'9֌m k.wpɠ~5$r/:z{QQ<ĭ-*G{KLYAƙo?0G/4.>\/ld,p5,3!<@PMɸ<~(i@$&0 U|/ סk?ĞY}Ŋ+.sU*;=%91k0[xKӵ{⩪Z-'vCєTuV>=T.)7 qendstream endobj 377 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6602 >> stream xYxTeap(FI`='ԥ) "҄RI¤LzL˴3Moe3!HA "E, ݽwWtN ս'${Fq\U[,f : /5c `<?4uƺ;ٟ@aOrx\nJzU87-!.>#hvK.KV&Ŧ%DG&m̈M?$mMN j|Fx /dggϏLJڜA A[bcӲbcJI4oRęiASbbӒ9o:5gGnz;7zc̦!q[nmOܑls_K8` Ng&g3,Vγmٜ89;9oprVqqvqyg=eo9osq6rs6qpppr8s9Op8c9Kp9q<ܭܻ֍Ix~'%1S8>>0nӸ,Q]OLzO6Mp!เ́?(N2ImiBa <;5pj 2 %ɻTgi ? /eVr _gG!X.^KpC zb v%AQ2k'RK>Fw\۳IAu$?veQWQZ^HEG]EWy y߅\y}Y3o=ϒ~tOQGqaOHDLQ0mg. dzyۼFdp(ZPo4 l+b3Y9o3B;RVMd6,bKsh 4?|ďmϿM6,$Ë }JJT1#Pmکz h;@ B%HweYJ64˞Wux=l4oǂwE%$S´_ H)ԙ vmEq(yZ@lVrfЁwV\pkx۳|mE (XWV@v#֟_g'$vmy3 f>&A2)`~+-LSeq)Rޘ,eg-YIW{]}.TDt B^ESjޏQF7vO=VlzeUg{јTm.p@<%q%C^a Y/XxF F-RF%׳/5?+6]"VU lnBÛA':KC漙 e~dpQ&6M^FSw7XrYV48~revUԺ|}zpp'?uIWh/!*tz ꜛ  R5 RR>c&1Hh9Qb9 tDA9`!4bnqة]} *\]oxt!wG*vlC)тh1d Z䌴 ]mS5f69)Y ;zR[/N`M,|ڃ'sό˽=i`wtQ1ԘUf :ayo>uA! 0}IYbp[Vo%Uu &=R[]EkkNE_O`9;h~?m?^S Y %KvN}WX6ة bHp$ԥ7te5()>g`WӇMK<-*z0IA}:^y\x|MV1lՔJ'+zRgg]YwQCS'R'h d`QhâL~:]ݬm\ HA*;1}nXh^u? FΪ& ΀x5'AiRņB-ܼ||}hv8΃ nIMBe?zٟ~t@'t—ԐNZNFm+( o68`n&Nda)$V@v?ShA.>_ 2?۴`*AaGMj%M@ 2 bCcsYAM% m_'OkTR(?0z 3+p\f_LG#Y2X{[ST4Kq{8D1ka\-=!qKk<"7O4Ϭ=z**T+罨b{Zw_ouG[1uK{O 7{M`0 qpͣا@"vLޣtGe [czJarMbh$`rjI_%`RPLd#{SK@XV͌i>Ex :)2}H\ax̩_1YYW\w:Ir+P!5.H7|.(ph$̅Ʋ-$}[3:wdc/Ы*vl0S)5+e'-)P@O+q&n+{vKNF;|#p{++HC*$4%ъpD3f]ݣ^WyВ. : إS=n`qhdBh3bH6UwTőRC>;`/иbtSwv}>R+ܱZ^ Y9 a#=7/*7&:L6_\#s_䪣ۆY/$iMd+Kkk+[EUGIc'&`aG :cp|2J%T%B@ 9fEI* OK~(n;lŎ:t艿KGh_јk.\')B|}+crq 2v;߃}@MI?ozYaahdbw knQAEjn4&=~izK ! P%ↈ)chv6;mё5puQ ]mZmvMhL@u.V=:]널=x۠ǑX/T8+fRҌ&mFSyseW?'%>'ezp{=褗"n>aW3Tq0O};Y|,mo5W $[;r̭7&Ӯ-r%HZa 7( v\7 PW׿.wʺONF m{vTeFʪՀ&iys"S@'JS50 &vY@&sYynv݀}IT Ȝ|kkZEMaNt47CiCОȤ9dV:G7R{qsq|CW{Vne!%g⤙i+[+ Itih?[=hzG!) teEP۴!ے_\mڡ}+}grsx̴endstream endobj 378 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3836 >> stream xWitTU"P^W)[-EQWQA14cF"TU*5&55R2 2 rX`ٯ[΍7$Am~k+c;y'|Yٯ<9oG_'}2='e6_$U&*w)ų?`9[ ^VZ(ˑsE9JCV<{qR)[jznNi2ΥE5 UA2R*@<܉/Ye eB]_r✒’Y1ǻM/Ps4ڼl]%/ZD(fmmț{o9oU^6͛>{ƛ̿I_ɟO!w|O NO}wn~(}i;s2 2#sgh3rA.a" 1#d.s@^>n)񡀹"Li\SLmoE@C';``;@ 3,Lڠ62?_9ĸ%F4-n(6mfxn;%D VjX).\OtgW[{SӐ7΄Y  s{m~:NA`VWwtE'Bn1E`KSʝ$t^  dTG ð ^~6>c&E@quh oEnBc5A\nCZ@ҀGG&sğz;Fպ4i#0dI= 7.~Uv =^D:n>:>~%Km`RN|ykO@(WqfC$UKg'80ƌoD(S2%Keˀ҄k G162y[xܢQ@mC7k-.R\hq8b኷v' 1Cx E3.PBwT_|`W9,9͟u*7ITlU6l"\T5{ UGEн_E,!|K^U+ ~{D6rI ʞc'[ X@`,ia ;w]->>=Flᡯϡոx.)"}/nZ6mްm.-h1]C$Ep˿ʠjH$}~B{:{&PPl:4V( /Zw. -+/;* m B1V2jjf(>& _WT -SmN_5zUKcBmuT.QOa!*#9Ƞ{U:ݒLyBA* "qf 7ʊ | ZpU궿/bcՉ=GRovv.R(F(g;رUfڈ֊PeBkQp鹿q6]r\D|T /.Bi:p̫/X]r6$9챙mb\}dCh+h@⢭ҒRRTH'= z[KWpwh (Ɋ;1%W=;0p9}Dͬ[38;z{t9%N-.ۆYW`;Xw:Uc?ˁt"ik` ҷt׵MyҭPۼ=xU"HkS3+%M ܺ'4 +ES u_H^A/X1{P?]UtFכMGq3 ˠ7fBHͽ9o_c9bl K7Pƚ:M.)sU=*q4HQh;giO\h ʸ92iƁxakqgۇE#V=eŏ x SG[֔U}áR rBҖhAl<6pMk=zd> :xN*}5A_<)dUR&4պƎX;ގ?ٙ*ima$"t SJ}MjնHcsM>A+0cbpҴeh`ѡ:?vgrЬƨBWu'hhc`Mdxc>{r WK^wkx1 ^nR *o)ʗo~Zb!/ |p/`7c-7#gh#4xG/FVO(^b8*M .IN> stream xX tS>!4E6ͩr rT@AP MC:f>쓩I:O@$ j/ * .A9ӂw[뾕aeo(#S_}N.ĵuIڸ s&ONQRkZjKSq$jZ@M^QRj5ZNͤVRYjj65A T;((,4x/"x[Q9IzF 2aOuF\1#Gt}~ݣVsOEI!$)2i92ob6 [)km,k%UO8±qP:hrt9ؒnowޮveoMϱ٪΃U$o]uYV^u5{:ZSOWEI\q4- 빀}&JP ~Ga+}: FJĠH4^KIG/AW٣κn̘J\j׮n:^YHu9cV@+T WŃ,I0 D3d[0@h1ZRЌ?xW-aܭ*fj`w[7IwYFI8.&IM3R1@`)ИxBuD_Z:`gzBP{ww*e2qxx:coF\Q esmRt EéY38l60( jݎe+_>GAP[fM#}$h( (FZX% )vEtoL8ʔK`lJa̸\6[v|P CVWBO0qRQ.*"w[}kZg)΅l:RXlKkصbS܆LB?Uq@zVv=!&IO08I{8CaD i qؽSiM3lZSFXUBhDzo-.{[UwEݬ2Mq+)M }p2KE0:`?y}  G -"\\/ .K&EW@Dw(Zǧ:H-[#]|bb.`8^K :H]({]~|UDv\R"y,ti~lx3OxGޭaXL*x EoDQvT4a#V 8hF)K,n+¶MUoeK<2䁠pXKv+Oo]9N[(PgICe*azx@g_.=ݲ3s [~QG9ik@!@ج KPkCcKsny ;Y獖v剸 S';r jAc}멺Trys܌-٦UL4$-%D'JY3ރri4AjԇoDe6N iFP )Ef+G'"(aB&rOr!$CH tB~Bz,BO)z!hYX\6y HM[ZP[YPzB!]87;]K޶t֦?HX1>a3 |Ug=demZQh+[ɀ&ހ,(Ks:[HY?ѤhD'z7D*.,b7ԫE,<4#GП?eg˥{3xmd`;$$cP8K]eH eŅyƸ͚4qр־e?/8hK>ic#;bo~myomߕ͐Q=#ʴ*k6w:T*x_lDCG`%LT*RDC[ 67wٚʅ-&C}*qYQcn%P }nCvQF̔5G;ؽ_]gƎgoY0nYrSPE}cqd ;of_oɀ n|MҫE:&'8Tf\:,_O܁7 [ZdbQL5V,l y%}^b6 "NUA!s+ҧb4p34%ez,#FU/\J gr=' =H:2qC,G]rАRohTx:^ xědX6^.&z&&}K"Hi-2ĞE%g%1^jH3Tkڶtpc{V6z1BVe`.6ycHQ2U bfTo8i󖈢߫:f@׽g݅]Ig+lűBҟ }Py*#˜nA_n~QK `s@ ء?\:a?kHA4տ̈́JhPϻ9!>ږ> &S~#%.Ԋ\Ұ%"FlX]BA_+9-VR2&*G(3fX`)_v2 7 V ʌ}(s:و{G=6a/ <釕T땵QjMatLi&)}t4  -SH=vL+ F7糸/+F/8l{Tb8n }:rٕ*AYQwy`smMWٯ< S`tAOsffUf%GYȔ5p_ìRoȮqI kIMNWe[A:|i˨Ҥ%'uPsiъjȦg7x#R@~@#୍j]RJNY*DmMbBXCM7+T>$:LQU\:u(YVCdy`sC]{G[u:+֝ܘ蹷nSjm0##t |ˣ[Lյ+(5$Y2!N3*n/ 9xh4(ia5J)xGِаUϪEFR6dendstream endobj 380 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 925 >> stream x}mL[eǟKiw݋6 {oˆdYfK^32 KA_v{vli;yvml٨.l~D?M4,krNAEij4/WwRrQ 6voԪQ{X؆-m+RQYOQ8P•Up6^v\Y6naEEKKnls%*Z |'Wܫf=r؜="/pN^#4N:tEET8m8u3ǒ uI~*C}y̨x\w|A>O)pn qww7R8/έ~4w?POw?:YDhpZޚ{2B<[ la9'b2cÃa,)'xNf, AX ~c…$B,u _fF+zr5 S NbAaw妑@J% )&,F^8*3ᚨrtDXpN8S*O>M&~q]s'}V T`gKfP'? ;rhHzeV=oS ]!Va/Sx8HeyW#z!0=Q\IRDaJ_+Br̓K6vɜ}s;.#5 xD 0 g)@<8!5/ 4n\rҬCVq?O8eW j|&ya%t5R $8nO'nLaSwm&0Cݲ|endstream endobj 381 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 328 >> stream xcd`ab`ddp 44U~H3a!3k7s7ﻄ'~%XP_PYQ`hii`d``ZXX('gT*hdX뗗%i(gd(((%*@s JKR|SRYBt^}ω33G[7]z}r[~kb}vEly~_d}{O!lYwVWG g/d4mn9.<'yx.x:endstream endobj 382 0 obj << /Filter /FlateDecode /Length 176 >> stream x]O  @dX%C8""dߗGSU|ΖM> stream x5kAgS#d.b%M=X"HVcƝM, &1im $(E[Yw <=sB8OlnG/=9젖h0ߺA}S7Xarz1.J&VJ2cU gYdYAm VhqZUs4MYԓ*2j+˒^ Yf"3\^ JXDL~D Y"@'ΰo''g>:"մ=MGENl!=nn}Ϭ^iTie?zwzڤ5 C-[ t'ds):5kd$IH҈ǣ8ē CB0f,)ӮJFT o..*%GvwlA?O?%c~\ zߕ}W&|" חendstream endobj 384 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 192 >> stream xcd`ab`dd v 544qH3a#ew[ς 0012:)槤)& 2000v00tgcQFBըqVн_pON@[{W4_N\;~*{r\y8;yCendstream endobj 385 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3679 >> stream xW Pgn!V9f6gq6 b),!HK:Z[S۞$'>Xg2&4;gl*ltUw} !b6/_8?0Wx>$P6i,& …3HtifB@U^&W+)ʨ _ZlٛQMORHOFmW&+񗴨=iRpMR)_tiNNΒ%2Eۋ^ʑ*Sv'e&)6N*ǧ'EMVdm,]LRDm%&)NA7d(6e*U%&LIIK_OE vynb!:"XOl Mr=b3xXIl#DI'>{EH"O׉G!/ӝ;n8h&v">!V $/ϏN6ཛӊ I@iA3tFhVC/6:+*}E.ũA MCKм/k֝Og-?dGM=Rx:u1Y ZY+#Ʋ?+Dwjv9Ϳ0~NjoğѠmCP*Ro~G."!o^%WFBǾ=K|Itº})DTbA Yj*1ꓥiȟyH^OW FmoYKm|vI^`ZȂ`Y.(kVhcZ~]p.ANq|]@c U=tÍ3@^-12m-Iq=!*Ebk9BTy wIY)գ39k09"EQ碛< 70F|"'9k\Z0c(ZbkDQζMG} ڬ|`rG( /yCA7%8`la?@Ɵu`3. 30_GQ r5X'pgqJ/{C(nZX" Sd m^o?]Y+G2ŗkF&w 0+ 2"L0Z(ɉON= k_n_i9xɞ̮ˤ.k( _^mTh3w'VB"jvoO+NlnneJNEirVRe@fkkWo%=#hgA甫U R1>54das:U&BS y4}hY_ OoP@+֭/W(NbQ J yR ]{#6dxG~;b.fwnW0|]' $^g Ԑc'Ҏiq@.%9Y;w,>ROYR~./*#dCYɒ'{z[(GfÑk7;q `rtbzjei[Ts{6Z䓏Df M!{MY+nX[tPCb?HP$y\ 2bpKh(f)}.eu߿c#ewwpr&=,d:ixλϾŢS֯+:5lۮo;6Ɉoa@@l9nY휒4?] fjG7pF3E?2ӞwIg$FEsXJ&hx4LfjN=kY5'2氢+r*\lP3|+ttpL{I-e9"& ڸOo1Q;y]~(ZNXEoaE7MrQ9ܵEo?O߇unm^qzkLů8'__=Ph=|fq(1,O:ɮ;:U#84_>>C[6? 'HQ0| R ;,"OцmWz.gA]٧e,ߍ#sai}CE<}zg%X렆Тz A8C`PL.rAjjY#\djcs.Ml,8O-lTAyNWƘaM`Z3̺;OWXdU0If?,q)1)C S l;UZg-su^B+KfwoIໝuۑÉP'^>Bt G[DV S?eOI5=9 Bu;Z~̈́JNr( Wsc^hC?WNE0WEƧF0dIiS i/iDQ*;jſ#?!l^nf[v\nQNpg)b  FHM(gďh]1q 2!cv6{) T{$x 3}S$ ,c6ٷ^T#Q'OUWWtaw?r\>ڃfj[bjyl,V?ѳeVŮmY}(#~Gl,60% *N)H$GS1DkbmtHufڎ < @o~%#k](G]3n>E7|N WdWendstream endobj 386 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7085 >> stream xY XS׶>1xPأD9<ձjl aB杄!a֡jj[;^[kG^Oߦ{; x}Sr{=hU6M#Fgl?V@_>۳~Dem < <^rf();%6:&-1ASfϞ9>hɳ$DFF$HJHmEFe=77&--iΤI#R'R!*5*%#joRQbZКM|EբQ)AlXmhW'/IY,my+ʎ\wM}li- 3f 2Qsn{bؤɹSJ=? l"XG!%/ D(Ml"#6c-Xb+XH' +bb"XBL"eb91xF 'VӉU b51XC % !'=$!%Db.їxO#^$/Nb1M3L3?1:2;a[ΠAs‚A_5#xt!φr~~sqOU)ܧ^c /L% Ndy8Д Dp:id$?Ƕzژ Y4E+nI2$ DBs(q.:}z@@%[n}y`ְ > f`+uE+~;MߩN+:dm=u Pg%*ty:%뱅`[I{$ʳkG[`M27*S A߼[G[)fvר,r,xႻ ktҏn$tIn$ဏ S{u+c,k3\ʎ"w#!!ϐߚfWmZ1}_ r-WZhs h  Q,` )E/snb C9vZ=ikxnCmbďZQ%ԑZΒM 6>Z)IR:V ܇@}Pr/$[Jd.c#/ԛg d F+v MD#1%*,d\N|id~M5L$d_d>%"(9D~Uw3)jFbuVV[0+ S=&ϣ>>&nvk_q/=hr5=$;]d Z<^+޹wVhh܃ɄcƶW1D'?yQ>*B}LH =E.26E>UCMC=snQLjP -ԣaY>gwo^󄨜$G7:T&!ĀXΏ_ %2P !xG{z{֐[O3* Q˙sS̒[Fy:!k"pAA)ιSˀdV+ -P ݵ _K7ā58.N^a{Heg2A+IUGodA\Wybv*HXep3z,QuLdϪ}l*&N̉$:zgGUh˂<\^Vʙ݀p d@SuzP9 樽ȕ`zy4>kSg9EqRRYTf*伮DAn?DB{*|$hn`JGjΆbY^r!O#N$ГU;/&36ʇ2%%Š[H&2^'oB, 5[7(4 dy5+ñ6XL kcv,c-ZE8jH _\RKD[i-⮧/BP=urթt We}]I}&}oT-P vK=TT?^-G¹8B:r4VI@?Tc.{.)$= f{ts iU؂7611m1 DDBrNUN>gGVV?[v,b2'p!U絊7Df9EidGF}S]]&th4}5| `A>"82T_v3c3,Tah%=,{1>z~ZQuۘT(Rg4֬]4-? &`f <MOoX]h9\,{KH|nL{^ԐURe7+ :p:޹[P>1dՙKOky=Ot_i(/.=9:2U*? Me9yK#pq53׸^>bbvs@6MG33XLcKpԇB4ѧh-?+|89V3Vc'~xM>4%uEVN|0vDwOAK{^ V<| O/g?@,D=n,v?I5_h_m?_Æ1Y.ECeYNF4(GOtUU& tedծPSR-Ҁ5`R+yX[;Jurdw :T+@fnp֗vahz֡1{7Cͩ Q̗5Z-Mbc`([1^uG}!SXyIZ=u.6MA R{satpRb bP OH=(pjRE$+wQwx: }y pe 39?ƙ܌i+jKa3g3 Z>y[[y%zݯe K=c}x0}w\hUWLV"Ђ:^4}bWa}'[^4b̬@VbJTғe;_ɸ G9p %`MOBߞߪ8tAa'Z)nuJ ѩV.W:`p' ռ+\cL6im1@ʮ#P[ɖ E30 +tهՃ٤4Ĵ+{@; +*̎R76 ?b3}߳EU {qCtsZCLllBT3`[[af:zL'wsErd ʲ*!y>) ;(Ժu_0"z?]\̸ۯʵge K Fm˩Z ' ] 7o?}I{ܡ>J+ϴm޿;qń_3ki[>9TսvVfJoٿ+ۍڷ\X5kr钢PI9rZEPDL!!.4 TeEyueYabi'& 8m QnJuDzޟݍxDbϖ|XCWKA9+Qi(.amBfIӲf K0B|@h*vzT8_L"eԭ, Mp;LC -fPNY 鑨 D4F_bַշx \_j?:ֺDJQfHV9*,/v*՘?%T)Ny۬ܰjol4wEPCUK%rV)cP5+,<;?EbрYTb s2%E2:gT#B)\70tDi$X9esћ̧W8.dՕvyĎ,!G 'nmS#ϕ\1'0ywM|=h'd- ֛\7+$ |- h_d* ֩0i9َfSSaN&d0iњR4qDÓGgn7 Z_SwY~BI3D& ~=>Msfk]َq;yp5r?wjH[(UT  & \vmܤ1qvIff >s5wmΤi,iռ׹>.Ќ맛g|3\j晪bkIQw y5qOӐ^ ypc9m@(ȟ3p8dC_/WWCӧP.%8sk5PW+cCS&$4G!ߎ5By.^Tݩ&Ma_%;\HdU`vK%5!RK Cy0L(ݝ7r[FBT3] )ź -HdE9:*Ү~j 4khE !w/^GP\sMJuQSWMLӇ/4Re*\1\KVJPTk():$2HJ>ŏ<^ʖbuEL jro3q kZd6G#ъ5b>4FKre {unKQ-'dMMůTa1U/ 14ɩ[A.5 *|uî Ιfx3-4[1gwm7Dg`} PO|qoiQV5YUfgump4iobFxT"/)A]p<>Jph&`!yhkAt\H%."0?O%lD^뒗H6re\~o7[\p7_n5~S2:eL8*^M-h0'O]45eqNn?.aK%v+%5;imçﭸNr,RD^W0{fendstream endobj 387 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6725 >> stream xY\֟P3C=([ŊbQޖ-.K,u)bŲ/DcT,I%19k.{]ůP~03w=9#{P@a$#5!=4ơ}L252,Lc;@?T.cYo5eҤYV6>b.V.wW ZUj5zDoRtOD?1㭤w5`םVK|%V+\|\tMY$q[tRw 7- X,^dim%da;Wܵm^}g|1s,s;zޘǍ:a&O9m:E VRa*ʚNfS#5Hj-5rFS1zj,H6P BjZDM6Sϩ%$+j2BRS);jN-fP j&eNYP5LPRS=)+52PsT?j>՟@Q"j L'*3ʘ  GQ?'_& &!0́{^ }to}~oՀt3CG c{l'>yoabAaf=H5}C i)J>O,U\ +igs5}5H 5O#PkdXWܧ]a!C"jT̽K*Q] byT-]\s2 PĦװ[BAeR jsѷ`6:\L&F1ꬿt^ygXLsvю`8.~NRt4NFpc$&t3(FGwsaIYGըaK\lDu" ֿM$A>Ү @ TfLi, ,e;N:?j36p0-Pv-zoL.Sof]< 8ǺNvƓTJpA Uj#x'xh<~=Ͽ]tg׮ݼunD6|!L :vrTѲ03FaYYwq%1^Ah|/ AoLbXuSJTF=U&'rɻQrSlAK0e@'պO ^F( U w"SNrt;LnONrx!# ˟AfPo^6+'޼ğ4G؜B$G9̾ Ǵg\'@i B?h@ (ңrޛ?rw,b{j(Q]iG!_. `; O ô0[X~~I 9{tXbu r۫אEOcM {m2l}7K5fͲ w͵tYpR-𺭷鷾 E(q*/^t>asptGo r<3R0A KV?]p*ĔՔEaYr^>Tq uUG#J}xBGlvAd'Hw[*RyEo4dti87<5SP>i\j؞Q [9+Ql,߅=qGk-ksĒݹF+ GԦBevS*RSl"^t/N6܄Z3O3Ѥd~!$2xg[C}_7?j|W%" L5]٥)jxޘTw Qu hO7١ =uF#׆u 2{YPI7GYjA.(Ԍ*NrHJElFN h|[7O HV,!Xk1 =TeW.#%5HL.AK8D٧yB+!42N,UėNxI= CR,QxV-9"fd|*DoGc`uKjl#%$K㹄Ȑ-6ƳJ`(Ou/U"RQ\{{rW!SO# }wdT-PbG4&l[o/IS!/YS)F2ĬWv+s3kR[b,IkF<./>壂4 ;ˤLؠZһeL7p޳4T)^V=B| 7KSPNirT z=˅]i{) ru[#HݞBk=m:ӱ5Z :͜hͶ_n\qy/Z |7"1_00 _* ۓ݋Re]^^#v̐R:ɐ0P%8J9U&?Ǎ"2ʼnUZh%AhGLe7iÙVE 5dVw`%>{X^^9gSXu*4zΣVt=x.j-tBVZѢukn/\VoP;{gcYEl>{iQz!4 J= ԋU@xTdR;!Y5s6O!.3'52?_,Y~ےq$*zl. [/^ /e.3d]r셣GϜ;eggG~;|@Ҍoֆ)yE^ez~ܿ">1y!7xlsK"f¢3{"LE B('f[aBOm"3]'#f1"QmU]R=9 WQ-nh(㫊mĴ <ۨWi٘g Q\?1g#ώڳ;+*=9V^d$UƜ=s}s2|ysԆavȶ!*El~l[*EL4- E!Ii%#H3㋥ڣ V|d |Dbo@̈*UHi InϏڼi$~! ^?JUh܋ËԓGDsj+FA!Rbe>\ǁҪ% C^AY\TD!έb h buPl1O?$+ʃr%U\k״7C LA1V۔^s}8$8īM!; J֓n3,aDoK\\ 'oB r.-(7Q5Wa>quyNXFXz@\$1R>Qv~zo[UCCD[::;'? 4ЏcՑ·5~`@Emє@3MPxVW_ EmN(LU~0H'S|G"x"Ft Sߗ#qfncP/hg(nEc WylŒGbHoI'eƟsX9:D|*},ý8D;唥eJw:CS3(؉1`~}@Om=899mg bf*Y"O3#򕚍)a)$ [/KmۮYQ&Aa8l{`{02X\[e@LKe%{F @'j{+»t&`igq=*ت2;vОi{Pc-gZN~wf5 k5 ̃pol57~~lAc_L`˻vlδmQ.^yKlr܇Slo޿)U6GV$il}ӜEjDZUb}n3ZDNV4á=-5(=#CNwehYXU RX&:HFhLK {y)>vYy|DZW{m z#9%%p8[3#Ʉ0@[`M>^bo]u 9|o'g*.<$f.kQβ)8Բ<6 N[E3+ B',T(nμ8hnPUw@}KO?B7P+<Y)ܻhCL\bdHQT5}p :9W!lArLoitmZ2Af@8JؤX q(EfE#jQҼRr7Dnh4ۋwNQ.g O(OԦYC-ڃrc2#pe'"&<$JBpba4(;-5@YeϭcQa|zhp+X"0Ff&-+,o8>>q#wvݵ(t*wYkדdޟXt‹ӵEM $~LdglzUF(ʼĜD9W<5b~ى" ؏qv.yX>u?@ĈqI<ĂB<,7n{u5&?1S^R&oqzߏ,JE()(GD&ג,C 3 2ZpJ _0j[#ƣ:^έx͡A@;i^0F_ݹ}c G^_vezKH\u_HBTT":1:$9<%81CGvIB} ¤lD㝹 jo.q Hhߤr\3?җNr+-ǯ0yŽ̚K]KLy֩7u;Ѷmޡe\i|FFu?Oy0_VC7\lM]3{ ~jEG'$&s>~2#" %a ËrLNY]TrHkY eQEqYam9*l(g[@IZxfs){>q>H@_}}с(1%R bxk ;8L'[z5t:%뎜iD ."ICIzFNWp"=8n_-:G> stream xdK˶Y$amp^T Ė7h`cRz< {{]O[% pty?˿%ޓ5_{\ZG;[\Q?G3Z{gw a+wǭ;j|;{ pFߩљo/+g~_c9Z_??x/{U߼Oo_IVZ" *E6i#w+qVrF"yCg/|&n~W'bc|~Cv"}XocUq⧷?}[J}{8->1r1^: N,g&cg%P_!=wON5kd0%7:~['}v @ oM&[=,o_@pc`bYn}ocƻG뭳}/O{9 1w^o7;z0}{*W^0[~/Q6gk"5CT[5gyo b>1Ľ &n/F0q2?hsM%o#0q}5H@p\~Xjx*7'L\oKD0q_s$}z\O>: e%299`z?䦠x|3S猚WB~s|E @Ӄbq=dbOﻇ 2H &rpnas1L27fou1lΉfoP/K7Eœi]gNu 9{9ښ.$.D{ N^T9bvt"B9gYFo 4þLNH&/yh?[:DjRJ6 oo?7tS$$L I(-L84`|qp b +ĤOHLNo' %br(y>,W+t_wmIIF(%oVSz$d;'9 G'@3t'{'YAx½T`pO;;йDbMs7Ԗn<4kT!~i? dƌ GP>V+$fp$j|CNPS4E J x+{9' Y=:&KlF mPD~LoSMߵ|)Kɷ,:}6Z`oY?Sx=qrH;Mma)O1C;Y);D5!ǖN^, ߆CǿCnSmvrS!BhWNRے05utڔcJɧ&!#l˫HJV+f02\_eJև@JBlucpu=$%OZ%9W'J'\y4MKY#*CЋ8adj nj~ ۩+Xo Jo;؋&FIK8uǚC8ub¹#B9F:x @'aI{[~[lLL_sBȟer2ɱ} ڛȝ9CJʜ\Ws 'B׌ 7zrhjXv9wz8woVgj -8?Bwy70~ O8~ $4CnU߿.&T+gjuj@/hd6mK %X`_mZ[ %X75OR)=g\3 Ȉ) ] %%%GpuIId?PJV~r]7JDMb:a%L1̛'8*/zR=3A\Vu  ~4_B?*wBb{~;ϠÆ^f !ƻjCw/- `3l˗dL1Jq!B۲~;bɶ|S_`SXbV S)PNooR[H򝱡PtOacJ<蘫&gcO)4ƐH)FL u!dNtX|R@"N 7-=6\6t-4 V{&7$=N˃>%s>'6,QF{b13xz={Ǵ ?!V(5L"ᨚ +GbPP,ֻCVZa+7OFlE5 %CS~7S!ՎGjf"Gj9F+f&KMt?c=]+sI1%U){\S\7M9qP[ɱq~ g.j&ی {4j浘 {6oé%# G$كIg5r&!:/=8hdRչFչ63b^Q<ڏ :ֺ2]a¯"ƴTf|E#ܼ3 F|"vP4Bx)IJ:cڎC2quIl]iiN*Vϙk_}T*W|Ń$D8{j=Fxkd+SZx0rz xyG1"nX]JI멷,XՏ!a:k!醥i>n w#v%4H+?_fƏ!_zwZ[]G@sɗ^0> %gwOѥC?tfsS~ȩd?6;DLM$\eq*%! 'B!٬%cΟU*ӹ+Z:Z:޶s-CeNS(ևH7s@'O&[_tDZ SW,1D;;%;I1a!TJN*K$w;Y$qE>W$7^= ABٱDr!JpKm]JXr]"* ,wO"8 \Iy;&wA*[,%%N&B*;zw7 bj$Bow* U:!Iyd(gICnχ؉ߌ}]wA:N?BqdEqRU)i˝މȝRE1yI8Ϡl=Չ`@s@fi "4#!Ő;N,bqCnDj9g#\3[7.c-E 7)n?RK^j[w?`Ywj z V]TKv#~n@npT[ 7DP-Gs{kLqf3Lr&j'gÜDLʩ;q4WB@6! h@h)ׯf`H͙xsRO_'$@m@L>Y3mj+H,Cj x!U'6ɚҍN:Ҩm_;9S Uvu21} sފS(Su}G6X8m8quZmG6MȌ#7уPO pynp! m8mG6FG62K%;+!|l+.baED qIc&3|cС.}N/ԣh!x;7"=aV"ؚCEpfxsm~9)6|D9Ű@j(%9g} n%o0^;rnn4lVbu^R׺GTV " lwhqDlC<"ũeR<GOlj{;P6.~`S7ꢶm?vLJ=F"ג"'-KH`o7рx"|H˺CCr]s)HVH I*Jϧl10!}Ɉ㌻[N'\ 5gFрp>bJߵtA^["'F'ݾD)Oo) \pr$o\:yXF_܍#`ڰn#5fMB07RI!za[[0|7Ͱi9>@"pd&=O.,_.(U"#'#In O֊YE$7&Bb%HP nmv?rS 9BӔ tnj7Fbmy/D)YWNuā R0?;@HTaNE 5t$u?Gt[[z!M s5t$ɲq--423$BWD>pvo)\JP1PVM\.g㹟 RLF\@H:6iP3Ix=z-nnvQp'L]kӣ2`ՒLZS"vn[КCvcMg  7R—)eS͡0zjMdDP {FB൜ k9bh#Ѣ<,-H?2p*V0ѕ[L`Ɖ4B?SRzWCgԨ~SV"IUPx~sԌ _؜ZiK&N^\& kdEMD%7BB .>ݿZ TcF*zKw[`j$v!mQCC=hq4"d #B7w We<@M'@\r(!>ޫ_C/R)/RApp ]<-cjT{ͯ^aBN"Iq[@F8/-@-Td '$PnZfo 0j:&"J&{ˍXS t#j떋5s)`4KM^a9@YPL,/bӵ<`:@ONtnc2 aB 5,%YV&=QiFa{wD;J7 &=@4w>g[}yq*5E!1"9H7jD~F}-6:uM['-R#TIGB7Rݔ!F2M5T!b}8 tOMx<Dbz]>8śaL[+=% txN WR4  BrBҞ9 F-7W(=$7( s FzJ.i.?A$7N.`Y 3 M$lӿ$7̠㛤Xn"!OrӈrBP:Cބfo!eق|2d+ɞB1DkN}?ºHS;Ȥ"8DO.Z%uYH?  #m e]-ދɉ=%9,}Ixz|IvxM tDj_7|I+*eGڼF/9Y|II+JS]Xv]Mz"t%}SA!""bc>;tf\jL x2f5;u97@Xx<SWG3 5Rwe볿+.=m+ = @hGNon)2,Υ#IT$PD]hSd+ɞ~XH ub:JFmƞ)#\u)ْ-9|v7㝷 d#_t9P$*l7"ˆ٧SrYP"v94phn O )7HdRpbmdIvL#7==j)%_DzB @S"\Q_ 1v]y~t1t@DZb 㡋ndW{Su Gfcn(9CEp׻(O';N:."/*'<W:2f}9{g6^Yf/;ϭdp)k0t&ϿwjT}͝ yRdz4Jkt0fdU0#M^|kZ=$ lHh {( a@J5$J2"96,$u zJ\ʍ49 oZ)a7p[)ZV)z Ae2տAs.}|U:C/#(t"ҚTu ^t"z+c"K5pf\ifƈ3#(Q@>F~8@FҮDHLl@H5!R)?RI9&'כ)2/tNE#+4CLhCbcm_Q1^2Cq^)@pS- YG]a.M­\o+!5e`(Cl08?ُg!4"~ d5}: Xy djum(H,@h&n DR;4_["KgxGFKVسDgB4*#B\R11&-!3LO">fRMsV ȢUHNq0{ 5\3PN6o%KLNe7(v0l}%r2&E(tN_5%Yi~N:%8m8USOI ЧԶnHLOV< 5ht [uZjO{2NkȕsJJִB!bLns")'+熘-3S]J09K)r܋L@0mbK9*"Ktq 0&K5?EtgǠx%OƼ|Aq(d_Y+w. V])BOj9R`]-Uy4k7 !!Sڻ_v0a21&Gl+y,QG"qMR@$(Ƒi,@(dc9Juw V.Ңnf#]@г?/T^Pl'}#iMmPY"Y~@Ȳ ȫ򱪤ͨ) i|G&&t9(Z|@Ho?Ya//«E;++}o/+E՗3tKSVz;\~A,1`c,1ܭZB5$_(~rm!n3j$YpbѾpC=Ofۺ>Xn?ϡp\5ΐlvȥ wH>ơR`/ Ej\!:@-jx#;v3%"4Ͽ8D QNؿqy;(R-=Tb@J_O5,YJع D%-㬛*HCʄf !/ EVjCV))锔yBW1\;U_ֳ$'ͥf.!_%ٶw犒6R{*mGT@=?W}DmNQ+{Vls#;|Q儰}XUk~JQ r=g tlpDl \|"G"c!3ږ'rfD2}"}MO܍rYەq򚾪"x@X$m=WխU įD^|-Jrgp{xўv-:?EF^ KUβ+@J@8lo/MEn]ky.g' wiX~ʾ?lHTڮ˲*ɽ]wu^-_]v9Yf,Onr9WJs/-]]休^a_0:W6hw)B@!T;Yɫ4wȥ=C;>e8]r\oP U&5v"dW Ǯ&e+绂>xv%jP3DMR2>C7b\͞1P>oϫAzb!ɐ =zB/R|S"LU=챪+]0s|WDjH3W\Ȩ0s6,n3+6=4KH*n: (TȎVY*)UeuoTjykNmy^NnZ@6EOy0d#+D(krGEHbv nVZ.i((]cRH")"IZUK2'@g@(kjPK2ׇ ObONQLQD(gUKA/Vڪ"C1.@z.#}AzmFѮ"VJP@%vGvoN/buT eC2pݮ 00ώlF6rS_'Jr3`&p)D H=(3$(k<#k#[O?Oƹ~K0#aN|\@RU@۞g"g8 i'z *f)[!IToV*Ң/{7үː<$Yx- >=s䇏%_þ5_dFƘ|:ʍpڐ}f+$lv,eQm7fvOـ.;%0 "z@Ek-U2mc2ӆsv>.9(l_Vlh ˞9ۉ\?\gISj; D?2֭?w-E!Z}@NFHn{(NKz2((p]찳"pӏg;ZO|b~09zea t;HN?ʝp3G|%{G1]Q 4 lW%ߴB㑋!%F8ھwٮ#@xޕzRDv'.^{rY+ի)s{ RlmQ-&âhͯ%IiXװ(6i@^}G];S;]6\Uqp> ?BfBG@T ]|  NȔ4]v$xڮwچG;ױm& 5lwRt?!?mPq, 9Hte ,[{P&J2)vF {Oa(T{,+fݼпf>3R]H3@BV"[A%Pr;ZQGVq3*@3Nf UIb( 'rIooP*}=crܱ0=bgq bP34N1֖ 317y3VyЅSC䝡~dTC~d@C:~AUnRtD_H"ϬP^;vxCH zJd㤩9ԋ 0a F⟾D!{"Gc}4}B]?3h 5#C~?zjFVNa<$'AȊ!A/@b ]Kafdezm] _™+J; 'nl/dGh8Cv+:")6,Q@rb㊁̴* lZ3 ݗ(eA:ElC Jkx/L+71^S@0oj##9L ߛ`Hc "[Z;Bc3S<[d^C~BRwNڐ!!T Y\` p VS8.8#sUڐ,FTy ]Z\.Զ{FjCr:(axg29Շ Tf-6]RK2T近C㼧nt#t~TÍ`` y.3+18fO$)>\Jk/5J@`XRzN2Γܸz 0>@H~ldR#rl#ŒpDkYœvf`m5#$L.yb2!;&a F׼PR!^ `2dknaV|\,"9$mCO%|Q,`8 `q -EYEg4 ԍ 5"nR;2؜+z6Er"Fگ6WZ8QHVdȶiE+2VdHT~w_gm*kӘyP_I.u"ʏBJz~\5;K`S"-m.ôū3)dR'XQ7!RR'2}א%mֶ0R$ϙYwu#ѾK4wvj;ORXXHI܈G,QlCt̨g=?" u67ڿjGu߉TfgqO Lmw?!Y(\#ZT(P!33 ;Rۗ][Gp|͊߃Y@0}gC}ͱR72cTAҭY[w#Z ȲHu,Ɏ~d_$~d]i^mj?DXߎ~dվϭ~d_ٜ,4qHmw<%@ݑ>'c[z6RB3٫p?7ˆk[fہ[l\ؾ|VHl_c6T8mXg+_!j[a(͑?[vQCf7CoMrŗlZnj @~ >Vd csѨOޒyiV+2BYZ}l(gIl DTR[as6m". o;~ՍP8Z]K.Ss7wĸ#o K}|ρd[䵓_4G"HQ]"dՉu Lکpy} #Q'Z,Dԉ 9o\(4GȾEAu؆:. z㚩7<`T0yǷDYD؟ {T}ͪ@. R^𐤇_6GR6>rȳt>9n/}:qra Kg+>锔r9ax+Ggo+</-#ښ9}stdg' d#)og{1zq?PnT \w罹e* j"MɁPB&&o(}gRs!'ۑ j k #{'5xO[MT4N.d?譊X6}o(ߠ.dޠ]NK{[#,k B1W]BB¸Gj#W7['s?W_wN (} #2*H8\%CFR3ȉ T!nd_lɍP /InEϿU7rۧc8n u#ޭșhxnܱ1o0.D)d#C^"o)ky Ub;{؎p\7Qd+~fz ZD? ;ߌw +jK{>GU'2tɅNdxՉ DMK##VG3_cV- "OݠU6+.F۷i~d:* p}8WU[׫3מJFh7N穬n'+&%#vKQ rmh[p qI8PXR]aOp IҊOr#N*4yK'Vtm 9ӯs=Ї kZaj[FalKF&Boڬ.Qiý_Ў'. su+#tKaesW9`%FTȘVl,3/t6 W'2A7F,,wu2uxG|ch@Ȓ:H Ȋ*Kߓ) w:(,RKomF;xpcvމ0 xf>zo?׶ב7N"j8lE66sFۨY+TY%k7P fL¨%"uRh* gd巋^#9 5H+#R&w {{I!ZqrKRЭLUFW72D u\K`fZԬ]UZOU[ȑl l?8H1Ռ 'x 1"EL"i ԢvR@FlUP'vGU3r=k!G2'FKP1w/&B/Z@1IU#}\U6…br&m*@hsh&@cރ&ݡA` ΂@~s8w H9 #NLTjtpE'C< *@+ JT7 HD`6/q_r5!ۥ\sQ&dh% MlZai:VGMI'JBM&UՄ̱ٷF=;G'h@("\uJ|2 DJMR;ze[ՎƋ@HBФ[vJrG^!0 3A ۮ2U %Bm!ɭ-?ni[76!Պё/< h#g]̓p[d2-Oo-5#,3-j*Q?*o6s4[쿬ZjYX^\=4@g# #'o7P%Yi7k#/k60'y9]gW"F /367h_9ChOf6{Ȏ<rOhI#L4]ۀMq=S Kc9Aj nSWaA76rî%zאVڏ!-S.m%yy=l^ ba,FH ce%9"HcCqPum9tXر6n.fG 8&Z,'>makqFP 2wɉ-/=w|"n-6q3Pf0c6"}ڦ!u~l&rmⶇ'jGN,qk0u_H S7JƁ:g9NqpjgPXRPv"!V9]WE/{[d*o1u![#"0eda ]џa4>LBfE-{adWFS䈪 B!d$|&I7Յltaʕ }Щ?S= S|.~ p+#hmfR^BUJn䐪 n8#r2n"LlKJ"av"@زͫN}l0eyse`SgrtFы\+2\ִ{F#ɛqvN1܈n,4ivAc`^5ˈ͊Hp?<),WG8sM?Ig=2@y8DɴV콝G-#!9JU ?9.cR@&~(3ds|kD=~,U ؿlp- [R u()Vt Y  T %hٚ D,RsPP8U\5\Sί"e{V@0q(4r&~ bz;c(/C+N"lԲX-\j@xoK_<;2ƎoqRz;wkGl-\ˌ,k0lX+S60p:d)>㻔C| g ؈z~9KyP_9vN-e3"<Nd(VȚ;L,u"C̞7Mn6"CU+Q)VG0=fTa3}uFdWVZʏ>qP,Ei>dr#]X˜1K& hcIq~(gm[_٫=FK7EKX⸫;=!I:>A'9;+ +l/E}sEF)2=qL%Ҧ(nلVDqVv:R:HtƦݲHG$0m( Ղl][=rS.9Ձ YUfձՂ .> Ct[a5-‹rCLn5!C+Pl`/ZFTD2ebA39t6CjAFt ZEnj Vu!n$ʙ5{0Po Ƕl5!- #{#8o&'3Ȉ101sr˙ױAg|(]jst"G8r/RCvDj{}V$'R]ڱ n|<"g?{|ϯtDnY3F$]C5|&>;Cpc %NvH nqȶirX| _σm4jfQfsƹsIdQ|$v+6鈔RL?.FH~A8WMvلl\Du["elپxf{w x 5r47ۗ-wܶ/N FZiHkHdhF$CMg"u@b cb+ \j@B7jGZY9J$j@Pj@6UE6 .kǾ:p( gnV^m^'n{O({ZIXFmiQ[j9jG}K?v2)*%= D~PH }&(wN?WDXsL?[Bj*YtQ?wƚ ~Z*t-]۰T3P"*y7Wl;m#"3*Օs}pxFLQ&hD(J0:fZiM(>n %jB&5֏L ]C~[sjU2uv"AʦDH(Ҡ {(Dj0(״!Df`--FbHlPށ{QfxA`O^sGV!r43I^'(}h:Oi-r"WI#gK$=(@! 0&:rl?CvY" 'q"=[j-7V#ߤA3>^}\*+SBD[.Hvv|Qa EJ{8 )ɏbk7F"L+m3Ўf?' T?WŵzfM6ka ٮO%UJypoa:s7Cۦ?ؖLE#BRi%5EORk72⻔X<}jCeQֶ n#*y,a8Ȋ[zSwh*Cr n ("ȲDZ(&H~ G*Dv0/gyjC۷Շ ։~~Xb(\pmFDXeĆG*n|3&IDsGUѲ=߮mw5܆hGfU?#hJ39%.zAauЂobe>WH>z&IMqD$IADZH>9\-j$TmD7a9L!UOijC=J$[4%gޣ[ƮFd.#CD Շ1DMja]})摈>dRec"34?r[u$GDO 4"PPF0.?>ÍR9c@63ӌ-׮`m@b2c9ܫ#Մ,wH[ȕvZ_`"ѕ>Rg;VEpSrŊF8UHwQ #MIbAQ^,uk)RQ2ۻ.~ź܈ODudr]6\a~9m? :J;r!ex"7w帻C%r%У YX}ȪI}HV+MDA%~:N 600ԈwO >؈cjD.-(r"Ǘ:yӍ(8`ţiUUN)UNpT9FONgT9γuT2UHhܚ944-An 50&4$MM7}]$@2.?kG\Ld}|y pzޟl77PEbC .GII簌)ɆHDK)z^~r#j5'\;kgE~F~0d);U SVdh#,VRGC:F#jcED'P/U;%;/vH~VmDrvIP6q1ȇF3]w6#>1:۠7EFMI^ "ۿXF{DOj(ѽޒ ]!&po\%pN#Gj#3A5dD9W3A@$E/C>3ɧXnrbQγQНbjQ5"ͥa''oF{9\!` TP %BgR=}RwT`V$f*ܢL&Q#l׳&2#fKKy%Yc$ԛ!$jH6%7i E=娕 #dVMr!jW#ijkk*lUysm֔sHF.rSQkS ֧O5$C\\jHd'yp*}^ݩPD7JN#Jo7DtCG~Q|M|On5y5zTɎ,ܻZ[\⹡]JnG7'ZZpu1iCۊ*ua #ɦ?YsLZJnuzHGIZ!K5Rr;d|ZBȚVd5 ifF= h2j:dҤbR%G`6$)XPBw6!)=3@JP`yKO!Ua>B+J6o5Ayc6=Bs 0Y_[ҧzl'KrBA2dϥ0[p؇ֽO۱`XGôV Ҁ;B3bnI֎fd[  'O.V{Yx^psxQ;|J4AsO0pJz幣bc8,ae k\GymzkaWõJsS]%ϡSUpkyٜZi{kD#뺮%G+cA2u6Xo⭢Hqf;M$mMO zoyFF"~[#x?t$_YGadcn8?su929 ˤ#{EkeҞY0lQ]YsBm_J=5D,<Δ_;2:춲?O*lXJ;~NC-zb8"m|TN9"R[.R6T 8;KmYj~Ezvտ`Vby{T[!p9˷ )VlN`"ގyG@p+jrTWˇH;)Li1֞GC=,p4s.& J5#/Џ|$rRSqJ>HC>h8WJ~X 0e42Uogٿ{ާ$3 $[dV"NXh;i\%DrmmR\qTSU$ٰ։6O-Wd =mC@!6u[iݟ#.Ve(M. +;jst]*RU{%l݊QWUv]~Xrv#["I=P5׺$"ϨsUFf"7]jǯ=F"7+=JqkF`Ķ5:\撑rCxWd?W) Īa^)_]-\yH"?(,9D4r G5\ؒ#>rF̗)t(Wt@$EԀ{Us1b\!,;x+"W߷H0. 'i2ƨ=G7r$Wrw4ޜK5Zs8d#PLdX ơUDȽS2 _ l('jXMoCi^)F*gMYs@UMS 6.]ro!̕@NLѓCFQKa=FM %chDFnBd0+]o"_d,{)kBE' o/ s%&8+RF@h* -{{ws棁嘞I!s&Kx@( ^*|MogDc7b>IJ9C`~ |v# zx4ƍ~Ԯ: lN`"@89u57 ԕ#THvhY8yr ]%w,?_h2OHrUz)M^AU8ټ|+j4 G9 vF?\|}J};rT ҷ3 [ d5W޽vO~?T,D4{%ua'??vRɔݖlrʸ `;^+_xȍ7SΜ} wڠ.pevk '{= 4\^ Ch?.pڬd@V퉧U{'r]ȃR:KiQa0Sp[o oM!eX? S:412IWDuz)\]T7}e{W闯HEauA;1.!B ^E4'\\S6CÀ IR@O̢1!2b ~lPʀ_2-MFz+S3FIF[ ;T~CBOжt@ j1:m3pڢg3tޡq VCUFS_W;1D[*Bw{Ud jzO[`; ,s_ lzJ*zDY1D,Rc逬۽AjAdk/L"jɽ8Ӑz7e%#ֻ~*fy~Wp6+ 9Q{֧ZJ7_Pm;Ƴ~XNySfD1h@S0pd蒽 |krfe@%Cc6l*n`ήPsBO]֒fRdMIXQؽOr?4V-Y4rS=LgNCU`O-IˆEw\Al4}.;\N2ʞ_^ef'v.2kZem^Q&x4N>)jAZѨ{` \;ơ24矜 Q ҭ|N-N(%/31@oq8Azs:aLYٔegRTFuUkHBƂi@hMҹS6ÔU!O5Ȩ}h}ҽ±Z7e>sպ̐9nH޿WbX޽#i*v'Ȩ~ a?m!mp$]ҬHՔ:SHxkSֶqbެGŔ=omɛ;brJ9%2dGVPFEۑ,oQ%==wsK~oؑ'Ֆv<޲-tF]]i_1|ΑvTECg#~)x$AH >pcD8_rpAAp C` +߆E⿈[@`zsMoқ)(Ao93⒆޼ p໵s'| s;?9"'JhJ@p0ICD^;S}"2H? _Zy plSb\.&1\TD臘F:.^aMv$>[q!E3<9 U`˷(`H@/Rr@Qʆ#2'=2l0aNiЫ<@@)Le}d"pyĘ'dx>倓T&U9Lw 0,EL@dzAv9hVf b d`#40 -W]1Rw \Kdx\EK !Ƶ[-R`K|ΜĘ/mJZ]L?nmL2?j^LCjR9_ lh#K޸LEZ-E.ä2&-w#,pUWitiO~^FN]0Gk=8j%URTנ\*#=lb7r[4XFbI>bc;S 乤$yi/Y|^1}IN1Vb7Kn, ~ Y}r~9Q3Ӫ䓨 N3kZJzt^ x^#fM AaaGݖl);{JkX2fm@d4d) SWߖRR)ۈ"8e:`htdnʮ谦?EF|)eMgJ3|Iu꺯ܻ.Ks~N|DǺJİ2,KgBR@VF!VK@4 H_'e*,պy L g^m0XЖjRԀ6%8uJ' [s'Ū,lH@vJwoM|Tul[Ie@^S.ಗ=<8 Sv}_oK r9VN37_#,^iW"3ĿLMs+lJv~Rl'4:pqe\sv^iJz%-O7mvΫ^R bpO :Pzz]^Z\^ ljcfnոA)ΉyGnc/oɬֶJyK&H+_B˱ x\lmIޓKHyjSUޮrDhD|%7Vk)YYjf޻FgT*kЙ_.;ZU ي)C1TM|̛͘;"p\&b%zRC3 ($؝o4@Ÿa)msSߊ)']1eҝi-Ho*9~*lfFVNȀarQmϟ{2&xl|հ(b ZoŔ@[YZ|.66@5w#@n<پwO?By4=f#)U5Z0v-?Gn,n+T#QF1 o L6I__c2`~ 8|['4HOJ>G6%h^#ij%-{*ѥ *`V2ʖU@h0O8T ާo:G!e|#1w do@ gHY{5 {R u3k98̫ #Q >U#`#YE2HUzP3=\_>SDqB;h.V2N&]]߰ڏ0H;23ZI޿QqKZ(!L}ϫM;OkX⫽)I<' D+gG+{;';ƕH+*Vm)Q`&#~QNV<<#&`dlX΍[9i\I1) چch>̝'逶$-5#-huro_eТsUFH8GɖY*A_'H׉kv_a޷&D]%/ 9]cZJNLFK,Z}HKEwO5#*H=ƕq!ո1%z) ]ո% dGyDTj'3c3e}\ ܫ|;a,XU{w WI>#.v9X##qR"UT7[6%z﶑^%׼s 'vc_f M܌,mЬGf߫v>U+2hj\CAemusWeبAHkWKԮ"~0wC{1D"Jܣˈ2mOb]oiWT7rq  &=0׽q'N޼Om?>JNOCݪmӂb!Duv%y4BXERC[޺@hToM2+ǬZn!ݽ4 l[BlK -@C IZ"Ԕej esʶo&Y^JF5kˋtTzotap::<+iK 5>cc9S/,*nOe<9te+3'H"8OQhAC\:%w?+wZN oSej8y(w; }GN\󳪾LMeYl|cӡ@v˴? TTf[ZRzrPuK@n9'O WL̀t(ϚYc;Ach:\)rE[t*bz,`H۲[ %@SD8'SbO (|D?J,CǻB?J,{bBq#Ж%W_I݇Vtn]#JRr WѦ-!n=y3V 4, + `e@&N_?%(s3ȗ/w$SX|o8 3Tc.Ql d(CeDIr]&\&[/#TUjxԵy:?)GsuE4MieOX7]ҋZsAp (ᙨMZ[ ߏuw8no(̽TS*g,٣2!Mw%mvda-%lKv@Pqۧ"3lݯרMDIӲ'$R@זp;nO2 Ƭ륏Ε+L Mn@T5@t16+YJyM#ZDܷk@M fL\Y7R~_p.Q=n|U@7 i`I]ec#&3ҿz-JNab!\eC Bd +fRf†Mr6\ TDj!l)o 8˥{OypYOgz~h@hԀ]OƊrw'Źߡڥ=T3;̮:7r;H PKWOߟP]BUv X-KbL'jv!Ȟ9ͬN ϽEMZ, 홳"̜Gw֝MxJ@{zِ&U`kt_<]w $| AH<6!bzp"mN5+g>1zFpk' J,TwpQU64U!sS0O>uj[CqW`٧ '.* L{(&Fiw}&Z>rTfNiޑ]÷H `8Ӆ # M7c_57 e RPuki?YwcmX';sn͐Y%{dQdṳK k)jyr*#aC)>@nk\3אe?fC8J߉Xf]ef[XXO]mBD^4ט#D[ UQ=j0CedO9Y@xOSlg?.6uy"@_6Cp!d$J~0FZDVJZ5R1@Ӓfzg.A&ǏIPx T͉:+Cw>ˈA `JZzA9f W--G z=CwzcN#C 4,n `L3smuD dfe:1b8*vaiei6kΈ̧cYK|<5PxJ苾T.hm6RuTgd)%V@"FN30T(Nߚ,Jc+Hu臖z{HdݤS$WZұsj(?TA2B y3HP>E˴,c]ˢϷRqJFQq<\'Uǐ VһCsmT޳g}J7NFTK!PSr!TÁPSvLW<@ SeTt#M3 fʜ,celXÛzwY:nZGe+Se0NI\fn yHу2d"@hr%Q?8 (7(L=Zj]7{坽l gR2 a=5$g&CY08chI$5UfJ&Q o*tß*rG0'-:)t:`N`Ox @e89,A=YB9ZnI5DenʈwmD /thF5b-)iHx* -LE$pt\"e$B 9^PP!{#<:$5TOE1n~SOIDb"HewY;=4ȦI8F߿2^nݿp+&jrO1gLt0 !aPUrl@-EpPus}?+%W8@waؽ);?rU8*(nV1X8WLoy^1c 2r$. Bv:,kE))cm ^+^xS=xӠ;r)>k?QhX[2 %Ѭ S Lk,֟|CѸG:J-cU"0h7US4'ϺRW9fwǜ|ʇ3Zj)ȭ/QΪpgEقRҾ9gIڹT3y<&Oc ;~E @Z4CNM}]?*wXA0tv%cHHbZ>$M "NS擩#vҿ#?T@zYq-KuYQ.Ct*b[.[5J fo |]F7cp.'PSߤ24y]jЪc%Wϟ#q@H[e$ iZ~-t.Y:A7sW=㻫Uxh1l_WBVLO2d'X,S H9f5I1r:C7ObaO3׈O{}%~+d3BK$@X5õ{ju-{_^JIiwfܺ7Q Bv%~abp{9>1Q4X@T"RZ23[$-#0|p{ƬjZ%]xzΡ2 Ua@Hx%r߇ȹ=U:MD[ߘ1<./]>!WPԼQK#)G񽍰tߚ<~`q8]qQ{V5EtQ#nY,:{lx*mzϧeC^kg6@8챝 + O{ouٛ$F8HvKؕhfd).iSrNI ŁPv`7G&S}6p?<0m [own\"y%ܹ:?{zXlvWQΖGyJ826sVl6>p|-s#e-@za+MK&B%˚?'kF?if}MS/?nT)ݷ] Xo-o^-5BR dv<#CNlH'o@TMA(n ɲ:/33F-`,伀"@x!^Vt:u ¹Ί1o{~N{wUh_??wm d"'~@nA]Fo+SH&ȁ3y@X,=kB7FfrE{K15C h*fY82^G# A\MQYo}ߟg:N~3׵+ uvy `|Ŏ9MOWrAʽ9M?v7 륣uʔep0ٝ WcWp}Icˇ`ٍa^G1'N.r˾&5bĖW<ߗW}%^51lўj(7R,ǻF}w DSIb:yX1ͳ{W LBgY]xl#MwFnƗ'\*?Ӗ?uZx +KO 5b*UL h5I*Kmi$c|cUmܯB`^cs,!%u@X5;4[ܼ>M_dy>?G@8P^ePS^ @˺Y +L6"2W$;,O>z@,#0gbzDcNnHtlRR3!-kk+Nqg䇋Hvg}JJ K\ U{:/v{QȒw *!]nA>Jo9J?R'WeoΣpX~ q@7a8D#/r,ٝ~YM95D[𲯁E9֟=a39^"(PF݈yvUJ\˄24W~h{Se@.{׊@l!G>>yL^uH-ǖ7$yh' }+|nM 'GtM"I,]w|U<-ªTGY(j|=VT~>âzđtLp KEp(ǭCn,bkGNҿ#Y~((lKxv~|h:#j^-*ӫH^Bșإ"M JzSe_#滬|2rdz}a9h*mKX129e ; Ĉ#rlek>?M].=U2MF--d꟤')s@3UQhfkXY2y uL]9|UV>5tJ5*w8?Y~͉UfHkDTj#4 HDMMnǁ@dTFQj7L/jyZYTd?*wϞTa2K2TL o%ŷGg$j ozSeΨTz O-ipyWnET|,Iy§21_n* YZ~?_6u@ 2MMg_P~ٛh dMo!*L/n4 bںOg^sZBs9côXfbdJG򜄄3]D Hy(H!eT4.M>zo֥z7 êTF%g'*mKbG'yIHBKVR ,ջQ֬yWJITg{ 5Ć-UZR KWWteoTZo T NS~t+,ٸ\'G+QCPf̰uC2= KAV>{)ČM9p~UId!;9d]0 9q%nUfyaͬ=,$[_ql"h):,Ž/^w̑An|g>X&RR7?T˫%<<6|bwo?B`?6JhVDW 65o)T![isKm:&ؔ/Pl>x@FIk]{yT)sxt:Z)ba8 aNwmd Ƶ:E NB_ SPcֿ9+Y5LM}_nҞrko*<]8@> 3jDavnKg/2#`YYN2@H/M U ]])nQ]C enVY7C2EzC3OWe%ŎWjSmwSYBܑ1ld?O;{UFϓ[?*7Z3Y)}*V ֕PׅJ$7;)iیLm9ԦL 1y>-7pRZ<$I{${ݼ~ Վ@hPqٲȪ1rT<?f@:iCi&O<բfbϑ=FU|qp'@h61$:,4Vbv9%gÿ{ 2̥Yyk<1Lz mK޵ {ulW&LQLWRfziTRA<@k<*vHNMSy=~ݣvThBpy$_J[p.ڵeu~XiZպBHzi݂ZiZy ׻#n 諂 v &_]]ɔL@''y~>E[]J&|N*g94UnoS"3w)Wp)WlSdj1rU./ÎTq#T{ϖ;2Md>D)u#QrD"GVkTM]eRc6m`=~s~{W9fXz !Q :a<|̝lK "ZBo,{3E -cG ZEҼ5͋;YUB:^{պ Iߩʍ%P͐WUr4^Vn#oz}VAQ 3w_WT@4 PΏu1'2V8K11/[~xBY{a6z=8A2zN!\AĬ%ˠ%Uzơ^Gˮ.uڟ$Qa.\ŗt3_1'̺bpSce]"HeUƎd4q p3#;x ;^mN CPn*@dWnDYuU\FXyU~MT\ޟ N?H{-tM0p@ DM$a鸀f~hQks oU3 D??j/ڱ,^ ʪ`vhS%j t*/ଚʀNi>}.@=F( ҳRj 2f%]^鋦~%GՎaqFGf"G"$٥j!11ٮU%"ron'g=~づ"(T߯9P  R=RrȻҦLeuߣ*j?+OpRQeH+Õ9{ rk@fgμ31GN'Gul>L# ys) yrg)-gV֨9JX.vv]B-;G{:GQO 19_pX|\ vU ;GUyewl0k_jS|s;4IϓR/qK=Q_յfCquL aoZFZZӺ}کpЌhǜ`U523ݚٟ'i֢{/-{T;˺6;'fntC"ER>`bl#ض 0{͏~ަ\[3yx{K~B{utJnZ0*B  U Syxn<) p|!\M"=[i #y`uflѧ N-2e|`;׍.N_. -2k洫j@5ؽu\"B/ƫs6Qմ׈ʢ-VY4Ы6|nH1V*hOs\Ru?Y<@ZL|棺SuQgeћEGK }c׹*ke0s,qHå9co4qUA-1+ۥaʒId3dN0,k 찏呬) }ašv7W~HV(;Y5h?Q#9UZYyguGUP1{VĒ`xӲurT\yk$vHƓJ\‚BwfNP1M| o%1=H^'nygo@B* .`rf6 }SMOUDǕX6eY\x2˛w#dG(g $0r"8,#]t{( 6!Y$'}K>ʵ^ 7467PL<ܳ+?An"!.-|Uzݓ D<7k܏k 5)IsN*ʢ^j5*yHq]M5vɧK>2LONd1H~եuG_#2|H`V@AivۥuG3.. 3"K^ZРHB<4O!Wqs #'@n'_AvՔs(rAZ;_*9JP|Tp(>b.(Lc=O ;({x@vuοcOY߳TmRbH %ғS#Tj٧1Qrt/aG]r lL]SR B}2@(& `o1Z!I<+RF6JYZ\#@6]23PM}lT߳k+LׄJ-~yW=>$C9&Az@U%6=jo Eq6|9/349tRν Ғ^=T4c.+&RoEwj%:UFʧh<= *LlTE-;~.Vee2Wr9khԀZ7g|krkޔ={JQBNyl:fJ4K.[M }x mU7uhʚ }1ff-;#6ʽX,&Q9DÂʿxWcoblNcB0$-ZݔH3C-kdkwZr=e 2nc=BRoR_뭜 7h(K@X͵%gޠa~96+AV @hE*-{UJrvK04Mr #dO3\xˮr9MMLVܣ=25l|S *{TB@8@~쥼2գWz|P(]3pY*o"um.2ŽRR8[S%8`Gi]|(&s3(TK4vkU$g |]|]x DK|evy7I rFk*u#ͷSnF PLKry ( 7% 5`.U:^.UQu}5!*VJC" Rz몣 v}:H%p)lE3s<.}u$/14*Wi`@RWkW\cW l)}V\ղc{WViWVc=` [T- 4UCҞÆRu*{8-i݊+COQ?)e ɭEV oոDc$ GJk*qc Y"*KWJܐ}{ 8q1n&GA[XxJ;Ot-Kaӯ̢c &n=@J̙?sԲRb۹-F1P,„u@۵R?URl޽r""2@}+B ຕS6ۮaN(+\];r eVN}oY9]x_A-uW7y؆E·8B7 y;#s_MyråqǘY|" fcmŕP͎ksyΔp3Q@%7oT0O Lnrܮ-M[s]-9Gd@sN @,I1Jђ77x LяѱVHH޾~73}[^đcj%;;9\Z|=%\^xhQB) 6=b##8uP6{J`|110vP4B5~UXCjME~шtr $2 Ƞ}[&i[R+ym2qEVZƷ6ص'Й~,dZcsfַ?O@2K69lho@/RU}7hGnp{'n u$ſ9=vVi'|{Mli@9]?@!eDU* 4U\ئ̬S1 e 6ipGp{p+l+6&ľAfIkIwQuF SH~R%bayuiPJeB=pE2)ۿL" \%l=u SsN%][_,?#yIl\9vvT ~O-Ey@F46*wZq_ڿ'EK Sjr i>MrԶo~a\%~G.SF^S)S-6ƾD!\L PUgLd =HWo]b}xSߙ^|G>Rr}L]j T 񖲽ZQ0@X}LB(:`7ls}LBEϹ=@Kv\hs+:=J12'Hc@:,q߇U'C%/ 26ug.y)p(@jUyU"بg> Dk]8y$U"Yށ@2W6$ved_w#Ega۫%S&վQ#@6-XgzGͣW=wqd'iu;#UYOR 6B|{We<,jCVûڽ1rn#4o5'ϢhS*j:fwY-\TQ9!堼4?uTҦ6B_븤Fze$SM:m*>M/!A?l20~S{뚷Z=SazЦ@ekiDXhc:%',#3<Ug=` u;1S~S)n׍t ]%Փc("~&y@vkk*k`JgbI>—B2K C[IUN"O@4L.dP=Qv.8 ==nCUSz^9/i9[km̡ѭ& ~3fSmydogÖ0l> }ĎFũH-6ko"pnAɍkW吁7$m/ b6;ݕg Jgk"A # K!4g/_I@)Gn>DKp PyZ?U?Bd ԕtsflv'wt+mWn VZz 0(8 Xۛ@(oeJ4؞MOWM W"XV/oPk;?I 8] S۵ S ʞ|_{^Id"SF(2)`[Fda+luYsg/@n$Xl+ *i뗞nӯC'^)%HCڛrO+O-QW!2/,1DΔHr +Q=@8MkD7Y ̑;ֺ29l5#hwU;_7+%F 0K1rBf[a NNA \,NMn_-=]cds|4 "wva!{tCSʿIJ\O])d =2E&9]jё;8r1PI4vCdnY=kd]ߜ'zoa2߬L,9Η 5n9/Zg;7jgM J=HO6; gfe:k'Re"R`y9Wip}4~D :o;ZݼF[1yג9\Uoq#eRm>^ұ%GxGڏCrerbzm" !QcHюhR+}4J!;/x9@08=J!C*s6SѢi9F5|2_ ,g-=s*s,Iǒ:N2C0!}2v]Ԅd<|vmRykkȵ5Qaa_H@vYn29ݯQm 8B֪ۏMitMm4T@ȯͫc-0%9ԮGշtϏϳFF[#~da/ &Uoa5;9H֨1jǐP,{ ?cŅCn"UM)DžqR T8Ms|ߌ%JS=S?(P[v@Ac|;+y06IhܫS? &̮k+\ [1t ԌHWC攮sBaD,]9fڷ PBE\T}۷N G,dp6'X ]ao-~z[8UFVVSmPMj:KU RE۬ @ -4(^* 񨏓ˀP~{ȓTY0^3 : W4O o |#K޷W6oOBSjVs'əhN[Ncz9mDczȷnV~>rRNkz,+nv[o[pN[|^ISUL`xsb۽-#[GR\5k]7Riky,*ېtT"T5Ő87).I3&Lc)yGJ_ߒ'Ȭk`5X缛zh~ ?MSlxHC,iǹYM9YLy< :P~-T#RV^#FeI[K#*CNMKb1|QPS\`hWe,kH ml$\$!>SEƐԎ03Sx2JL:8^mI|iCqt8G.Kݚrה9yJJb lM*é<ѲT?2zr-ڕ߹?6xJ=Y? @^{ľFFZY2-aSj^ Fg\;SٞZ,UIJv #_j?|uZ9ޟJ ٛtKc#_UB򺖐=zJ}jLEp+zKP,з;5:t3{ s쩄Gck9er̽ƛ8lhٌPxXHƖ{s4CVƜJwԜ a\ܸR}K>SS[(I5BJRU|u3AjvAzIk,mTSv/RRJr\fWKm;N5b풳Ϭ]U$ͧX 8CJ(1>^OD{|Jcϛ.%'=Dj2b<ՙߊ9H"8YDZoF}yjDocD\uTVɬ{{KZ\X?#.Up9 #e({SG#jt4cUi[E-M{O]i6}Ni6ߟsR? "<\%jhDjSNM۪v˟}z-G%foi3CҴ)kڏֱ=yUl[TChyS= 6vC|cj┪+ yOeҧBȖmրg:CɥP YHr%Z$gCw*rȞ5Pyz .񵟞*5R:GʷuFqU {-@P>C;SJ ~3/"fVgrOIə% ,n[=F˧A3wEF*VHWenn#4}Nkj|wνY+];Quutm ??>Uȯ0GA?M۪ U_A"p^ȭrdmBܘ UFIEoOI秃]o!^^hpb`~C V* q* '* ёp{ߴ\My:&wM";E&rhQPԲb}PU.Y5>VW/=%\mes_JFG7h?|+6^O]l|UvWz@v;wW= Rngbh Rn+mE1j_s%m__ygˆsI)V\qihyn*ݴ?Ne{jVw"ͧX2mFF Xh<6"O_. E O EKW|&R>sY2vI*k x*lYd@%9O(aa ZqQcAv@(GNB952ENŠisfZfJ#F ݞ/ `w iNj6 ['9w|1\/4# Ё0-i*aUmOo^yFU^F`[&k ? ȜA3I lXw:0Msk=Uʊ\kx$L}X"(86K:`:8@VdO|C7by󖲽vGg^Q)MO12Br'6K$IY0n䰹_;v$K٧x޶ TLLWC0DQr_Bd739,\Őgt)'c-Mw":/Ylm9YcIB۴Zp1Օo&6YH+WRK: Z<%]e ld::pK(,Kd11 ŅyG5)U?rMTg0S C"зO .oKݙ;cCB/2'=_%R NKƟ+wV&6I~Cg+9f&iWD`9,mss"h&W=1{?"SYP@ӭb- O45wJ5+*Je[!!ZjD+uT&ղ~=,/_b9Svi_3t[2w[:4*Fe|SیJA{M9'cr*r0-2vjdNQ?Q~oې>OXK6aIIƎʷA1Ns% V4m6K]uiFP0CDr{v$?˶K;eu7PVˌJQyDa@TڪHx'u$q ^jHV/z\/:e2Mig1`FH֫`"hX(ϡcVE͡ggCt#ce0;, 3o" z-:DG u/J{K@ޥTWqw89K2Q'aY#wÃ~hjÙt#Q 8Kٙ*9GEU>L>lی0x7Lvܣ&dtӛUb U X:DƤ>fSa PnyW(e) $6Yhv%,ѬYMdi! lŜ6RHb,{,9 #Pre6mH^ D};sԽХ$ ͝Smk<(vG0x[joӊ-ur2@ׅCl4S2wߵһw-5؏7i%Y!{f( 0Bګ8k.]nŒ$W-Gvd7Mn[#,ȗ f_s`? w1U!Sfti[؎ K00\/sa=lE'r9󽮳wG@'B=g]bNO T7:}*&- S xMRNk3*&- 0L5^$6D8I>ӭ7Le"IrLP?f5Oߎ/I˙*|rYo]'w&J`+$\܊9cDsL$K%ڗ.,ShaD6l⬙D-&?HtFB*ݮeD=̂-&*f):&Eg=,M(NQ/S'6b`C5 ~6GClWY:Oy/Gqsu["C#%lEAU5S'a]mss K&rO=)ݫ\"}Yg5v7s;CZY%4#LgMmQj*Y:?AXfAh(taۍGj>d % МI( ,K6ـ#KY@wMnD0 8+؇lzQC2@(ͯo",#f'f{l7:IgH~ӥ_o4"˰1HEY%Kf 7 56"vit`(tՖȢevu=Blx @9ަ[vuOZa'DKv%ΪD3Һ(]HQ[t)u[s_i"xz㻳Aog?u<^fQQrw?ݩ(0#.>cJdm.To}˺,\жn&}^(ݻAf"GE!a@@Ĭf'U. kUD(uCY d{*4jLA"Qbb6<&Fdt0B |Gوl &&bvNyd;>or:DGNъM{RpUuRۣD`n{{W%!UXr~%YQKl#E"UNfMr{R"toB)kImm.!fsD p@ȲT2=oR72AW)WLbf# Zl6"5.6eԆqY0ށǣ$*ufgA"ekJD`\hh?ϧXrCEeKY A57܆-6rߟ.{u>O~>="mDtBnudǢ5 6֌ Agס=1w#!rU"HdYGZ"㨓@SlL{itvvds$BE:j69Q Hݘ_1eISY2baֆA^[\w{r*Xx&VfDŠ-W~(8oP$#e޿![b¥n F6 eKĂPzgFkϧŧUQfm @sU`~v:N=䳸T(ӯD) $gT\a!}@Ymx ۙ]&^.p-dG UvfIAUđA잒6ح:؂>H(e`n{pKmց!Exֿ%xN$ҕP4Iq8lI617ڤUkJޗGAGDFz%ȈMR-IlK564ѐ<]6'Îd$:j}ؔ,uiCyД,?]<)u%+["Jv"md#UL$*=StQW2OB/͙*rqԡ={[TJV]IOZRN]Od + `vkn2VzQ &]Jx6F@>WQzwP]Fb GƊ^zV:[z=a "4Ji YxAڒ70/٩$Qc(2HO!݋Z=lM)< A|^ͅJu~؜ pT;앍?NtXYqX.&0R7+{؝,>*)gEew@v\7 p` S:NO^Ϻ0&jA#D%/Y5#͝U: /4wz0{a-nR(:^*mRZ._w?YdtgQ$U!`YVJLKc֥=9PɶmͤӗڿԹ"c4zٗ,"˫dWN$zSd,1YYf'o%cW}>F)`<[2G-d{w1Y5' j@  Zk1vY m! ˾di2иљo9|Օ yFU|q8a@+K; p 6LBOR=*mY+GsL5T]+r MVR8 z-tW[Eqف.6BeKQ\%a7r|$p5G:ii[8(tM*Y*azx,g/ڿ~;ƣUs"ǔh"Dl~kK$_DN?=-g{ATWäe~CbP$—,d4SqdKɉD`t]ݤiEn7#߇ 7x8E͈.N;?mRDpQ_P zgYʠpwI [KGi6AsLp6?ܵ'Q@9y.ktU"1{,lփƽag2Vw#I]3%2]V&ܗO{T0L D-fgZd.:fJ꘥ .Ux ][ 8>N'=b[W>$2M|V3ƍ-!9.%o‰@xvKB{bROן ;jO6Cf<((N@Uީd-z,}L[Ǿ `+VttRI]׆C6Ap3DN#ǫH' n$NAc8B4K6 OeJ?o2]i4ٕmو A4$G[U'"`V#O[D#wa3FUmIiqmߞ9AlH{v&ޝMK»kTlZ `S0}t͚7ÔwL kB9^L6:c+ v=@nk'KE)jא!Orh>V #?VP߲\j&0зVR6JQ̦BkC ^vRݒP'8`wܿY"!v{MAz;SūA0jfI+wd&@.Na2J`a MLMfd~0mυẛ% `LsGVp{ 1T6#OlM6gwiZ◐ɪt*7gJd($Xn=L0)Ry[~<up5'Z%CNj\1+R.pP ꘽FI};: -U~4(oٶ#rzw!`S"dHJ`AE`(p'u\A%Y"XAYIC\\NH|pdE6xlYY? ts:X=<]+V =Ir),*8&?%1$(` &4N]ǠxzK%Ůu$2skIt-r =rW3[~U r,A{eKA;U%FyXqoZUL>-cJУQ"Q)ª\"(6'xd|&`5 4qTjM۠aoV"~dA*4'K{i&YYգd$e&0d C.:&BZtRiC ZGqr͍tQX@&nmoߒC5Ct~Fj{Z#{uDrI*&04`㏚FgqRn,wz:F Uq,w:;99>҄ nԹud2vlA Sa:ճL'J!F$bJPꞈ&C;Dϕd#69O6IɞZ8=b{B \c'Q! ʦEk @22A٬@TbD'A&e,D%-0]pG ʞ9ׇ)Ș!oUQd3DxUL"eue5\*3: u.mdBAK]cGDhs]Ks著}q?-FAY%ǝ}R_Ti=UMۗ230^v1vNdGu&sJdJ׬@厺kO3$J{oҾL!/Z( ;OAݧ&?u)wdM;M97kq!s1Un]Ek'D{wݼ4`A1zNHaGûؚx~B&(Sw+]VgD{ҥ$cn"KFZ Z5TM| OĪҸO"/3Yn8˄^MQDAJa I<=@ySZݣ;o ! 6rN@7qgbdPOL{xcZH=ڮ %^UJTҖ$I )j ,2y. }}<,]jӄ/VJ)l/x"GnJeǡZ]E 冀#]&HNSHP"XXq@P6yX_Z$j,OdSO&Mɪ U>3_CmoӒ_H"2t:HB;ũ$.\,!.\$sGw+L˒G"뇖<,OM|ly OmH>|'c`&>]J˸PCQdWםKujl#Mf! ֢:ˀ&-uj",뢜/3UrA&ަLUi7Qgd/7>F>EI3Yp>,io!l`2Ӊ@&"] C׬22?ײMdZq>QIji<v(V%+q(lB,fw̿Ɖ@486߮]MdGz4[EL7u&aP4B $&99A׺iqr؝m%0y6!׿Zn󛞐+Iٞ?,s ??=jg >H~B;$1=H瘞9I|e9j,{{>s7_?~꟬Xq8O˒gƭOY}=-oNmݿ~x{_=ζ$]mx,@Wj܆K(!ߣX?G>߃uw^}sF٬ݼ߿p_(CxG2P>|ߕ8ƺ?-~cG=ZQ)g~}=W =b?ʃ[e5xA<7(ǵ4$m!Z,v\i1O ?@7D_h W1\ PSm (> ~kq>jH 0Uh_ s1CVydyg w9BF2Q $L&}O<&c$fHtƭ[- >-y&4cINw.Θu9|1\?9_+e"oG7BkNp@2ުCu  @=R^J7!YmdYX/038\Zrع|TІ!:ε>CsN'p@aE*V1X,Cd$U@ Pٹ܂~s @SqSF~<:w4@ù ZUt 4 u(ao1=(9zOqSIMJe`Lac. `tРj$ͼ5wV<鼌 $y(ŌX䙷jZgFbW:-6vO]! 3fv.~魳GKh;}ݟtF}}H @4Bn(}uh:K;ec@6<]*Y )xng.i88ۯQپ<ߊN To|S9Q?p89{ Qm~G}Rcb\M1QFV,G7FَduC  O#X,Kr f5SG jv8rE EP;܉ ,]MQ@9rm0[E~$ 瞧94KsE5v3ݥ\N@zRV#l6_ZM_sj i2 p.Lf +ǐ@=̀w^MЊO`+߇u}(z/C+C~TõI>잎p:ǯ &Fl,E +@ğ13>9PxNgA<˜8YPS4ᨈ%*_#I|.!B9J@1tK-c< WEK1^] FK1^VS:d_r7r}R3EZCf2'+-Yx;]iuNq#u |r5gr?Z]*u3Vrx%x7 2Jz BPHf!cb)!\4397TG}>H|=5)eoQD0WQHQ)"at= f;}(+ 6}>T:wkwqYu({\d?o)y zs <Ԭ MYh[" _"s2l: Z%I%!S08D!&CLJ 6][ *wa|hfwj!W2/5zv..O څC sMuh8O;pq4 xxM.@d\Ȕm0@g}Qk[_kI%B _"-J:f|  #E"[u~Jr%)B!B!WHq7&g/ M$3ɖ"Mjo]7  I AY"1,n{2yUg4=3Z]ߏB<,L({ɑD[ 0Q.L*k~S >ndv4;u&rm… 'TUe@ȑK喯 D=PR0FnPsS`+B O/o=4&^f{R< `IGRu ^fU LLԀ¼C`67p&1SdBJk"J]DD"&\zl#C@N}z[! J^8 `54dݨ&=9u#"Q{zZkXaԛ 9X'vyll@MR7N}:KFZ'p],esX$J/QS:=g%ʩM@w]7ea'L%4Ԁ$5!4v$Z}/*A%z-ؐb۴GaBސZH@(7uEyɨS~Krem#Cg4[3M;2VnmlS4RTкtO!U5*v\撖@k xz]26q&8A!Хi6Ȝ]WY:+G%Z(GJZun) )hJX%j Esua}x]4=vtx~~z]iٿy.g/ 5ñ:\m&7%[4nz/cS^\uv)Fh"s)>%I^ n߹% > |L.۹w'e;g% &:dJwt#oheh ށo /Zqv@ !CfuRbj 9_:%kpW8k>xRW|II.x-SUXlO0;jN|GѦI J|,8?˒u;=e>L&epS/_Q~Ks 趧ye8Ex8h7W~@?zO(}|z-[!3r)[?2t{9p~࣫r"zDq?]IK82+JhSutS{',wv^UWM:K45(&$zonTLrHIAb,=Ս8\7 F2KKK(Cs62D3pR䉰yݗDdz=xWD5^NJQtۮcvb=6Id)GK:mpkR¿y*GliԈQ~1`l?Ah;S]Xhʩd_{n RW.sحC@MV'j2EqG Le89pFSlbqxb kj.YީT.oQ)'&v}IƳ );У\ҪvT@*.L$G| kM]8H#ӯ ?uU ҭ=G9L,3^Ҿe+xeffztNeD-}\la-۳%~ێ@^9*]s:Qa7_szK[AВ\9: 謼ֲ6IĆ\w#43ŠD,M/Νڰ.vU)"(f]mVLL`w]&ޭScMM9b,E B [,zn%7U[d1k9eϹq*Y f:$Br `'d#Pp. /ډ?XkBKM`r+t*XZ~k C:7+0ۋc$TРLr!mn,NZmkDSOv:qA}pz?Do碯aӰ ezzDoWr"m%~g]꾳!'-nΠBfqO>*DˈnFT8ޓD'=,dBHzv DpdYB"QڧW{(}_|`T`yTaVk'j$Sd[0e u̹P/{3HbVuD- XV`% $lIz!s)v}lVέ;}"He[32*[gwmNOU:꘣isib0,VG$~OᣋM~Æs&~sNo \ 3+A6ZQ)vC!ù\2M :pČ,R Sں'ܳ^ ȧ_s+--&/l9W ,N]$,|Gzr.CR/.d5JGM, n7rGuU͐]L,$\GȰ%.Lr/Z*c10DrκN:\魼VlKF Izε2Aӹ֦ & gkm"膻h5*UN ,|90ƊgֺD+ ϻzsghV(γcȢ\ri;vn=j̪,w-ڬ2r9<;?tK>:ed AlZer.o謓!٭%fJV,BZòZo(KuT@<}*sJu m}e&i)0Li{<0\2OisWET?W@49n;Qpzy}It3M{^īsItz멳 RDw]^lW-R龛ɿ5ܦE%r+rk+ǹL7#H(EWsj7$NOhd.BDwޏ泹_z/J9z_$#dYZҨm=}kYB;-gf~kJGƧ&arUW%zϮZ]]}vS2,_>:05\QWR@% 4wQ4w hxim@s WjtS?ܭUl10h7zYށkF'ΟoR"(t鵚*|K;-FNmrZ7\& $do "碼Td臔:^OߣjXXkY'!ػ:Q{ȵ^ʚS2x{~U-QվArUr|yuW$m1W a$6M*]/5?-~`K钀DY]#6n In4kF: gI ?4 o}s`jGKD`]VH0J,zr/SQu9}](voeֆkdkغP) Pz{T^@S D.(D,ィ,SKo}0daflZd 7ZuFj]\?,V'Ý\S瞏D\5G"|:u`g]?rv]#mn>Z]LձB_eLb9r1leHpk|u#gJ徶73 8f}vW۩? Z}cc-g{gpZt2xk\lh#UU#NU347G =j!h5|vЀAzOUefU"=uj@^vU{5{vt>DVTK{ѨmPQPx&7 .ZؚR\gǪ@?Px+}M5Kn-Fe. \[&Hd: 5;', [%ԗ9)jͣ|5OR*b¢L8n{k$eO`݁fo~\+OV <%V]gd)¤[yh[$ZuIӥcEPBB&;%2ZjIU43B^UfC}CV#G:X5.cޤV2z#.\\a~mD;IEF)l-ve1WO$){ ֊\bG=%{ٷgq8׸]CiW\OP 꼨Ⱦ}vm9˅[s.ׅi`A^xM1HTEBd))}䡖@zseC`Yf"fk*.Uԙ];ED^-?"#hy%{Omב:']/סb|~ )O]rݹP!BuZtۀALsLP*XLb@|(ݪl*J(4n5fbF+ϹQSS&;uEMR{wݚ'ϭ4<'RcYnU 3)y7#dY٥UFgObi34u.Lylu&;PHn;F޲&÷Jɞ"rJiԪC\}4R-*Ja S08L;h]Zsnbu=5w,^nϨF%֮I{ Ck& S" t7 V&US{KÁr ưuy"DկŮa @mڄ5h"ũ !UlP6ؠln11J b2JI3'zR Bq7Cz),\['$86dߖÉtp%n_ ܻ%o01Jv;fŊkN%zdڰh1 rN>\:/|HȨ0Ey skGf()ioYPO1$*Ѐx1M<sAߎnF$@lHy5# K^1֛z92 n+s 8n~sωwu:lLڣ%r]qJEr"Og_^uUFB˚zOg涚%S[3sԴ:33 sԴϹ^z~{A%2W!7C`M o!RT%8,妘WTߝ jc8_ys7mo-L=fi@tJ 09AmW6:IXٍ1Vꢐt,}?nH>݇4΄|z{dUԪ޷xK;|.Kczd[K{]"zRlQ\-2hlQ^d0UtY_F .VNZhEٮEHNrBk9>je H )nNq  Z:&R#7ik$ O$6'lyK$'$2,O${lxɻ΂ejXX/wM M·V%qHG;hFYKgaT32@&2擛ݺDk䓛ÉDr+9Yf%$,{"2]=~mU}"xr%HOh"LBx$W IGLR5_Jw\#+1=B D2@9FsVǶ {--d;\HϨ(#72D2>fZ1t(TO}RmM$dTw?lNj h;DB> $/u"0"d5 .C@#lfS[}M~!SKprQOL7hmLrD0]W>ݪ/ΰ|x/ &M;YքKFNʇ!u&M-FV45^i5tGf 5ƽn v4kQ>J!UJ$!JŎCD#=%NBqF"{w|OUz܏;Peþ[S5KUzH kR-$S-=W j1{@"~> 1roic9w/'34٭G댑-=0J]Q҆y %,4(. 76R:~/ɠyߛCnItzǙACwImVM&]i Bv0HAJ;A>ډМY&9DōG,s>059nd|jQͧ oiiS H d08FxfԮmYɸ!;= nEx,FGm۩D9=$s0YnS$}9ǫrVj%W)cBOW"/-}t5څ kjP&dB(&[5Ԡ*02kWut)MN$);2 ʠkF^Q=k}OKyCc^6E R6'}Ci$u7hZd{5Hogi@?Qd{;5Fj@@ILZq~6y:߉`\\^-?J"D ogۮʉ~WbdzfŰ_nb咮D&CKd=*~?֣M'B߭b.弨/Mq6LHS 7{[2sZսMK͛7=5/r9g-*agi8J^K| bA?KݛZl?ЂXcpu/\"oXV%h>oI^fR,嵉d}!9ŬDǢ=^Vn!?sD~j&u $g溴EI~2)-2Z ܅ez^^5'7^jQD &(GXjQVi~CfYwa1`,^oX`uTɳNtkKT9ѵ)L ole$i'>IF"f*~>4|Hvgr̢'jz fo=Y?BEJ(Xt =GMz9zwGi$ҹlDQq:( 罣da? ȃ* ,䳃I] eb'Au4ҐZ,u]ǩ7OGDَ[$0Vi"%Ǣgd&VT7h-KD@=hG-ywȥfD26H 4irC}aRI%%0P Dr U |֏4J k ;]+C0A1>DP B !){x6o7|CKF=V20Gjw~Plu_Cœr{Q1_as! rbfՔ"=luO;Du(O eYZfe' ϛeOb:PlʡE?kH9ǩγshQ6eYBfE&#(-Vn1G˧$>,̖"mv&d\*HzhRV"hMzSqT!A}\m'Mʰ8HfD 8F+L2DTtU\0q T.;D=;sp>8jLJ_ 1,GMov21( rgbɇ}8B"asUwU"̢st`n@1jǨl`hp(+ ɉe">dݖ% lvT&;k =&R WG',ARJ,&\sȝOSc˨OVm(MMʦWA=oܞ!:L"BI{BjŨObr;ƭ>ݜW`'{5]+iცˊT9-?V0T-m8w\7L"}f's墾 ݽrfBVUW >QuW }u#{W߆'ס8qF"CV!e_䢖Hpq˾ #F;f5K[@l>[xT>i3S׉ .]"uw|el T7y%Bܞ@.3_¢lg῁zI!BV0ܬ)(2|'Ȉck={9ݜshވulgpRQUwTl&w;e.9݇B%[[/nAE@䧳>|rz<6t#NŞZT^h !`KsKϕ)z~BJ]-C'gsiPlC%/ ʲ-ԇ)=DkyiP}a\8 ʆAٸVʟ̣? ?s XgvI5u AYV~ѡ ucIYQ|yŀp2y$;JMFr7Mf=;e98Q@Q-cJ ɎUIQvRG=aVyhџ,Ⱦ,4SA2RjhOnMUSf͉4'?4ղU%Q*D6s!c6)4R9n=R> W&=ڟE(x49G\pA]H>9O>j}n> [X5Bg>fרș ʄ莒^Kg"!TR*PK:R%oQٞ]=@.)uO >"ië}Ob+=Athjx׆.PRtM`rs~|¤'@~Ķk,!&w"`JWO@/vȻڒ&S#,YЗ(]MH(NDz~LtLA&I'2%Y7IhKRmoWD3n}-6ܱ:hnW9=%nq|Is X΀rPh ˍ|v(dB7`;zk7?a*=SrIlw_8&pQ+SAhm!`Jݣ={QNpe9? 4UPM"OSM"$f3IV1vCjar[B%vZ J㏢UYB`*[X;B}%"PJd 9DɣDM%R`F鮟Bto[p$BtJp,R_W욪ؼv/H1g8 :l[4[UHTQ-kY]{ٲUx\!0;Qhݮd;|vFq"6K5'Ob:Z 0*{5JH=Q}״|'9W>H>;S!ڮ+Lw:|vwnEIFM^fk9,d.([ ZWXD|x>[|8{Io.MX F>$yT!_E^4([SX5Τ_Yֿh,Qul+KM„9Iò8FVy]ًDPm)Ԭh8!JWDT0]ڴ(-^o( 珺.]>\Kڷ.2LKYCCaGT$s9Yy]ͧj߇rR?lo _5)Mf.Ċ1"x,}v A |wYlo08{2L:o!ߘU{ŲX = 6*e*/@X&iIdkr_BQiѲ 2x_ӛx{\ȯ,wY"+zaNy{$~VVqTY.x@ Ss"hL3_l}O!e &YN_{hOZ}A8mיŭHzK7ڕ~f >4t7vIa_Zͻy)iq5u&XuG|:U23E4JC Ѻyl]&(\ c$%CcCt=6\?.\,ZbeąLqg8*]j:ݽtYf]p!(z$t(Hq9ù3VjFA]P/߻VVrg"H+ЁeUen*ݡ7a;7u55Vs(!eDVoudS/&ݽٝM0R ұ'߽J:Uq\}M BH-3pWRmFjsР>&ݥL!3ێ6{.^2pI /)ڤn_V Llsn+!Z/at}W- 6Ds@|eߘ5?Jד_llc(3IR8<:?eb$ ؼrFUEUݿJϲfNëbDuNK)ɦlʪzxG# w]G͟@ 'sL]<,OyPʍoStN$&-K5N4f"-QY33𾪈CswA;tCjVv2_ayܟ_\" Mw͇|)W͝%ίZ5!Ὗ@̿j7_EKGjc.5j,p:D(;d]i? XŪ)/WӨ\ne7&$.etw[\==ףdn矃fa@ޏ}H,P:YTÚnr&;BZ׹%5!_ DR.J"*[NUNNԍ B6A{2 nK.ԥQtBacD^%%2Jk8e$DV )- ƒ @04d8D$!Pݔ)d۬'UT}lLz`;o1sɭ_1]it.KnC`;(-;ؗ\|6I>QOo{|Cei\N_nJt%ˍ @#1+pf7ZϾFǹQR6C%zhPUc;V}Ѳ6%Kh eN͹GӲm`#*긺ɩ\~>WxeYv=ʲn텠q>-)%@2&UM,{G}Zez]!xNSI]Ek{xp-sbx]NX89EB?%xDjKHmt_s)nSvoYe~"] xa=ݟwfIbc;u?Uo\8w|oHsNIunUA pqA= ;RZ,I HoeX -dVi29%bw5\ Y)-zƹ.C2\!5?z}HjAA|.}}APHϟ!@2++ņD&%Ej{4- 1W狜Tca0(Ȅ+ Ȭ0rs7չ^*]vs'ҙFn iM/[=(b%"\4{" V˰;jGRX.U'2I #fsK|$jNmF9*ң_^M&";.&2$?ėT@?  4j{7͑џoLJиZ)Dn@Np!+#$7rK/XHb=.XBDziD09SEm WKu~I\q'QT-瞀9gne_&^_M{ YzϟMz;+')jbJWvz#'Mzh}ȕ%M;~Dh4\T<tEJBbN>;eH>Opt`^nH钪7 IewkaW&rgU^!ܮ2c>5 -Ei\CiDn'Mv9!zqiӒ1']?e7 H_'Q\g}Ȋ-vw^hf@ސNAuI!SW1na$ޗOeɦx)D:[SJ'ɝc@ɇןG0Mz$$#jua ϤCPTƓD૴}uWtg${W{r"Uj*{%BPUZr'_%&y7UmJ]ڛ-xbw&]~[]6~V\q{#:A}ܨ8޿բ?КIa_j̱Ԫ&Jd\!j^RY[Lh)JTBXH~O/]$K땚?K*c=c ݼ.v$"ٝu9$kd`9':44n˹{xt=7!E.6Mso\s.I$]ΏWNŦ "FnΎ:D7|V{`xتuhz~.t.L_ӡfQO I_k0 ly~PI'嶏;^4,zJ` nj.;ܵN$P '8D]5WW_\>Z4,f^ %Ue"?snPy'{$L?%<+պDF;$7%JTXߐ o8X͐,9 Aly W&M!vh/r.<'r#x e.g=A/M͞˶D 6$~,Mm7B"p; }{d=TW(n+a$2/t >ލv m<+n @!`v`&ZulЖ d1ݾU bE+z{˚?{{;ݫA/jz[,|2,LYlx˲I0?dmCײ]kZݐț*FNv\43|%ɺeI@LNgcƧqږ咇%6 B8W rжue <^X8g5Nl1Q˗U:\5@i-z:: IMߜIxrZIM!ω38iߝ( {Eѣ1Hbtb D=6m|@t Y\qX Cb3#@lծ) Cuu3[B=5y:&AKv4;S@7%FU{9:3)D2G}˺/D;sar:X mz%&}2}Llun͵?oϭ@%`ެZV)|dk~t-د~܈U]a{8_"xrےIT"ܦ=AX$۷><W'WDp |gcM㳞Votqm2l J+n&EDrmr*rgMsv-ji"vU)<[֬g[S*%̬LOfeDOd$HOj4-̋~IeI>doKZۃՀ%AϲlK0Yc2۷D&.jWtGB~ t8cQvA Y|ot*ŌS \5' D.0#1R l$wqEe VHmzNfȇ`b[?~[(NM{5QD#O%z‘&)LWy%C]Љ,mN#.~K.1;-3 =9ּEU+-29+!}uN_Iv$"vݛ[eci~i[EKA mz! &ގo{к,CWYC"j9`1l*M~R'cu.J.j~ px aM$7PȭEP-/ރ}D:y7`]YSkK+)$g ;wG`'y\ ss#M!]|7RZm쟳@t[3S۟9~%䮓+̆XU}z,ÏI(LI``P=*>UV?fe ʼnlj[C=QU|+ 5Pj"Pѷ,5ʳѷ ĽiD#Ѷ_xt-_PWWkYw<彩HFqI [L 1,Wв,\-dVo!k''{ݵ'WQŽ]+&I*F<6ЦX'KDrKC;'W&Y{|9I[heBSiB:UXw!>{Eq/חM?)X8&GU|-gW-"c Bzj-C B.ZBf9 `pykhIr*]Sֶ@P׫ċrS~Iz/UwJ-̓[fѭ7:U ChW֭ȭbZ[dw.ӄDX/%.^;ogq Dk֒M$1ƏbwPrX8@SrH!hJ:QJ+m.n)Hm.M^6=-RHHO.D\X550[ T.!wkUUG!>UA|bQe c)-} Uo"xtWm;5vr9Z8El%43%gzDBbI_HhUu)!o82To᭢;PՉdV|vMD{? ۽Gt)Ki;ltkEa-Q Rd5Z>Zq:@rw{t)kCZ ),X3Q0T3H _8})-J#K^ӿ*?/$3H'Zl+&kX ylFjA6өCپRz~~1{(by4mY!^*k9} \zTẠ\߫|WZ_ٞ& T4rwU?G}o@jO+9:pQBЭJ# d"JU)K) XS*MXC#lo_R8L=FIiK(,%za;| = |kNӲpНl{؍6(m%qP̣.LH+QGE5[_Ug+$\o(c,#YD`Ll"%xlk?Tu*$Z46>@Mߟlv|{TdnP#{jIgԑUFySH>H;|lb8hp8t8|n}@Ԣ-Q{col_"\o?]Hd^AW,% rSG_x/OPj"W"oYt%[nG9e ft%Y%2W|9&fBa\L$chr`h/8JĠCЂM&ƏQI` ۴ȥVI I2{$a[>־AP6٨,|tiZ#> oxmMg9`MgW^PKD.C=f3GJ PX!rݬj/z4\rǗ+zp̄vlHHQo"vWo/e]qҊl[QJ/xJ7'SY":=Mj~dEU@y@,Sc&~& >V A,Jdב#T"П:qIV{wDb*>1gܟc2(N|a<>ھ틓@2Yۤ4`ß)> b['m"T=G1!_D 5+ H⬉ɩ(ES\Zjє\e>(>k"Zm`q}WRS&]Hɠ:B!0A!4%;?ׁ)Y.u}KLqwҔ,%u/hJv*8y‹EcC?B2{vJވҏ3F} eVEg|:d^h\0Y4&ۜu`nՆq}7i'+AW$w|sVL/;K hKS پl̑t$鴵;zґG]bڔ\AM'%D!(`-'b .'bcrX"12j)r0h0VOkt~d[` N[kOc%GCL>N5N`j6f};rl۝@GTa{gj$$]$֮FF?+M^;_m{O<}!U܃>IsW@"IC{ kOu5-qrJ!v D!YCQ2n-+'9K)N!+(mڑe,ȰcVe"I6ȰB.ɒ’|}73GvlOl"D Y$O|,R2춞<( >콰q>)yK6ݴ ؤ?0Xd/tE JϹW2;/ȥaKe񽄗No H>ϩD6w?smR$ Y>ڃ!{s"[>kQ\ϲ\Q|u!kEG_~Є,c~AQ'6_=,[әC$kڐ!DX<"m'=V?6dIjW>,\B\shoq'w*g3GzԞ뼊 :jN`;- yFnqQ1+D6@fG:Tq(ҧyqﳰXM XZg7$)ZE02PgsDVPYVd;|yhE,Fdz!}y2Ȃ1|LF\;C+pU(jmKiF,iHޡV>1Җp nϪVC/"ϵSc1疗iC+uSGOcD()ۂ"/ {ߐGOS!٤; oԟlXC+3rxdan?@$+JD ˂v^ީ5325Ԃ woF'wJݍNi4˓='!XV+F{UT`dغb0:̡s} !H3[oұTڠ zNMȒO ٶT"@ Ah@fd٭gfn${!?%~dQ <ע)o2CH>:(>!.U9KAz%y@Vs 2aD 6&LP>Y[6'ymI?2og#{Eb{C#&xVȇsDF*zmH [eґW#YHZ3ZooD a)hBja) zЄ,2* hͺb?RB~ס YVE OYYBոU#^O 6Y\1VVqv87}8;"_eX [GfxpK+aغ1hNJͭn4:0{'?@]R @ˉjmBKVN]NhS=~k1/inDno4"ݏ(1==eMk5ew+7tS6_҅ F/䦑,A>|UwWIJ< h)6f ,ؐ-n!),^'p{ztԠ'eXWβ_, ~Z!P~F`DDM GV{[~wzEN+~w;TS4` 컝(4=5C;_Gn{X;([S pSc"$Q]r/m<l_ERsI'~.+Aj{nrY HMUJELkdUщl>ي'deRiZ_ٔCS*VPڲeQAF}m=J9mʿ1YȾݣOK6NVa]_\E2"ri}\Ln J I'Mo~RoVVrىJL%XޑNW ik*-nC[ _[4>T!l\@.5/zo 4} ,=Al<.,y,- =%BBх,Y 2M2._jWqOd!P:wG0֋7jS~d?GDhH+@ hh+ 4G-a5 ' mIAOV@$hYA _c@* #Fa$OIa*0TwH+9SƋ@DRT@A< !V F߷Ag2F Mye$7wbQ|B #4H-Ѷ k~.d! =1]+a Hz`j&dYD av}o#R(~^!LOS@Na L۶-Iz;_wL9vi*[ g7%4xӽ=m'v}MCǐN;̟5>c<}jj Hp{ cQ@<& z 'uֱ}좮`_3ѝ,K9dnz6d3 mdYy%uJu{:( 2`-=Mkd[*@ ҹ-pS D:H @T44Rۊu!Oŀ 3 4j {04IkxܳX{>I ;"7%ueY z!KG&ڐ!q} #0;WGtzFP)H4qgپBwD{H{ qoi]X>XZ#dj1S"`K{,:Ҟu3AĘZd[$j*liָZ0^]d%f&*~`K{;mACw}t'F}Z[KA< IZl*$`o(G. e?N6?/ x%ٿ?'~>V{?X_qj4!˟>G`nݟD.=wɭ/*;IG{R{oӃ,A38!W|҄,wX&]w҅l[Z)j `lf7Ÿ<&v) <{3;6G2˺l )j`ϪW Hws^wҫDzU@UX$=4Ia^14LR~OW**4I|YRY;A|Lg7d-& 6&dYR|深 K',7ULZ]1@2BBŗ|11)Y|ļE$} lᗙw*)~"ɝ~vb< CH7<Ikq@`B^)2!SHi} XB\FWxa.rK:jFGq ~֮54[N]]V9lPh][ђ-}>@:_Pm_U⻅d}c5ti^-TN @߽KH Xko5-:פK5ԠEK;XƑsJvjHmcjB&M@s. R.6seNS?Z%5bo{J#)T.p}xgmw A}\b֦n>)%ߏ_(!wEuJ7kYlm䀹i^Ѝ1|A=*oGTJfuaVU1+YˋEMHc6r$@yǮGُ4F/GgxӀ,4V@qg:H/Ճy| xGɟ쭥}Ipk[dz$H*4yh?nl-.)B XTm`qFyPXo4{5\ݾ[tr& ;ҘzSjðAmz@E,[TB"$'U &ZAW3w0(wM'v`Wߨ\ gMF[{z lkAO`1} 5'5˰Z -h 1^ArO 1[@\6ǺMs*%?d(fU)!k៰] VLpJ Y}8m-)7Ip=O܇˒˒t֖fv ZO u_{>{;Q!{$ !}QIvF,YWHFI$Lĺ:/\!R2ףCͮQZW@4F ?ͮG;Zd' ˀyM-TPg2mnU1=l;xXKZF 3Ou*4ZlvDwя8yE#WC> l-,Φ}P(Bف *o X "*i& BACBٓUܵ=QrҚh;Z@zAt,=v.`]}@6D'?TQGх{9~@kp*F )vxC{E;ok:;ณ8>qc^6* ûA;_`0/IH t丳ݣ2u!qLWPkRdeZsExd :/t ׼iɽg9kqaOqE>uCdWofjI@6]L@6D({\U :{j: 2GwSc?@ :/IrsbNQU`hk05/bf&`@ʩ^U ڬ{T%(p(Unky$-囼X2S m77c)e$gͱ7VE9﮸CV"#Զ0we%qG!B"cؐQr? BƊӇ`~ |#|y2H}{f:AoqFLy@lZZ #hlc ? Ye퀳i_Ib*Ӄdù*!@>~n?(VnIǜ O#"~.U8ֈﳾ?ّ4\|dhRߢE{, WI\3.3r瞛z޷pxƟw4nqcj}sQ+bQΩ\BP)w2F>q2I] }N9ᰆ =|"; / M:wU'҅,8*}sB\SuiC_$E5-2Ie4_9ܻ gh!d"\ `~Z 2$!/lR-+<=(6ߢC㒆 4}S=~v,3LЪpG;e}|9K;Ӑ~ )z klwO}rYY%S"N Nt!"`&K;5^^V3uQ+,}.sFzh>& ه(2\\x䆻?5@Zչ(=Ow? wъlOzlwv-xx%TkȦȁΥ 6eCQ|"˵E^ds{?zmZʶ{E&YHR٣ټ&Ȳ:KnNQ[.xt"tҊ\w64#a@{Z7%G;(#hiqTɁjKI Bey2>&(Gw:X x&d7և9+ ]Bl؅ ȧd_%=)H} J윈CzZNizDEt~teK!H#5c1Nj(34"[:,:BYv6#)}ŀz4#{D}F>cU^qlF=+/eޘ2#^2#j2MQ}|Ry`S5u@,M`{ҥuZ$T@N DP2^E0Jhݔ#CbYs"hh!H ^L"N-$% :cek]A@;8@J}(uf\BbYU*:uU 2I:eV#q;#;P[$[j=fU)pҊύ)t끠1+y3GUzo"WzJ<A32ln%S@64drc;J3]ɝeܱ:#S3DUrJ[@8ŕ|]VO}TFU8ԣ#a곐Ƚۣ(HȄwl!QhdLBK:ӭ:@|UVD׫J"OIO"ZW1s%ȣ%mK<`'4y##C: a#C=p 5o5T-6!Pm|y z10RbEǢG%wkxYXGbj8KIJ\fF_*@@ʠvef W6>dU!OUPҎBkp}D^mw!|BHv5дa~qG v5ǷovompzKYez>QAZ"I.TxF 3j}H ݣ%5+ h!YrWF4Mo%P3pRd/ݡ!p=F"`HΜ]8d gBai99Z`d)|P""iӐ&иi(;FWfVccVF"rFc()n^'O^r>=T݇ 9[sx쒾ݯcQڈ|]+&l H޶Bܣ _zig.mUK 4]` B<sHmk쏪lEAǂ"2L!Ir~9;*aL$yOB*bl-&-5.AɥΔtk&q;5k 22 JNr(AV<ZȌU^U>v)J35gfm*JEv}j徯!ThrC!lrWGCLAQr=-lP =s}p*'TK]j>ŵ/\~lsϩ"`;QOH!NN*z>y*CKiғ ~DQH"H$Re$g8(xl'=&Dfh7P}̓j/^هctBg|kɺm/A騙S2geqR,% _6c..{$Ѫ?;\r2B䲤Ql1ZhZ-"rB3K;mAKӮmgCrK&K9+@ir8dhtX2Ht.Խ}F#t2HsҎlXRآY [Ԛ1Ge hUE] }@K)bU [h!hx Y1={m8Ν큞!вы4dIк6Ai\Y-v34jݜr?kIb;]3Il vp_$%$%i%]D `ێw\|6~D& 3ГmmQS,C2#(XVYj%귞^Z 9pʓAY =Z4%u]eJ Ud]N+v pIy pF? }k1a P@X]=EWyջi)ڛq\ҢBUY8[%=\*wGn̬m Br˔pmSYzЦk=SUCQ`MfnN"҆wrO䊘kQt\Xrc\]: ϣv<xnMm-j(rܒjdђl.Vjѹ>dHZox>YZ%an!Qód!YǢ^ˁ 7iӔ,?h%&Bͦ-rV"m1zy)+jIFF9,Jڿ}YYI֎o^yMUd:eJv[rAr;j6Y$si|V>gGSdX{bXlsϖ m$+Nkklvc&z7@=夻mri,LZ^ɢ8Qzcv4xn3-i,7Qs])_Jٸ-[J$χ_ɔ"ED -_7MPrB&ԩE^4%5IJD ȭ 9%TL$By>7"h멭ܺ/$ܫ÷aUvxzZU:ݷp>HV&ץVb9U,տoo z($?!DzE+d^Q|AHe[ҴIltGv"l4'-=5BrB)~HE>;߽jB2TUL.e "TUb(#@w+쥖 H_8uK-W}w]!,>zHKCKf=;OBtއEY-ǦVR olrl<7G{x,j5IQ/tg3}m&4Eji=єF"^@l?hY 4'=+ xC-=jc;KS_fv8!|p'ݾ)R{9}.gsi}-h?J8CE3E#5:$m4c44Ah*% D tV!ZzxQdKhu }~i!rzmYH9&*CյT G Aht-}Ⱥzג3F 9`Ȟ2WTc50!B-}# SQ~dGUoٗ*&QsϗA /Hl7U| *bFw{&…Q!MŮͩQD=M }%ҫ^g$IcUp 8:]jpס=IG踷"޴yFI!E,O#NHBBPEvd;#` k$@6j "NcqNI{@mga¿26ږ]!Mgc55#唰} AalGN cy}tؑ,񼗰׎ˎd)V薴}mG{|Kitnqo}UDH] vٓ,%n8RHMϧZҶo0/NB`N>ŀQUZnWR܎X۲;xI3v)dVɿ;YN˱Fzʑd A˝'gEɌ_?"IUTr@8>"S:o\ߪN(ԃ_IБ7VzB9,..@ۤ}7U]+ۛܿTWBP+9,lK1?TUWJCH˶dy:OhIβVQ#| ڒG[mFaV[霶[m;Ֆl9V[eV[2^2%!V_՗,1irepD- 4-fhO$, x I-.z@rڼ4{GLw56ru0Xgڎo\7%1xOJ$J-'Y d=DB(bM<ݟ]]z;]U;[P!h9H蹳޹ƶdn wհ-Y斶-dU,e?I)()ӫmؗl6 G[e"ۢw"ے2R~0R@6H>6T3!hK|pJ}[VcQ 5?m+oOd_vFB7%?s­oq " AԎﵝ^~rc}a?9QOUE"El"gkؓlOH`[fQ6^K@HDFמ^0{%]J)՚ {MsJA8Vv$ˎZH]MH6iU(UB)( Pڭ{ɱ%|QNȨvOزqTG۽9oQt` ]}yq"!n&2(lτFQn \ ݙh_n#ѝPӆDw½h4c/Go f-a"xǁLw2JϹ5LG-S9^IRI$j}IMH$bK$J^mF"PJw(A\J>M`-X+C$F󸗿 cΎdAB+"0 Q}YΖdqT ?KoB@NC\K3Y;6N؉% jIZES!hItbL[۹ki6y9ӋԠ7ndVnyv;9c Ck6}n砯j( ^AMsA7s"`Kc˗, p'ZRg 6!H_'zEH>K3ԕ5`GQ]?FMʽNѤZ T4G 0%D1ax2͒uѭ3 *Fh!U; g:NQ,P3`wl#n[? gA4`w:[IGir}TUp\"$I_)%[X`;YrzL$]3$2 Uyp"VT^Ei۠w%B-=TGb}!큢|/GoX m;#WxmEۙ$X,|@ˤNS}TD T꣜JmL۸%/d*]Hږ,!ȷ 'b7iӆ~[]~30LHj[yW՚l)Iw,v (t1MfB"I J 221jM&TL&K]C3q*CkUI\$%MցTx[m!jʩw jJY.߄hNY_wU/$8Ty,dTS?{M#fm}JԀteH?GD$msVob*` P$yi"(*Ls&=C$TahkO߂̉tZ*t|ܟt=UlMŕbd:JN@{fdSsWdiad 6!L8=:@Z'dÃj2m&yG ɦE흡wV1Bp4($,uU,ݚhPp{fO*hXnU(rs/\J6O *%d\`rI#Qo5L/rܠzQלXPk4.# O$nT_*}T[,ǡ3=~"G54A& v'W(JJLr&Aڣeir)a]"<.ɀqM:-%=Xf4ۅN?|ŵ^~8ea$fa2rN"bkI-%S'ЅPzUyRz~,%˅Yo-BMt^lK6ENq;?AtϭYqvIHą-[#ɍ3&_J"M8re#A@IASi@ >= Y?oP yKu冊Ss"]*| zv]%Ri6nI^g2yBVp+:uW0Mɚs(V5%s/DP!La?-i"躹gA.n6Be&Kpܖ&4[b@ql /2j>dw d޻V"(6&[:AF%kvb-[8׶q`^*Hm`bk lzUM_Sw(bەGbł0fɭo`'wAia'27;_lGH4jBxC v"^$E#EJ1Qͯaqɕatd$: 3JᛒL)M@jϘjfkRrgy? ~:˸ƶQB60rZ8OmnS~Do0p7uHogk*>~0oOnp3Dn {sGH#pJډ'3\q"pRy^ѡ#*IU2{=.hx:w^Np9$k-"e[!ބ ?{=Ew=Ju =zU-&za/̧ڢI)kb"K=\ [MI$-d-aU^sKEUe$Iz*1r؊l5GZn[ ddOV8B~؋l] {m$Z,SuH~$>̦~06}V[Eй<%)O"]ȰZpAIv!$w|Qkp?TDҢk赬!M=AF^[,A/F%&WSIdCKʁ}G^d8Yf~㯨e'2pE"LR"l$Է0͚d +],&c䙚9ȆJ3TF$!4F;FX& E9jTh(P*Z{D_`J^N. |R. Oe,}\IykLi _{?rKzݝuKoK{29sKHQ+DP:{u_/!ro! i\ KRghwLK"9-=_e~T{a/wQ4*[(M6Ve/pD9z;a/24Iltfdqe3NlF'Ǯ^fnchT"GM*lȭB|{5#[('UHBM2e/34 u$ :Ok2Ĉ^pMAK{ ']Fn=i?ۏܮ#?ފ:~ut4`:"cRHۮDX+Y~"HEǻoB`B&`"1PQ,Ju^WGDrD M$J]墄Kz{͒xLο;*.$AGݕ$z%>JIN22ͤL'B5VȔ(n,!Xe*[IAob M hX ^߃[KDYP* (VYDؐx#)9`yxr[*Չ(707}ݞK1b#,}y%ܨ h&GA^TGosig |jn z` RDPrkJ$  d/,g1$,H^,Z cˬondWIe"Ju߄[󔷛IkSs+{~> c;./k>"G{=C=@$H iWD@Z&LyQDgTM/Z%$I؞HK9m$sqj,⚙eD]$L+dsyJYZ(m *?^j"IN6*d5O#<2&%-mR>y嗅ZgGYFv{'UYD |<_%Š5]MHbm!9xO=}]}A#CZ$s˦!5&!tH?B`;߹XZoD2WfdaV"WUkJ6yhEZz1SI"9{%eڮȺVcv4Gja(@zm1/u1o/EUSJ_-jvo[ [I\~T/LQv.@^/"ۓkЧS>]:eCT6;)pm֖h*ԨpOʢ.duI:26z+| #K^/=YsKݮDnEToxS:bҷ/ L$ H ȒPmYMlE6],ىl: HL_,^$&yo"F(!:I8>!AN_CƱNqrzۗ`\h8R׌bEkw"LU84kXs~.rӝ_+!}"G_Q(*&}4d*$*'\ipS ^U@KUqkm_ʪIU@:i _>6" V=-X6"D`c#%n*ZU/'8Nm{E" o$ݏ5tfݟ}21MZv pZW&dlUf Hnt{~L,aa4D^Km)M0;ͫ%{=\0i0k#K`"8HlZɻk}Clwkd>x3HgF-h4co?5Je˭%m?]KZ;c>ݗ▇a:r_k^R&nV~߳_=nUJV`7VJ|H~;Up]bR D&KdKZ|خϰKu2L{$?sP*ymȶ{7&_%2 l"Cc߅JN*%7)_3J;d"ۻ,u;Nr>LېN!9|v&:ھvoSv%$kkP*y(2pa& R[jl}|wj@JD "[>OYGdȚt4N>K\\#mD %2|4 |uNlunvp~4[A!ɻd&[!݄,N X;733F#|#:WsMPl"a k}.L~7DC'GIJ#@TvXZHyF~oNUJ5@{W־.I_(|j|aJgmv%(CEq L0z*sԟ$U,wrP|rQPIDPt)I&j\.7I>2>3u@To?K VrfVGZ%ow-DfO= ^~agaEy{߷oa̶O"t9>d()+ʾ35{]娏2Qb8k0> @H^[hU ՞<ҟ&rQzؚ 3-Z=d7J$ EyڋP"ƚ8Iɢ :Mx+NJU@ZjI*b}VP ԵJO$HdЯ.ksV @C"Dm@VmDp $$ƒ.'S^ Ǔ 9^s4d\+e \I T# ǬF)Ǝ<܏"pW]i!,LeU7MJ-fuV5i$wBk6z?Y_MϗS;4߲M %8f"$h;BJ*p3m;Mbs@(mӷ@wLwsv7uDTűPz Js*=q0o $g&hwEsVņ]ejDʬ7l|C,{٢.0^twz579 > up܅Iw]0UHJmfT5v);KsML9 (ػ jZ8W!fa @ƽbL>ȽH%M|OY:99 ތ߂xxf9-uD>NId=5,L)p>-{zot/ m*^bQQII`y:96Y׮}w^M{$#1a5)vMr^a$;0*,Wm 6,[OmRJ@ 8#M;s<\˨/Ls~1BkK}׸|p0$h`y2ItCrGucr / ;dY-h4G0uD@, ad;ы2Uj"4*dAὔlPv4uv?6ҵt\TL9F`#]_NeЎ6 ݝ"w裆ʼn<[v(u,(J~n8qH) r8ՖM$ao̳2`=SDp;RAd2hDem$: P"}ܓ-_/.Uy I'vAy✎30]g"PqcDiB^t W@#ׁН-OojV}R{pݿwlo4֓jGϹu\cLl}jf3*ѓ\Q>.ZC~ ) QMX] ɝ'8#Y J G+. Yh3-I2|J_'-BfVDz\Joa2[)?ްa',̏z|Iݙ!e\?jl90SDMɂ|=It/Y9@* 1X;ԺgSχDwʔ4EItҁ}wG<ީyCK#$/Y=1T!V|?"dy`,V/YZ3$3tJؖ,a[lbo ;BUžzےnU2aU4A-..ڒSe[:rٛ%eSe %]Ft9 tٖ>n^ڃp+̀ $/O$e[|#~^*NՔOy))3Y'䲴o v2t UKݒi[rwk4 DG=S(KdԏEv?4R}A2o+DZ ,~t'LCaK;Բ9oz-0)|Y$3ME2`dxћ AZjJ"WK_"0 RݤK_ywѥ4ͩf){ոR;wtbe'F(Uc݅dDd&E\'^ZL >= R"i&O& ^ ccvٟ,k J!% )`Kc$g}٘һRfnѥFSL{(v-^ f'5JJbwL.Σt!޹b+q ?bXYGމƄ廠uJ[H\:~tǙB:%)I͗ HIHK&ad5J |%d(=QG=Y䣪#'aJ䖘CTGkI#cS8S"` Eaքez&v)(7߅:NO U}[gW<6Y ZB)D`ΦMtQDt 4me фRHg2-e! kBN+)ދ}M$[MY^5y.IfcE"J+ @LЅYO[^wr ef@=27ߤb.7_3q 8)wzrIWh2+p[uiEM| JCIM kD/:?tD4 HiPP5BK 1P-oԾ)>&(f5Gz5*k bmVTTk  ?\UM\?hkQuݫI,`:V,K'SZLe`D[ :eꠤl9 )3ڙ`ߙǽFeV5nL?Sgu)[ˇ~K@=l6ƝFˌ|>[ӎntp.Z2{d+8Vv(SUݭ(أR&\nM)ma" p-WQ]|h-6eݠ}9a#F*ؗR[5TڬB[lRL&rfe6P1: fhi:ZH$iGթBWUHaYDv_*tvTJ'<٤l;' qGeUuP5.yPiTD:kWdR8<rݟ-e UcHlQYthI7SMbyn @7KIs\A{q19Jk_pLxmVfή=Jn${SzL*{^kQHc,`uդ센Q=K~IRMʞikSMʚYLѯ#ˬ&e]D&'2=duAǏٴ?30%CB;PL&pGDzUdρj63=#▉0"R19ۯcD^NM ;O,{SoDvENF~o'YV3kGDa {kZJN+%JJM$5x!0IrŝSwEPܛbDF0K> Ws\eMY|9lSGK+n"B2L){k|AHi? 2u$_]:7"JyZM|Y2PI} _#msHwʤlzFe}曢7YiGQYx/C5٨:M&db[=\iKIv `\7(UuӴj[85)SA{]6\~;$UDʤ~ geT g1Rj$ϝs/4V󭬤2;%vH!f=UHo"Ք54?ŋ-*uSc%TDh%+ycwS:w8 U<2\lWbZ5GS~eI^a{"KdMF?+KdJB",Y( +'ҫC{.{^u (OEߟc*{ âUTVD@u9XT-JӐc(.%;5zJM?RM>5ΐwXm=W֮}gU4Q^*m}Q{L ÁKA‹eS0ű%kE IǍa2TGH - Af0MFP lª 9Uѱ*xNX )W@/5ԛlСe ZZ}nuM ݖM(:y`=) (.RݕR cǣM;ҵ(}`hps&ϝFM;XD_z4!็sBǪM;7yf X${^"G}}֥ҼIiBMlȄQ?5K^H?@AٕPNT/E\BlҕYlpte]6Du>0 &\ńcdtesJ1x*&Yqfa Z09p/P~~u eum,/tXЏl7s M( 1,# Z' :@E y|WVC}^^e+Y *jD<C2(`jg.oG\7iu=&Vx0/ISAKp|Ziŕ[>HGUYԿK"k6~UYD*,o}յIbHͦW2JGjG"Aiwrg!Wz-ʙMq)t[W-[ۿIv6Mζm -;շ!a2-IdT2IoSD6X-ׁL8 [^˜nԺ#{BBv:|)iJ$JPN{Me; d%SNTuy<Xd޽B @+֋]gjB uGyμZ,wP^L|0&cm`2f@랦6?8IDZRlHg#Q.rk'>WIJi绁7Q _jY*Yt<\lY!OۡXM"ţ Cb:Xf `T2V=(i5!N% mt1PҼjX5uɢms=_YW,9Rw%}}vc{$c׎Ze"_EWA;IJ$aoL{wRPޕF'A;r)ƄkŽ.M[=P?TB@omcSP-; isl_ Bkx12ʒ_&c ˄mًlWfH~9!t+s`T=GbDf{\T;jhɆeϣm`3ۂId n/%2}Zk*m}^Ց{_<YG1syFEsL+T.}?+KdL +p‹BLc9'm8uj>UjsйZE]. Z%€C9iX 3YV~~ܙ5;r&3[W7A70K1dJ[xl(vo.}ZQ$rz`h׀8vyf+v#'Yd|<,0^Vi]`A장#/ayWqjW6mg+[g+[y`\g1MKxnɆeK N9JIyP=!n1_]QLt1dٮYh+v)Pvq͛V6hu+[j]ܘ<[ud3qUfr΢Yv1ulTg&1Aܒܪ" uve A[wQC$ `=@19L[1 % Z!IBH? {:,U*ۍ :W䉠_٬TzbjWD 5\MrS*{W/hd\Y[ELM[a&)yA*RFٰ A&T V⪎eMߒnAf`1' Sb24[Bk| bId몆eSRP 9ԪcN -f|7A`@.Qs"hӻ:*as ]`Ѣ*;ڴvǡ!?I+MB}UQ ̢k0tC]B %&-fb)k'wm #]٨2ZJwtB0ٔ_€˟09TP" *(X~4 WHdk:BJVbòaY7na^#5!Ԓ],dD%1@NMulW!D" $&L"$M;ä.V"L"<ӔÉM{zM2pc|.IKɦvcp_-ό'%ۍA VASmvfwJDX!K4͋M{Jew^Z"y2Ivp/5ۦ2cн-M;ZbХ[D@Ne'B+y4ǙBs[_J:jW]qO] ˖ȉ 4n5,{i] ˺] `jXT)4,{K$dƛ4 'ߩ3fDzvznv,kzwlWۙ.mVBW噣}?{>sʗeJ?O:?_m$/y3m|a&y X65BkiO߹fsd~|MȟzF_}ȩCyV:KxA0 ڟ7dO? EDMp#-0C*D$~ȁܼ ɢ-ZWJ@~_ o![Qyv!oijpt58~p_m# iU4 I?g$R0)eK/Yxq~ &`' }P {ejU:ýl@A9vOm"y[ Oz#>䷺=xBvxM\ʯu~@l;uJhCCf~iI;<k[G]T7U{ k۟.d'R^ HţʎN"K@3L~RSW^ZN<!?\*iC7|8n1l m .$|Z~}Ve1r!~Hn]C/dh$UHoC RND&ZC|F]6 ?`OҐ9զ9%x/e)9MH~]$ diSqCF/ t+ ;~!42X(9NEJ~H(IȠ-8)75HmBrS{Zu mB4#Oь2B;w̙rC{F] BrC{HHnh2恜?nZ2L÷UBΟQ~HH.!`8ֵv 2< F!0RkLЇ[^:&ry&rUf;8u6e&_>̥6If?drS粉z(#8&Kf/ :;&쏁dCTږ&4/efٯ-hi5,8`(Å| j)b/F6b+M931VgJv;3h%ZDJ̠L@v<0A~TrJ#bZI Āt~&סS~<4xJ2&t51T[x]ρ\]\\ o祝<>Sndd*^D9FnpSz9#U^ $Iz;Lys=dXvY^z= ˫r@MH?r V#I:$V#K:[ atff7G? !-9jYbVA;t DQ7JB=HE-MpDx,͏O!Co5Ok(]G. dhnY5y! Pn^skL5i&{^eR˅ ~Ԧ_ߢlsdHHur@`$|);:H0Cmm޸^xy}/>ۯ"D<ռmYX)EO.Nv+=_;ܕۺdi Y^]Q|':.0{N;YuHh U~ 5=އTzy\ q[qSVAc 0ûк'm[ww򤒘owr}Hh W1T b I?{U.{t1"8q"C3{r҇O.l}v=1y_ 9ߓD JŽw9`{)}#{S>Y/b/Y<aX`JW/{ĸTaeio%=%bI)6-r/$5QT\_3˸U2e q=%x~-[<}ɔNVJ})~GB<\" КxȒ>[) ~1IR;'yEq$O ƃd"H}ȠG0hF:k";#B`)6:cLgыnEoso{$}q4!7:V /GZ WL0r3S0@χB)-H46R/fxNo6!]N:?YT Sh\({:Q0~i(M(b4aRVUjLo-^Xd\Z}LĿvE? fW1 7E]nH7Pԩ@`"_"$@[#HGJm#m`+`wQ h~@( tߵ9Zfdcġ|lãS׵ti#"IV2s/j]Ԯ7Y%*MJ[r3nnK_<ܺa' ".a D+Rf=%ݭi$IӿjBoxidIi9,i7,(pg\h![yFesfpg;J:< 1|&7Ж~feG ٟCr=b he8\xl[Q!h8B>h/pݟKw$?!S$G8kX^? he~[W{BgfSEր좞㣉F*$p+\+y;53֩Stmb62gɑ$vRocIf6泩3%חEwUMFt{qfngʪρoQ7O00=w#vIlgUK$|Mr瘮$ϱVe8kA|jV$Ҋ`GHzIn)b(m<aJqY܍ghU(RKBȨ6}/ =$-Dd}Y,TR/4Ub gZz.9BHq:eK GnmcDm|MTeb26MYu HuU$L=^F`C vt $x%Bru4 ʹۗimouz1[jVd_'F~ZI Hy/#o]so)9rZuUIݨC`뫾zj~kF-ʀ0QY4i?6 ,#A,y z C!fٰ:ghǸ%W:dɽFz3Q Ysh)DT9V~o\j%JhW?sEseQȖPt!&E @MD$ WH/ /C/A~5콹% &@'Hؗ6Hw =ZO(gvvگ> WmNXrVj"]ݠCg;v֛`{*EgO''Q%iz4r֒4>Mobk9}Y @N ldc s |5UھîM鯮v 0/cy@Z"ՅaL ge)qpicO;7{0&d(܀ HF~S4ԙm8'bJ0dTyʉ(+@HE^ R9 JuI-eBY,5 !Oq3Di y~rd!&8*NA&w,'['H&;+uR"7%NDktYF1`D-zRIkP_%lt딙DbiF Lr 2kیg"SZƠqOd3pT4 QU{?Ҳc2%³xLnxSGky?-Dr6rev,EKKD+XݭܵK]|""A#2yn(cuxzu )m:FN RyYg-?NW0Hh6 `*?Ik$sUWr[rGIdduZaߚvFQ?)NNh|']22߯2ܿfur&(L> V3E=OOo#i$EE6$y24}ntt?Dg_𣑴Vw=Olc(vx}5w]}݄I!FjHI1*\NZۙ*ionUDD&}Nbdq=fGq _eiB fe$Y;IkdFo֎]IZ;N#+DȢlvz 56<lF9Sp$NDNVFdNn!?k7AyIN՚Ʋ'x}F\:6 A3e(:`ES/ Y\~r )mme+,/ldED]&-d~D&.{>9u+! '&23L<ȭ`"W6r:RBPNkn/yVHꓤvOK!FQdE{V6$M$V|Y'虍2S/N;v*01Ij^?Jq!o"[Sǰz2mD?Q;CUV8][u1mys G'"#3j~Wd˴x )i Wł_nkAZ:\tg e($CGѻWGrWS]dD6׎]TMZFHliGiA#)Gn)߯ =k(1klDضmkTV~b7`Ͷ#|>}KdQ'۽Hhw7-ra]"w-w >'0eD&y7"O_d'9gB^c7r9fvfٿ~Ir;6vͨˤoc4QHLue"ku]q>ʌO:n} kܥD A/u*5ϧvYuۦ"WwiǮ yIZs'G dDq+$T G9+y0c_&xNc ,PhS1py}$D/42>3. w$}/Wf[_/vtE$&?Z/f܆t~]lUZywY1#õ hIbH.nen?~&?v&fnT?%L߃&;X"xwFlb-kAKB7V|d@`=ioy8GlI!@J":GU''ts(DG=R8cȸ_CX>J2&wZ(WA|3[E]9nts_5sG@ ďn02=f:ӼYG^^1""6,x7c=胶yxǞXf6n0oQ\1fH7/8q<2iYF@yY6]4+//0o|Fc{pQ_K%t|;9M4jOy^@!>w+ CH]!Mwjƙ]}kl(nܞDxRvHn vg Xp27a1ߪB/0B>4%M x,B)<=oXcD ;Zj>6k'ރq^ĆKU>6ː\fcR""p,"TqD堼)rd}' $9+I,n#zKfY#i|ǢZaϕ(!VL}l4w"~ܣz$hFc%h%Mf?:쉤 o= -u;8 DfˈDI%8 }I#9O]~)OstRܫ`a~8UsحD6 JxuVK$}Y@{B~"}Cȡ|R"9td{ɡ+[c Н /9sx}VT a'S5` 2V3DB"9v;L$cDl%qIxl_{l|U\/-,Qm x\B`D~D66GgrY?p-W+r2ێ0^%RUzfooYllBuAZ"zB=MU.DP VK[xS)6 )rrz)Q1;)FG* ,9o}̏Wnw"zY]c4u~"!Z" 5FZ ;q hhH}3瘡d]XbY:K,mA#@4tD6%BniD\Kv,-$!Bm9`Khf {lh)_24; #mgUHRC$}>q▂Z*x ߩ +Y!4Ai5ڇꢆ+Fk_](qex ,: i."֩ID{QleFc7.h~YyQɀ^Sɀ8I{4Չ.9^ yYĥ{uI 8կ)wBi&N djL*7m8^v![%ƐHFW!QѠ..b-v!M Ci rku|90yVXJVDr݆d9H-yg# {oxZ1 +W6x]Y~"k&fBs.d0]ZI+=Ub5!lXˉ{ZR0~״Lw`B/2':Ӭb`#;Y9IWxѤ&24 P4quqk"4A,VKF4~IRV8t[3忞BU2"֕yte, >* s` Y:Zj*fn;34;~΂y̍  [-QȀ[PB,M߲ϸض}Y_=)z}COsY"9x:AlrY;M|{l'Hxܐ$Iux<`=,S"qi2' nR{Z"uEGL%L\ӅmBljb~%s4^~ Em r O&%sT"ڞ븡LI(jsU$ȫ'L~ݞbj6Km'I¨E~#CEnXY7_*[ AV0?'j{&V6ӶQpU ً6Ֆ`/R 2vQ6! ȫi]ǗFʎ Xj2Vo%bGy!x> `,wȧdG '%na*X,WMgb>X0 n㸏@"XnA0~֌#=ABN6P0zP -6z3#pn fW9LDLHo {,~`C9n}%D6N* +rx3%0@Q_4Zyا1!Xg.^"({:%6K.& }"?N;̖yA'y3IQ#ϗ2⤊ֺ=uПѽrͿItH/:ڞݳ"r¸?a9=GϨ<%YR+ W JN8*v@ݩ hZa ,|ʏj[ ZҢMʒKQ{s eֺ7 $@ʹ Aef cM6GϣZV&gIYX.)K?pTjwXlCJ6٫6do{K؆!l(}[uTqe%;̻?SZ݆s$:O;~j(\k"~LdۼOmN82zԂz3'u| Q~PB驓riUuLwFHœݗΊ: 웂qu{8 ~r^IF )Y:H~ֽQ~]FZDO;id>d?oű)MOa {ن,jJt* 8;dJ,h`N@6) YVweho\»]|-u FP %0e׉0Te^ˉ+S9EqIUSlvsDs?)\!ySINZU^e{k$sm Kq-Td:[JsUKZ0thRtܴޭ*Ί}]rw/kSB(.mtl(Nj[|J=l)GAsSn≠_Vs(t ;w8M6ߥy쳬eSnb@Mau ~S6.A\4kئcPOF(2m}BeSo:ψlX0rgnMKO6-\SO4XWfI'+k{N?a'HWMϭcUX"SQ`Y=|NP~t=$d!vEhm ܉h[,tODnJ="QZN]tQS;XެhoC$s= $ܼ:9S[^x?$;?Fs Zu ZARr~,&/Sָ \Œ(?(ٟ߅*REYeREYm;bKHDXQ,jU\d)bsu|d]u'ITYDjVr{+j&ԈMGq$R0QT $v;A;L74[JbDµfkrQjaHI5uz*a$T>+1T޶c{AJX.fAL=Է\Hg>+*v!Q,_c1`*gD:> Fm"OKz잊~m_'vkYBIRa2c3,$TNѯ~X]'uC4>7ıUHmNĝ]=ff]D#,'(VI܏w"Qf~7S JNMd"5ɦNBb&ɛOG;MC#$*e%$wV8GII*u.kQuK[)EV?RܫYr,g8{`%pa.c؏,)sǤ,>#ۥ|}vd{^/\rA؍la26PR;ѐ 4$Z{]QwrFnjyJ߰0h}hJ7t.`2Y1k{^ i&rWK ~hәOyx \`(!\wLJ`(oTDj`X:,Gf{T#D4瘤FDcAOiID@GʹRL*iY tE! ?A i; 83_Za"HpJ eNvrm$JZ>JU%[ ֹ:Tt4:7"Һ.*:OJ:T\YmD'g9.NKF0lL)\ y64njQBPJ!cǤ嚜k ، |D(*KgXIx!-Y9א " iܺk3ovVLE}#ڏAN8srH0YH֫CHo/װ%0yۙ\d?N~{_ &CS~f32.5:R 4EX0x,3}QMXJ ;oIra"i:i I_VaGӜwsJ`qy"YN󸊥|[hw]:Qrh摒:.$\?g], LK:FBfԙ%Z y^qDx,~YͶMwKl I%KH5~P PW#A=Fm>Vգ/%VD$ \v\mM6ϣi𬩇cT^ɐ*wĐ3>q17djtң;R6[ĺF]iE"GcV1*mWkҶ/9(nDĚ5c!=nu[IJ`vQh-;QL%ͩD 5n=76V@ 8 R;R|r͇\o pVKIN F_cRIEJfCf̢!ѦF zGMXM>~.y~@F@ahx#r`3Q:F3$l^([IqWf4PJ$c4Zfeo0R#F}bp!{I]+TwVd[oYZf[*=`_&G,cN>κ5k9m"ٜ^y35WlK`G,#ȎN#y-̩o6VUHK4Y۞dqȒ5v 103NԶϩD{g&Q+A+wJhm:~PG xIP]li"ꪞ5Kl5kvie'r ;W9Hfyݧ5t["ىXԌȤ{%H$$ = G{&Cfb>nDmD@J"Є)3y,דO8*W;E3e$CQ~-D r`ek] X#\ms.Qui&~B6(dЖwdu~NK(ۺg2_V#DWrGg݇ :a AX"a"ǫfy{dk\SB/b!/Adg!nn'_yJwV숿UB+L!E;69KZusr{ h٬p_ ݍ,K | jЛҧoo9#Du)jȦGˬn'H5k'kgq[*՝l6[ɪwN6ռ՞l8&Xȟ+/Zi͊DZ]H.3K&d??ThC(IM;C,ڑ]b;6k܏@CpAݪqΧo=J[mWqۢ[ف-rܹ/`SDR9[v}0~,<."xT/L{VUڸٜ,k[5Q1FwVjֻasXmԸ g$"[Jm5' Rsco&oico}ٖMœ@E}]0a;_dgwؚluwCgv$HnUDZ.&ChgVLZ2}B<7RS$p+~mC1p t!Q5%ܖ}O$ /G$8Z"(D.vrO YE)Т2+m>Fڳ&n>+ć͏l_؉D$H4)>b_‡ D%ߊ%ch;evBؖ @QO`u 3ju 5χ{W6܊6'y88? 8;lL$ VCH%τJRsynψ6qq^W~7='# 3q<.lK65ȤZ9ڒ:ڒ}ޫdǭHaD=U'> `"G~ے]%5/*/Y &(`EbZb/3Uk΍\ nAIaW2Bd8Y*4a` Oj^-П}b\}VWkU^mAt!V",NQUy{]ݭ*^3WG{V1*yDžCI(?sٝ+4jPvk/yY.!KhsFej2-$eC[nӄeY Y1~Vj]! \H#/Z]'Uw;?ꮋV.` QX$%bJF,Ɣ*0CJ@RURbZ|"'%6ÁӶ3Q (J.ީŷ*H](940oqD?7xƕ)۫WNqIe7?U1S\&;sS ϝR@ʑKUWH*Yc=dϭĵ@ߝ*{:@sgQPHj&_LV1KixGq6.*Xx$KK=GA42ΐt {t?+OzOk^?'+)}Op^wkO]5>'j ړF"gCz4veOv婼oT ;cd: 8oSoLw>S.}W#՝w XG;7JQĹl ݫV;Ou+T>*TII$MjwXꞎM9JG;%divP%ܳ5fk/wmX7rL|U>o]@0/#U=cWx}EUJ%>4\wo 'o|7U Avy|"Eֆ<$_?8t_-ﲹ\k調\Uu=t('U}G #=u?"إxv: 7GTw;H$tyL;6T3/Twg JȪ]DP2Q즈 sFYԇ65=L@Vqh l0~i@ *T/ A OHWLiraLI9槀%仌U˩ȕe~c!d7 ii\SlEA<@1Vp?dJ8#OUnnp e:[GB (&ʓ\IC3P/OtI{@ a d,o?#M'V=V?'9U/[Jw'T6 0e?lw5~'ՓGpgX $~ Pg? $h0w# Nv$ h0 !BQ{2vg_!=j}MpktDue'SC0eMMT0%E$_XM, f$:)&e&eGz@ͷizYJ Kn΁pi٢@Ԣz ^Eٞh}<e[iћE]sZ]ɏ#y7. 6  9CuoM}]fKP 1¡;}h[仏TD _T#{Y,Hޫ.{.{wcݳ N-phܷџ=m:3˃&2YgA<-xoV Жܔ>9|Ll<΄"#Z dBmi"^Zrm # u/TDSl|Fac z1뱢H@750#y)0CoGȘFL E7P;Լtݷ]ۭ.{m@@vvdX!v@#鋣 Y׍귫Cu_O7Y~kd@NR%a$E> (;ȑZRݙYBSmQ8*} J_ h`n1X^>exF0'Pɻw)q۔I5U@nFRAr eފf>F!J1}ʏ&O H}A>\@ i{֩0hR6]QG=T[Ia=A ҷgPz령+z / y`a_ѥ]H{o8Y*JB26<($5Bzy|}L{dM^u+&ߗ;;1.L;Ei0pWsT9sP^rU \oݱA4ƞD^H:eGJjQ, &Վ}H u SKP2+Nt ylQVDpV X1n 6(3Y  }O*N蓊ӭ\״y΋Fxac6ϚMW4Ԋ }T:Qnlj0^dwuGCvRg!H{כI{:[/NNVgw'4P:5&Cɓ$E~2'0#i3IvE"}ZѻXZ*Y; ju‰h^f*Jʲ5uY/آlicEbY!,|_^ *kdKm-֮e]b@afkQ\lQ֗72ph!{8Jn[d^L]lR\^|1;2PgiϷء,;-k|1oBd,v@Ľ7oY-_|ov}"[$wk?2z''d3@]J ߳3 m,wrCN 'w!7Yn~H^yy6hM!Ē!IviwvviwP0l]J\{t=Hlԋt?F&S5G7J:C36.Ƅ,nϟ"gLRY2U|M!-Yk`@ѺNK%@Щ-P{RizPV;%PLsL36a1Zl6(o!,dSU˄oժH_?9>@$})~'+˺CͺO!o,xO˼5Ir7 3|#8>O6Y}o)r]=e&wzkq,wj%WeӞ4r>%կF Zf6o #_;!; Ac7Gۛ<4mfnJr"Wz7OmDC9ՍU:Lҕ̯rԜ9*).kՕiuMQ~kMX4E?뺝F/7} uҩxLOKaK)9!0XnVUrP0O% u6gw,cȅS>˞ΉJ5?1@3)-9IW.}8J^OIopAY ue+)ڽuO; HǪjQo۰ŏ. ~ec'ۍ wgn[=PЫA #&ˬћ 9 "GayCa[mQmEΩ[ξMWuDp~F tۭ*nֻ'"vOYv ?gaZ_)v֢ݝ Hl$joQfSGð,ޟ|4z6ko Wݜ='o_6 x6\WYy ^(^݉-ʫnQa^(+~-4_({'WI3xCW-ƵQ6es_(s=6(s9 (V fe6R$,m,! $~AHGY5Sv٣ soO وb{ApSke{*L^&Z5hTr uҭH_s k&m} }v^73 Ɂʁs)$r\mW=*uIo{ N~ be_GEʦY$eR8pw݊$?ٰ..psW}{Y/1I-7`1୷ˤYILĖHHD$ݏb9.*:2R}6exw4\֞h]1(E"&.lj-$uNF3ܸ9fI$ P}6M_~BJmPdok@Fk\ؘe(( in>ȒD#G4OuC  WtKTy.ֻ,xBQ>e3z(~A1h.wWr,R p& Ŏ~MĤޢd>L*mcbrBr?"9(!ѽ D`'CR]u~)4›(95tlOVWw'k_tlupx0aH1TL{5'r;+K93L@;.oSܣœAvo- 8nu#d~݆7w ,C%P@0x{yd׭0xPAv`FvEo6x~3#堇a;dH 0D)-yN}2a- d7_ =)#nԼFAgzTT5؎$#r!A-t6:+ʢHi #(3-Ɋ24cLmp+-ەXMOF1Zݺ.p򛠢kc;z8&"oVқJ%}sy)Xެ=&^{,tϦZ ݓ+^I[}"N:1yQ|y?n?׉I350t-3 cRwm Aڷ~! 3B/9֮*k:!UQa-+a2^KGqv0Km/o%۶PeKUJFR'@Қ.HoR8)aB1SG8bߚ !묤Jc;#A@d9 ׽br7XC;vߣL{iDZحZYmCMq~_Mz&=2({*;E:p'W:`{g|k_+tJsJ%ޖIaDBl&'"IJ"$s "ImF6"IM@IjWFLşgHRIjݍ PZ>X"/MQYN1~%ySo`2`"7Fe ^ryOnb2ȇQ_}G,X /42$8'XWF"~ 0L׳g2wXw74GW.K$7TP0$fV,uCV7##q%n 8eo#*K$X^<O?ca{//BIp u #x$et4)ϊ@w٤,K'ֶ%8$ ACAz >' bR|g4t;u IgaH`YlmmT BޡE\mw#Hk ]]?(C]#uz7SHt.~1$]f{َ: g]h"rnp|:9#4HEsE K2p{@߮@X?{2]]Jԕlĝ6B6Z6dai$T38?y| X.y?}Bʘ+q 'اU#a?*+$kF76:Iҳ$4*e!7:S\Dɒg7P# \Q̳GK$cMLҬcƥ)u 291ЌPs v AXY>#3Ц2݃9&-ϭ,d7doxqpө5q r[qގg6/Htdr*N gpW9bx΁[A~GǐΜVH~<f'..-a]O"em%3 qzixH֙KD毰.:6rIȕ4w w/.\Hg'2=ب @3{4Ч7c u_ީYe`ҍ4Q"K"d1]}5٢ te0{( f- B @PzU"W 6c"{ww&CǙ"w3EpO,)jwI$6SeJ&a֧9ohstf,k&Lr֬$"1)3. οMLĞAMs(gB2Aǵư^V(-5DU^"to[x)[}QWɀKZ4Aߩ?Qq9#ym2f2؏hckb[LM"7і_7LINZQUniٞlKA,&ےuL9fS9ڧS9ڻvēvvm''Y4~dS\;IV;c:ñ+ws?`*Q'fm֤9^,^;pIp<W9m" @Ja;B @k @#mԂHk'U_ e&yjvJ?3y<yLAlgO_"!$[왛Ovj"Pd3VLBz&&IKH/d_Qu"*suaWbw؝,9YwO?)~zdv'KV7k2/#lOU.WWq 'BmH~DWHQo:2άDrvX"DrqE"Cr+#EM"#YWvC\EnWU"T+_o=/@X8<#%]n^I]kۢe"lַoF:.ߦ-m f;H(YIùUʩL8En#A60ɠVׁ\;(^ܯFEIVPо[cHU<]g1c 53 6jT`G sj[ќl.BR[`䙑Ҝe2a%$C hWmn0QTnynQ4ʑFGI:~~c$];Y.S'2jfą`6 NJt-]e3ɓ@t3u @rsO% M{Vs wJ W-1 7ڜ.DFߗgipnpJN$@Sk0or6Ͱ#tsjWY>ߩЋ0,Yԝl'K~ x؞,oZ,ݼN}Nyqn;+zuV2u*4[Ӵaw=ʁ4Ѝo+zޟPRIhӳGGR$<3py7ܡ=vIҙj?"}I}R`IsZ"\)IK1$BI|d$k=K2SS,HnkgIEi !wPofnv"0mD6Dd]NìacY98Vs٬C`GM-hő֢u=ϲ|ؘlޢh(3 <4_aj$j: @|<2H;>V Vgr P)~629xU:@Q!_==}{94H.#&ɵ D$oft>_܅l@ l:F##(DDLV;Зr:>_lQleWl]P"bb@ErTu$K"/'&ǫdQ%Y@"۪HEUKu$W=d E ^}wDh"? BAض?ˆdeKꄲH.S\ \i%Xt^yh9d-n沺=}$VW#)7FB[]2[[ѪM#XJۣV`i{If^[=_rڂj:fm$}+Ȣsz4΁+D8p˻`_j LCP;JcԇLNQ?uZ{ V>ؑlr-,l_{ێ;-A(/0=QVE!zlHL9>Xܺ95)2ؑ,[w<:kyCxH 6%olJwҚH9Q(*lJkd ݴ͵퉠_KXHoMnu Ftmڸ5A 9onVQVgD nnKDlב&6 d=Ԯ#uGM+z:۟t%$B}/e<GoI0OtSKv_8A>9B^~dT:;uLhsXO @dvdgJkZ1Svф,DZۑgDq|51QODfK/8ZQ:;Z%c"G.D. =Y~oG2(ݺwߐuRF aAn?lo)^u vn>~[)6teT3]Oz)hh~`ןғ,\'땐6$WUH~h'!-C!u#2Frw֋`/Fry(mHnU٘)rɢϺ9,䬜^d>"KDf)$O/ TB! 4BlnYH.WYj2ӱ~M2 egbj"ʉBc`!n.D[Tc/2v5p!=l-Im9~X}d[Vjm,H_o!oԯ|FVnUDo1퐑)Rh-%?QAo&9SOr{-Z9}0v4 jth#7f@kP5@#r! [f3<IxؽHHn wSЛa4\ex}Xn"isH)}c]"=L$ !,-_YϞw+ueGWgIc1P2SE"W6Ws`Ӹ.:]MZ}hmT ͕je頌bX^jq+2ڱn@ e⪍Pz uck!;h&.~7x?9ze v,ɧ4wl9;=_y8bslS6ثr@cTB)jj*ƴD^ Ӳ%[{vg^H?gډv$i]Do-_ OC##ǘw/jMŊ=G6e\O6]v!ԶDڿS< F\2HahU@ ,Uu/8Θ@Zew 3 'I^8}sB_0y#u8*jjAG7l2ؽVnMkh\5 ~W6-Cjc2BH) xe'e;Bӈ?< e偨59~ӜDxjl~}h#^y Gʤ 9~n!>[S/4QARuf{wӚ59z[@DԆ˷=j|' o *O.)TB]~j\IlM`g'&bq}s׫s#]r.TTv|SM2O r6h"CߓM~>4ۼmwTîR\ad\`yFzGSio欙vSzUzɝ qMg5( Uו}g7ې&ݙ4kt[)l=3'A[|MK*._섋ڷFMSؿ ODM<.+5J/@*ztXģg2.A@@@EL(C \Q.2:9HEqsBͼ7 O&tqJ?t;s93w/揙;m;ޓ5H&!)}39Y "IQ!Q*Z1EpQhw`Z4Su*$%ղҪ\.a9i $jY!XO 3boIZATo Qb Bbg0}Uoj`#@@f]L7늊FɯN `VPFD7zRwNqG`lo/J9{H2-phCBNb5):d)әQ2իəy~W"uɕHDu3FCv!Ԗ/|Ό(#?w+l>O箥p $*^GRo+5 4Hp *T%E$ D̚kURqƯ#Zd'4LLOǫ4?Nw QޔۼfͰY Âh9 \+Z!tÓ#_K,lS.~0T/x /^l]⼩^)nVY IS1$('?|%feц94~8d0IN| FCo Yp([iAYx1#(@@ӌ]m^xv (^L*UIU.<|%Eޒ, JI9GC(N vҌ38t%3?tT}tyaUf\#e{FWf(xF.9Y-T<RSWr1_ Ng;Fqe`y߻lC!rL;_ugH~gA#{#ӗ=?Vrq҇lBd5NQa)e$qB\(@ḨށUa)γ@X(NYkKˊK,-iB&,-Y7|UZJz%x;NLn6l6fG*X7@~`{T߯T@T[rVީwT4Rbсpõ/\059M'Sby5.Ϩs$f h)ʛ5,J#{ن%%e9-vɠ:דB' Ob1$t+/f@x85eWn~K)y?O)ݹl~ GE~A'w [V ,R[+2mK-$tg;qUq-fi(fM#, AoVWSQlŷc-D.$~}>tܭkwsH7vyu@|.6Kd_N۞p7dD d @nnP2Bd=T;ٚ-A5J&Voĥ`/)^xنeԼrS&ʵT[ r7`<rN1x a]g XȈ;-~ @ٍo^7[>|';Y.iBD8l7={LlV 2jOJn ^,cږ!=ОnukmH3gn (M#4V2ޡ$f٪&`+ {p}WmeY@0J7tVOJ^!{U_&zZx–;IO4 C-r+A0?9WUw;f)jl\fwdV>ww;իm%CC3ft„ůluDr\0Vnj"d JAMb-xg>zawKnq̓0k p31 Q3?)} i JIKz%h2B z7fd,hAzIyLФR4ؒ^EՉX ݻZ{Z2Ny8AUFr2lbxg+u\zeq͇9. gV|S|<uMaD±3Ɨ7Ng'f'd+p;lN+cu qxEt?-%-25,\gn%^wu\*_Ol[,G4Q_S^l"{2Ê#YwÐc)O/ OeN6pqtk%7#e;;Mp|L4d ߌ& ,l5O:&%rmj7?{ RunM>&{\n!v w7͍ӕ9O39jxR 112foޚ!~qL}!wX$|zLopdɔ=_ 7=W>!g+H~T̢,y|%sSD@HްVtzt,]Swҵޣle&tݟԟoVnIɖa1M#gf ?=7GRc?Q!kFJ$+ ?:lQ_wHSJ$Pul΁_5d]|f/96uW~ycm*)xTqnY[t=$.ߦ 7ӹ  ]DF'AB=$~ICI}48=rFopLN~]GY_GHUƉSտ Dw6}'߽7U[%aw:I$lO*k_+~ߕ&lMl.l=/TcO#MEcj"ל^nA46_nJLU[jxzwOB) r4+w]qD.WNFxu`:3?8 :~N ;qWFҵ{tw$ h" M3'ݿS4k0à&OK?OMfefo76H@AZZv[͘{Qb09.ʯM[ϾpT|+!HcVuZm8,qKx Q@j@/BDKE Ad(7+rNW5Et?@*E/[9Wpg.퟊YLd@ˬ/ U I\|3)iY%.(]@\^tt_fmD@}8@WYF~=W#blQN5rU]b&h dy+ +Fp6%V]zGd6Ҽ~w!(^►*7"B ,.gNR sJs-"䒅 r{t ӏF^j9٘BVݏW ^@@3|oI[s`|) >}|J6NY(ږќP좄%& h6Dw)uuGͪv|BvNM d?vWM@ȇ>zD|h9ӝj}*e$eBeDEl@ vX}sqzv|V!+.੗놿=" "Yp<+Ww[2p{ p|?imsgdsBVm?VÁ;(\@uaeQrVA}ȦCQy >A|=) =xA~_di²3ٟZ_n9ض 7g6:D[=$LCwaQQ9~֏JQGwjx y wTTG#f%z/lϼ`61ճ,vuݴ=z~'mgRJ V1@8>FhUJ!Chvs`6%R*SvNU9Z55aT(.b{=8."•*$)ptxGYdzPhYf&Ȩ6Gm+lk ۋRe" ,% -9pu9U8c&{RN}@$|G>ճ d"lv=}P|ߜe0r]FLOˣ'-ݥ l>:Iھo48~CX̒zݳ%SYPMZWr+DfBa soVӻ56±Ԥob,XS9e(|nNu;躭Pҿi[~L0C)A;$="NC0miT'`91bO4'v&u?n﭂*~9dBB.9;Zs&V6J="MOփ~Mu1o}s~B]9[q&MwKşɗ=ؑsWg%f/2aX|J5wdTJ"Û>KIdlq^SQd 3r4BbӧȘnp !OzQX7*<֍o?dc*c4 /S1X ׺{i >~l߯8@˅%,?u@wr"/]z:P+GH[VJU Djl Wfp"%@M,=F-3An+gﮥO=_"sm?%Dl/z {{7FhK6"PTp0׭۽=Dʓ%-;F_ҲC҂Ȟ]&E}ZӃ.Uk陝+pxS[CUuUH_ :ONT1f@TC ݭ\À`$@ n#G |u9 FG[&ԔJUoG%!WYKJZ*Y3AL'z#1KG#)铖!FX=iYrmzam6N_g-C%v2ٷZG&1ױdjH? zʻFXCO _XDZ-W4;q`h,`gM*,%);7;]gl;leC*ZH02) 1~cMSN26B^ETo;؎!{uoǐm~#$՚ JIjKگ!L nId;E]Id-_ƭ)Y\죗$ݶ@g,뒺[F#,7SX'<FmZ-5acf5{.WQ-num,1#VjH{ ȖOK5t`E lFqFVni^U|0"ۓQdO !MȘ5U[̝mQ0 Q"A/=䣎;\"crdh8@wnG)ef|+B(!գYMDvi>3£1"'AtO2gV#tW7E#1;W!|%?gM`ctG查Mj??ӋtpwI/kW7oymYM@fMksޘY柧V5gg\#S/DoNsf5j |ݲB[@&{ tI~S >arVy2#/OOJ -+r44MZ@ryID 'Hw4ér$ =%=$[Ϩ)Q$gK G]ۘz$?RZ)1]֭{T#aNnR>*̙6(ޞOy @{{&9g)350(sTr"v,R.nQ'0''[pEޜ-`m_p`e߱RԱ!zl?$@[Sw˫PB9EW*JܬBmXi9W%w=U3]Son+atD>c6U*ꈭ6p@Tk붾k2Bt  35%CϽ_Wd*> 5PYh`Rk_ow^Uv?(oG%baL: @(sy3*Cːs mFϙ_,.*6-#6+%q25BXۥtp;g/vB !‚m |?֓vYpy֔a"KW(&Ya5@4BH #duFȹs~Fha0pg(b{F $r4WkBV<_eպ|;S3D&b #K S@'ȶAq(s->Ue Ki6ԹVt9yω}d>O@*Sn×CTGnZR1Z@8:?pt:R56wY^~XMRI pt=7AIۯ# ^9@n(5:I1zғБd2=w9nINcI&W8r58jbK0+o>Zt2\*E#r&U$C]6M=4 vѵv) "[hG?߯;V2v@XP&Ì aF4' JNJ ߹#TI Q!f@~B4 I\ I@r#$u$zͮ:rXr+'I')d:BȴelȲ,-{w՘WQ*#4L)hvyU׮@HV02W4w/|u5ԽQr9>ɒZܭq+%o-(˚]+&t_%ɩHs#t*uaBu(싣mqS9m~MYdV294\UA3Gf5$/ G޷ I˾0} Nww:*wͶR4{ $I2I {䗫 pmEOsG>8R]kF9=B^g*wp c ~)d }aK?? o"(o(ʽUn0zPʑEiBwKa5H-Vϲ̽0լr% ronRW3û@Sﯲҽ?0ةgB>x\\rr1B85VypfU}G@H]<3I,RȞS փU)Bt'auXXwܟZݏ@j?95=lҹ|V kB@:wdW=\6.ʝu_iΑ0Թn?INUtL|%0K J"rm:{%୞8 ~cׄ~:׀PML=b%B7W;+pZvECd,p;Q.ԕC? ]9dڨ7륫{n;rX@~ @.tR2Đ)f+ T!Co!P~b0emڇ ^CVk%!oQ@8B~Fw ٭^,srp57vf]Rw4fRi+B{xq.#rߣƏ"O Nbg"+]HeՍ!沛& 85c1uDԹ!LrXՋ*^~<؏"<#G{6YWEac0_ [Ґ] k)GK `e(8ȟ+umt|y!*_w.^@)@C܏`O+V⁠e`v[tup $o^:wf{qOځP11EpKi9юm~:xH/LiL逐)Mmk> P̀@((r`Ć)߅喤RZ0B+dgT !.' Pdd8d'5 4@(+_PRwڢBF,2ZQ>{!uFdV1F;ETn+;asR{="E =@XF JPۅHF1.`o0"c!rӪ0B \J7Cs \V;ő JRW]9Hv*wmֵTz4r]I |{Fzz.@ZNu׈f{ ;O5rBF9"ɳU7W7]5?qrڽaͱ $zJS1{m>To!h$wU&u)d<.&J3M%9Z{F ef/-7f$VzM&SQd@na\;݊" W=l6SY fw @H $(rE$ lOr@ȕ\w?_"J[5IDKᵻg^{9ҹ4Ra`k+rA.ô̓7t~6_aSMllvOխn!ɌICU.@pr.76VI4A2#@iNN Q?tzGE-i z#SIdQO9FS]2>EV~,_4 l)m^OG%aȾgFQdDnIW Xpۧ}}k+F브҃\w]޺bH;oYC sf\a7eıDv~nvBآ4 fٍTsṈREVɀKJ4b5][P{s5Rʚ KId9Չ.(Z]w((*(oSCx!35\O I^Pzq@ ^X.(DdK}4P6:v!,(;TEigԷU+J kQ}+J_;RH3XQ%{>7f13V) aVSXn=շY-'P\ZI/Q(p鸌t׊҉On$2KNK= a,ckI>s)|XGդ :.΢T"ʑ޹*Dz%txnn\AkO^gokkZfW5W+<_J"͑$2x=~氶O>uΑoݕ$W-FcOuW}~mݟ؀f$brzTPWKSBǻS|ӫ-=7wPI)q@*gh&JrƬHcv> #NoOb;,@XRvKJz|[>gnZG^[ad,#gT}ej@sNFw``Izoh+ X(#U+%Qt',aWuv( n1O+Yn1ݨ|ҩ)X)d,>F=n<@Ԫ4|p{iu_&8(<ұ[_[G#ʴzXEyV? r-Xޞ+ A鼶O&9Eρɗ`M?Qle\;|vqtC6:R=jD2xMjVҡc9d@2ObFGd!ay413=:J%Cm6dhN( պ%2S0b(ˋ®zsUTG:u #E*}MbPp5? "IR;>$JIls=yp^@ld~_ʥ}~nȣ: 0]W4s*'T%:36}@h!80Hv|+;D"5`*W47ʤoWt|Tv+*c"rlI/xnR(s1虼9 :t6V"w4y|zh.ed-M<Rq:gvy٢9ŧTܛΝ(]db݋'!.z@9eE0kU5rմtCFl[i:钓9zfvH؆e9%z+gsn7#»C-,IN_5ltKW4Q\2h:TPJ;O~t |PJx= 8g 0JJ6X?G~U]*iqlC)Bd$a{[ py@ mE{is}U_vjOz=*DbuQ(\ی׏j{}Rs'/`m5 +@8(5h2 HXV)OWf"s2k DiFO叅(&&)};HgϥW3:IsJ2 rZmfPlpOOz\g|^ @0yjdX?oHܣַO=]zu*T{ԯ,@,7Xs`2oGIގ&CfBSZB;T{5>kGV\RX= j1o=9G]IGN*> G΁I#҈6EAtT%(R9g!ιm\eyѵck^{U.YyY 5(EOЕ-'}>pf^V" Lz^י]x+iGrQ,V>קn#xa{o6a`蕼&ܒk@ =@Tȷ(UWvI\GJߥqzW:Փm0BUJ$|[! Fת V eK3%}ĶIҝ؃Wl%fYG6 p* SwzY hfצ^W O*g/˵n˅V51>rXs6&E8-ZFiѳk|q햖gh=hU$6G*n2;Z!BX;=Xm #{ o?h Ih.'2\*e13~BOЧQ6f$;)vJ e ^mܒ) $]\e 9nFҞ( A0NRy 8I.M*IcrIU xJUl9J{Hb͚mm(=Պ*η삦jM$1wCg+Rqro!I羒y~P|'j{y\9dx,kbɵ ])aS Ոo!Lk嗋&;#G߆G;6T>墁푻ܿ7+ZI 7em wMg}+ݟV. ݓV@o7^N,Gѓa|Qix$O`Ke~-TRS tQr|?h գ *f{,RYVof~yޭ*6Z ٛd,vOTmuvң؎VkܝiIЛÖlƤ/(=DGd]@|ic4@[.} ~AsnX@XF:eD׮:O)d;?1wz͕ 41 ` |Q #'ZiLoņvvwDYQsc9l_cn[,063QrJQvCeV~dXnRD91QvʁM%G!;Rxzc-?c:_.昮)%T g-2 T~%Myj8%eM?9zF|PWDC!$";{2p,ɒڛoGYGnP惨IJ0)|m)H}q_:8VCJw|OцUnfʥ4U.e QpsYc@xV? WSv^/%O.nZ1xF|f+cgӠSmկV$1+.CXK@i?䩄2N߂l2 5- (C,*%I?̀~WcYg"ffPKBWWTII/#D)Y?9MRHgpM:RƮS^o#ޙ@CyIQn;=:RE\NB$G |Z(٥|ewJNB.wQRGQRV>^ض f ![:{.-t3NK9D,sZ^i~)tU/F[T +{ 'gy.-y|ߛS `z<͘tnn)?%>{-mj'+8k2I~O52*1rV#V UHr( %`J8 H+8V֭2j.B}<ͣAlڣ*=һ(*lHpw!H~TjS9eFw yN~ y3!{ޕ #7fh9>s?,Q| Gh-1ݨQyVt^U?c"z>mFzNXYIOڱ0 Uy/}G1 hIHa "?дO.Qjr-_Xl"{6@g~5؁t.6%edoń2P~WUH }'.%|Ǚ948f2khp DBp-F&IzOj?"DQ^Ǜ3:562±{.E}K gT$J\PIȑޒGNeW@ %2|dDp̟-Q A{!)C) ڲH1󞟏AhY#.]mQ 6!}WMCq%)͒}~Eҥ2|R@K"<@$*G/'45RBYBPvV= eTj?);$)w+iB14i;un'}B e s?##f3 ĂpeQEa9 ڶ`ܫCIzBMI)Hƽ?PݏE.Ik$6[Pd\@l k}[ݲMsGD'_4wV{%q?^`aӓ'-kw.j 9\g9N=@CaBJ ROuSj\%P)Wd\+G]v@>o-pqe5mf/kuYVYō#{D/ ۩ Qȑ~ӵ!m3h/ǻ4`='#] !GC^p|tz!x#WƜA@ԋWw n}U<Wdm? I7U6@NV!$+Z˴ݞ\&3/ޓAn1֔nqEp$wMݜ iyPǫ,܃ ,fF%w&z87vpc3uKP|l$ ĕ+dBV~N#u#z$sG^@GR dK[9Z,@۞-a@8J&X -ǏiX=KN Y:k ~L{BtUs$۝iQcKvp5 d4@8N>\نti+u. À(ɬ=YJ 5'7!hB(,ɀfvI>MPGQ΁BTY@H#5 M+}/9 T(YLzNQn*f!"zn8ݘ:~L 83K&XO*>bRCbTU%ZM?9lU?Mp|kzS &C89VNٷ V5rFSc=):ңά [K׀2Αp\nc[Çzگ( JK^zG VzZ糨US>;S=gBUgzStwl39jQg;\^m]]K=RҲm;%*@TX"Fज़y#c+7j:mfF! u&dMd/aEPF٫|L#LqI~z?^\M٦i0?u* RuҕROhnW)eheJٿSȀ[@<ً38dQ_=@8uɫNBz9.j42ė= )-2wZ|߆G"QUwj2FywVLw@ _PMf`}W|7y a*z(b Ӯ~d~(bfd/+һW8xȒTX/’}r+e ۳a~糮JJg,)j]7M !kHw>%0UU)MSK`HeqGYZy'Wbc7?|QeDWl;[+Ks@[#\cG`E8FdʊUv*=U^jeo_/֚f,Hg*\94Tu)]?M R>_yM7qAX*m+x>UoSH~VCMW4F&knINW'\kTf}/ՖΤMʾ|V ԕ= ޴fx۔Tc D-/ЋO.ʰ\ PR w #ߓ OǤ' HA6}ߜ/&lp|˲ bw)3_PLړf{ =iX):[Ge}|)9GΓúY):i?ZZvK)\ſxl|Ōw,W7}g o Pu1`R*MbֽS/npU$R]4()Hw7.{/==1e *N Gs~dӛI "ҴہpedTOfeٮ"G%9{ݒAe *2lIH g$9~5#-GYqB*OXruc߮a$L{1@$w57z4Ͼ֟$_)eyԥyhdYP "gUg*Z&!4ҼG`x a/Ka$ l{r)mlXYn+GКRٙJ/vg<QΕ7{e"zS7$@yT?p:{Mpb`>- qžBa͞;2) z¦;s+.Fa_DkW3&;k2=5Iܒ[P\w`2o >o>$=\oU݀5햞.W I>^]\rU]:զ{m8qn;nlA|/W"eao%LQ"]I^ǎީ^^zJ8}%2u׏/?}% ݾe t֢?}R&[I; `K9î%<B״c,rܬWf5%8v+mPi;B!fJ 8EJء\[VDhut7\ل 7+DScNK cNփv[3 6mWqy ,wZ`(պTƨ-֖Ot F/fgKsCo=$|y$Hg_zYO??W@$!sZ a/@0gS8/O="E/_NJTd3}T3ֿ̩THҧًQk #4o2#e0Pgsʲc #VvSYd6`@}*n!o,+T_^vPoDĩ6m5;gSo>bO#S% ea ֞<]5i\?#Tngr.nڴ/(ǰ.4F񽦶кIR,z `[A1@sH"3c+kǭEܷySvRK*iʫ9uDEe`uA 2 P=K /B "0ks:ִ\HڻuJ~3 L a wo5!On%92"v` _ [cGUN^ݪnQT;H]<) ;Ic3/;ڡ^>kpה a}TmXB1U䒰'# " vd>si>~U]@Am:B?d.{ *m#[ oeaZ;!4 ZFQ[5 X&i2פ$kl:~4%ϮK2rBWۃWWQK9dرDU+#ٹ "uNKAd<ZJ"KRTװ}D!wnXs&m!րXSz*@' lf Oy~(_=ǵߵ,, `?}F˲t)Y_9g‹g9KDvXu0a.@nY־} DV7J2̶="nN1m nB-̵G8l.׵-;~49'Q7v lg}S,~i)+əB2 _գwYmz[~jߊ"4NMMguEap+ Y 6bo#ߊ"Wvjw\G[Zx7Q'˨=.ǝn FߏoǃcEiv נuMo?!lX˽'E~/ʺ&{= o1wMp[ӛk{Z@viÀPs3 - ׭~B'mnоA Q%@HpS +uc3|okWqZVݺ}, },=۷K7B.רtnkS2>w)֥v)8: f?w mGH}GA%t?#vX.-U_OWם6kʛ* ~?ENuVTҤrb*\ZceVU$Y[y^ٶ?(H\(n(f*%6'%^يZ83lZ'WjC *uTO1z's3wEr~1;ItvDqc=AvϬЕJq_} d4?;f/.ߧ34ӟ#n5”mB8<ޒ| O]d@8[Y0ditlg 3gőՋx?#/8Wl:8ldk諳\ RU2ITҭ4{}2P=@\4p軰k<l,\cGI[k`J's )}LUOےp۫42¹,Znos\%Y68aXu#;UYZW]UVGDdΎ> ފuDҞ/@2lymp|ӣόыa8H-kDrgӏ!֞\5(yQs6ѽJ"«(%1WuyXϣ4x{s$M;mxVq@xҦ$ycy(nP~ܖ *Y;x^@Ta8Q9Ҵ;ۨTe@XE_'Q4@ٹHWd{BvF]m@ijKwig3p̺3]h"ʓv=P<dG*D宄GrB+֌EMN Nc(e5 |fҢՈiKH7m ժj ") nժ[s`7J#[uSJ~"PE UkF&^;|z!4\O?kF I^f)$WM7< vk>$^'wo YvA=N,3bwAL&"2o$[9#-9&Y>@gH ^W7fC:Bi?K(Ba9ld*I6k$ŷa}Ħ9wdݶo^N%Md- )SV[2F:/z8k"S  t?]@pZ!'`J ) %d}ahh$-)l7 L58D훁zc}-.]p#*Tk'+:nՂz!YSޔTzdf!\g*VBt\~ 2^pM$|sw [:v,;[`Q*Zp0lW2q翕 D#dωh֎MWxJ[7kkwk%9*3b ˄Avvl1vۢ:~Ȏ0j("aSJxBͫwM$eIW+ l!Jv۵I>?825?fi_D׽e;>$@Hu?~}b ᾙht7zw} UGzTd~ ^^#]de2%jG(:( -+# [f@ga;żou 3qj-iu'`-s :2_+jVo|6X7ʟYW ߣ]d8HD$sɾwyd H>\n(lBD ~%8rcjk7f1cq{q$hkX~Rq Ƈyirt91<{߲iu~4? 8 F۸_{%j9~GDo2vϯ #$#U6=XESFВ`yɤ8t}-d#eGMKpwd"YmaCqO:J7n4ocH4n&* }Ճ9E$W#۫~ y5ppdb]ƑO#/M?T"Y Gp*2_p*q6 GhC8[+LaHۨcG8[XH~la! qD{6G&68 yo:g}'N/pn"fo,&_>ڞg#wVp5Q8"%ZHon¹a^иߗI#o.kOةo UP/=߹S^׳ZSdgޚ!rQi+m;ov|8}Tߟ %{֠oeT/`Bx~L%{&/'hv_d*ٳB8.1|c&_ !=?j'׈GN:?wbßY[@Xo޲fiK-*/G)zob؇+)?u3) oƓ1k~GQ:_kUjXy5VBH|Nb=n7l@7i_V׷H&+!tt ±Fz~G,, _k~7-{w fʵ=URuQ7hZqù-}"o R M%qj~߶f Oh|G?[Z0}q5Gw[H?JZ td㣜%[ ul*0y$rH?zO0rW'&[q"lG0z8rBSj#=xrL}'^)6c2>o2G>&_({#B`!'ɾp+Q{vLvG'~QAԉd5gD2EPt?H6VXi+}td:n^Xn8s.,xje}dGHRZu¹#1+-D<stB#%C| }*oomߘ(XqD|,@2cY{wGʾš_Xo v7I4NX|)#_l1w %5XUN͍}kUX"ch|"#TN`_^ܝ_-2/ Gp`ulqt`tTÝҝ;=$Rn&MxTp7wY!ugpD9{ˎQ7?|+o\{_~X#P•ڽvv/J.m̏ȡ~G#^_{%w/;韠/ܷ-#})t8ҷq*׊yG\k~:!nőϱGJ:ooGJ:1w 8B"ފ#%1GKBpsd#f#)B/M8J~]1%RqZi/G! #o {~m?!̢/~#w#Mi== -\ΟMzGxQ_3 O#xonss#pN>}/,u~x#% /~1?_s^ 8om#},G0St `+𼞞8+Gv^,վ?@00NsyE,G0O}1 ,T{@[}Q˨< Gh(?ߌP\ߋyd&h.ڛ<NGGd'_ Gp&GnaQ6Q "_ٺ>JG{n??"00)q=#(p-_8,sܻr_^E, .svMz Gi9|D1¸K[n_~qK\yw8$@jIX"psAWJe` $*}s7d~K!XѸi/IS>Ng?`#ij$ӟB #+ u=q$lBqFhtrt$ϵ:f|_9n)5x3e# Ɵd<# hJ/|MZn,ff\J#{L|U D̀#}guwcc_6I[S"@W]]l~9;{U&܈Aԋ &X Zh0xu/3n__Ew0; #{״[eP LB % jη*f t/=YI|慹݋SLsd&-&! (}<Ʒ\Trph!U9bۚ ]i,s>)@ʲ2̨MQ&pJ^Eʜvd`="~ܼ\`I27^$\쳲nZRb KlxڟV4faOL *kd]y'v$n|k}{"b{9ɀ=܊}mw@,2_.3s5k(O%^v:/:q ,/%5n:{n3)ˮ1CXq!;S[XG-v[ҒKݲqɈk=)Cr/U;1_PtQAx~P9hu+p!;LVWr9-s&dynmYWxUodw.$ KGoKWė u&~Z !OqKP4h+exay&=K 6`"?JR@' XYZY˱_ndق?o"ӛE_ʶmتNueTSi~>e巄J/u rX񫹖 w:JfZ-kz 8`W3 q7E?0p/T<;3T 1vD9,ӗ}i~v{QdM>NP#6wJ6Ns[2ʗRvTaһ[!I;«˛997?dd@yl]{oJs ڲmI$~ûo5[VQ)847T/6Ae<Wبl[S˖Уi-nرAK*-IM"Uɂ^\/ vdR lJfd IP=?қTJsZtĻƽ u u(B'0l> /-}`y[Yޡ7`?j+Hb~O$fmvg'_^0V-mOpq}˹~GZdun=;롚TrT { $5; !O\]?5wf|bIEژ-%|o'as&@ w.ޮ3L\ rZ߭,]i^&U꿨Iy[* 00` v:GϪYWz/Zk훪L˩5-ג+XH0'ݹt *>Nh}ްb5 lܳ?W6aԯ3X޽شUꮲNP oCt^H؟ySoW\t^_61)w{c:9d*6G| 1NqY!:X )3uU>Kۉ`"Hec. kn+5- g/׵g{ N5uv x^% ݀ t#:O3dV-sqhrubeR-BG0udﯰsО!F@ee5pbc+;. es5h*߽U}iCr[=Ɖ+mI:ObWX=nusI}29 Ma*/$qC-Zrx>)lo"5n*2&3Lj؞7n$47vKцzeI W7 79~c- ЎH__7yL 5{k*t@;yJeZS fBU_R<v վW'l~>~ՌN)ďE̴CqP |̀ϨC,dgWڭ^~-n3CjZa$0-QaTY9|:Izz~}%Y Jp xٲͩkdċNU,q 0K}C$8noI4K`$?"Քe_Q$h ,ğJU+N28~Hx ߯qO6"`&̵CKh16BT!SW`X1j5Vw(^Q]Kh@` ڎޒz Ğ\Hҳpo5FߗCjA{,s#1J(U].3VȗbH=(.1j*ߔHT J؝=j%&P`71EA:*lQMQT2yTO߽`I`F)3|, yS<5G3F0DG5qm6U F2ϘzGkW;vnFa6iꑡp֍00AAAT3ݒp( l)ֹ;3]bI5Y/.&A= [J@,=?DS_~>72ud  v$?37 AWP7o74pF M<xr,IzՖxq)E tF?W/QZArɦ> *V:zդ;ML߮(chy -lWLگ 7Ї.{\:M&P|f!"ˆ `Asn[1_ !:!sSoH2zϯ9e 5 8IK9ɼԦ\ _ 8 {x # ńwoډ՝tے$m~[UOBTp}~zT)XJKßcD MNϜ׉| _Z!pt'6eʹS{k X xO}|a%(؞GIU+`ȕzf&LǣJ]_EnAXI/BF ~Po-ɽR]jy/UhGiMލu ɕp0[K[dR%Q2*~Q41 k{9n`7Kxvë~{;5vx!l#Fxd^z^QX4oȎԅ7BXmv&.ւ- +a =6h]U}$7!' kj,qu׀sddh9 K`[X^' ֡UE`+U^{C:*fͻ=l ̥ [>Z=5geZ0JNZϯ7Ԅ&L*Q +6t_ڐT8oJ|eZ]ت6X(fTp"jl%}[m0Ow 8{iHLX?J:ͬw'=c'#OKT%ra'ޚT';zb݉l&gI#zI$of {8iasL;Zhy25`ק$DQ"xe{vUz LΤѳ>1AjOէFt̊ʆJzោ~`K=cq4]0?v*CH5j (.϶)ZDkCte3Qǂ1OiG9Cog\-+kYm)L4(uf?/ԕ{6z:}zI@)KLގh a%N,,{'fNy(C+޵Μ_#)MډoxJfAp l_1Ju@?=u\8r ؾ2ꑓUd*> .cH7]'`2P_(>< K09s^h }bߔM2b|tF=0ЃσgK,gr 8 8+xjH )#=#ODOHBނgG}v[$Qَܼ@ BD䩼hd $M ?!p?VV$;+ @nE.=)VZX2CWitk quFk%$~0Z4Z[*j%zZ5M+,ypvHny[Գ=[D5;K@,X'u̡# _簌4O91KuFvX5ֽTu;,0 4Qxq^D=^ AYUkL|^4H˼ wœ華!= F,B?+?D9{]H;y0~I-$1-D?7(ɋ1{P.[0j/vTW|ڏ_ŒY+Oq࿏P&ô%J?بG8YAu{ܤF)yYۊٳ9QI%(23R&(drFlZ<3lMHUqfF*2J tNT~+1a,-ð8Sђ@Q_PϘ;Ph2ZX? ̴}AX#屵Z{%m0G柔V0W|Ϸrc2Gim-ڠ%s\+7X $z+[epz*FR0r;G0K$T߭;_y"ԁ*WyH('ũ߲GUY-/MY@,B6"rX YƟ4(fݖ%>)>G.t ۦx*X^`^G{gj֨U>fH-'( mH`cĖos$)l:6z=R`!%O:]YIVz'< LMN5",ڱ~ϫ5p -^?<{5Ry~wM>d3f"+oy.lIi#TxH8`}bK֡6LRhNy]hЌBRBcOS6j4)pp2Ѻo@Jg}:I-C&gZ* 'LdDc%mPژ8T#`qy;E4{"U_-1"VHGAa)VH U32; 3{&Lee:}J'tCOx+Y;&:{#Vt[? HP={]1ÝO2U`*̼ۇ9=:)1vZX°i-%z:3K]ǒ}w;*2~Q ˓u0ﲥl_ haVBh<Z~Ii0lY`Xj+>l)pfMFzf x7+>*U[V==-lOnåFhS)#߸~vWx+&TWIדg]I'LoAӼa8<mee4g@b* o@#3]٢z.̀8m6ͮ;Pm _{xDԟ55njy q3I8C{@))-#nKwȈeF|$@{?[g |)XnYe +qC ˅*3 ˖8|Vg-3Y@RvX`7<_|Sm2 a#+ U%NǙ4on9;ڒmmP=߼kFWĐ7 V[s. l^ɹcye秿o@qN*K+:9qWN vx#üB,QkˈkOM٦Tik/J:;$πY27}Uvl-1-3]ý%i}^2{K 6vGm&s Js6犩Kn\83MZ3v{bsl+}N-uݗs0d'pJXSޏw:{82J9STI@\x#Ѧ?ZjĥJOM/}s'BsWIL0;aSw({Vظ]WQ̵*Re_ [\򡹃Ql1Hy@*_bIa9.m F 3&}+m*Ees0:}–1Q;a |/HiI`syDuuX@[Y ^x"Qx FJ[wvvzĻǧas!g`ɄIi$Ŀz~"`0ܨ &{Og^bFOb6:cv-TX^C^}or(A6x<^ _Y 1AHR _x޾P rbme$՝=1]؏jšM&nZc;Y5)1|ownY=Jd%&_\ F؄X!P̚=rrr bi;4Û7%4606Zݼ\z+7# D" ,i҅Uѐ-qғ! vJ2JtezxϾ'b$pϟYpUy[Wzӓ"C``;Oܰn,2"[bJt=[}yGK$>Ewr*&Y v$'uI]Zj̗rxIxt?GR'T e S 6LeX"qK 1m[+}wb/4+v1tJos$+xېIQ~w ײT13` ي=ܯ,NͰmCƒ>/JMv,ZA[&GJ 7mk%شv0L2,7o,Hf{D!چ`c┰DLlѠgyCcL{_E{ou&@:Ty7Ŝ.?p/C?{+}̀(CPmy/ aqQh|2V} [ w%m}Cjs"ƪ`/e'y}ΫВ{}Eq؃t;9 L8ɶX+/>|k̐xۇe5ܑv}WTXulRNlG5]aB3ȍ$8J:=MM "J}\%[${BȤ~۫$f;Dnzh3N^íT]YEhSɿj Π{Nֻ0:,Ht;y*)^ BSbtMyX{6B>1U}f'B=[􇏯S_! Զ|vOWށ/i<<9) JY.?+Ek~> }adM^׌h|]2SNs&=سFx꯫Wb ,B7yܿ%fv5R_ ^0D[ONJIop)Ŭ0B22&^1Җed=Em5JYQ۩gGbkEȡ:+~d=j:Y$%"bn Ұ[/ D^%ue/h5RSq{T76ݻR}d-~oQ(JX@\nx7zU\w38OiqC#tٛӌHG=|z|Aƚ=qi ɬ^b*?gG#|n8ٍ[o%AI4yFpk31yg#cu򾁓D|m&NX f@0[_`qs$&ޱL[FI:qq_It:"ӯ$t͢C 5ߞ)Umms,Jb_{ڹSTo H% 4O)rcۍ |AU$@P#Ws+n@ EhB0{m7(:I+' 6McL^Cq-/ç#;r?{eNxmkr܆Ȇy+k|A I{"-&:6EIew'yM][X3kt9 K!elVEx ;:w&6}˂baWSL/@"4NC6ݳ@Nx䙽&W'V ,l2U2/̊dM*I%=M*E sevSRkn .>IG><^FH}m.ŷ KSL\~3k2){I>P3J8dKNh=4/OA~#JfEhuY\P[L9fLU(>z0rް j6r`T=ʻL2>)#NrLqDzzdS(y ͠8X~@d5Y@%$JV=p{9_y\@~ZS[Dž5.H!D`Zrw*,ٚ_ t9;ڽ%gl".3}y A4W6Iz[V<#g(xx1e({kc l{ۃN& 5D7DA9\5uZg@ Rw|>KT8fI%2x'•/Tb``@oTr>5XdVu6D-t, KMFc4V{]4p@Ԟ/ig?ӛ%fIbEIו<-=Wd^TҐu Mgv 4mIەdzUV+,Zee {[W+ o"P鎙UL5P {3. ?t&ўJr۟=: 5hYf"$l S>lsd5>9OW۷-Vxr̷34@*3S[[—u'N1)6^>*E*1]wM~BCӆ}e ljZ-"^|YSp)ɋ >^e]p$ {ץ:9+Ub(*ƍQU8u?MomܙM2Ͻ4;X%y)%ɫY2 =榕+ہ1t5zeTX69d dT9{<-|We&QXY0W,5-=J0 8 a$&;}N,|ճMNM' /}.<' ewb'[Nbヾ"&93<&.OoToV̋pn*P}vҀ* ;EU jU|PT篒${Rxk06 N7V+Eezk%&zIim䘑rs269fUG_Ǭ#Jz ぶ8N,7e2To \%a5|=Ӻ$ s_ueXBB$7&C';NMX;)=1|]+RzRD2?VD5h~"~֒(%PU`I? qpoPsݧˎ:{Vqi7l_)ωn h ?X=' ʱ/s|86 P.vEOmF&\_=qo^煍)p-:@&!L!K L|0+UsR !6*5Ym}],hl |y,kq_&U#]EJ"JMw!1ą;}YaI^ WǚAM9֥$1 .v}n s^f e(ᵮ>miC5?$^4B{LkhݖJKs;Lgvd偦B*7@*dpf^dr;m iх|u#$;!UѤx$ ,A]6TD 5jYЭ'tJF#lx1mb'^Fy:`b˙N.zd5 Sd Iukfݔjv.vSnyh1ݳϊP'MtB*)%3՟F=*V JzN)%֕dJˣQuN'/O-W½6-RQ8w`GM$|1"cNAee^FHU}&fA==A"㶧~-_?hקDٵ0ukUqId}UQdk XI oOR£> )3sܪ++!#, 8r-"p*qgNvM F3D[JRh@']m݂y/qBv+t>bl憍'W!V~?l66<( zڨuyX9\we}Xx7V\\ ?YU.4ú z:  Rqk@IL(M<]i>QܼJpCoV~# `"A| 6~a7$a;YqM[O?.ӓZvn^Ŷ"zbY1PJ_ɧ9a{yjXy3?)Ъ59oNv¶NLRgZχq= |?M7?|Xz?zf"NO;Z9aTۯ_6˕ QO@.'7#@{85&BBCwr1{* AG{}yπ X4V 1&7Ԡ0[OY%? ѱc|4eucʶi0m/ y+%xІ`+h$[B딍=OoQY50 VAgR/T-18n)+)lHbAʨm{82@Ejtv/4 SyDmŢ:y}avNA d~mu<5Jlu=Y DR+,G98``V{="tkش[J/.4'ledV#Z}C KHKMNN!++48qxc :^6u T@u058>#ۘgJ` ꄞwAq>=N}J~n(W.z/W\r@r!E%p" |`A]}3`UI(3Fՙ2lb>ke>W84YjHFzQ5#IKRe3 y7֨N# B3K'iroJh>܆^RD G`Qd?tIԱ1;P.{pO{7<ٳ'e Gc8i eZ FGeGƈ",re@o%!QZ^W3X۵6XZw`lL Y)dtTu:e]rLCU0<ޠ !Q[Or˧_0Aħ>XY>q{@Yxei峷P> F"d h^>i@l}^riRtRlq.RHSG !ce4a6`.tڢbk9S{Zge+\}f 5e>g>uGbgBWy Ȃ"0ϻ-RjDіN2t$͢ =c|;)i-[@.8ZUA×3ѳ.QRQyj #kֵ>5 7UC&A?qI$=#᭷پƞuX=S%;EY?gʈϨT(j>ks8,2΀IPN/=֭>{%/+, 2ȥ-^.pOv!7ObU_/y@bQ-!ԧ>rYZM] V6G  yn! V쁺W{ 0ɦ C Rytc$Lɖ†ԃ$'J"\ET7ԡqCMx^o+"$<#"|s,W%:G- ƒ$=P2n|Irc@b1-ܑ3DL_ %zkuKl+29tۉ 9$v^T$2G*@d%?RJN>J:fmqc]^BZ/ @Y-6m)^ *'g K:SpUyada(7·&Fn>Їx̥jX>ї1+P2ASgMt%2Sd HXSjS4I̐+ef [˗+ăPU][+]P76C?ZB@ogLȷ<s~HI\yK6Jby!?^砢 ˥ TdE45}\WiZs+?»/>G#Bu|AF$&jt,![9S卋ICl10zÓPT~; 4B'n5CkSU}Jdȅ؞3!O0'h7\9؍=#T,?i3~gh1Ό;jg!q5Bop3}u>hF୤h^9=Du{=;M A,,L3K})JDY<ȲO)%wHL &@@mzk&LJ;"{nÐ$oц+–E0$^ ΔV<Ůqٳ%Ğך$4m[ANjVQx y%<^ [_FҦb!4z"b ;1F=EZ'>r!hk&fy%!]YSR[p Hum~C^|(5P| |#Nr^ϿCҐh ~9i6H<{ fjЭ@VT5Oj}ڋmXB̲:1 ݯƙ#4l.8~{N$P[LJZܶYh¨ 0J֓TRe7"(XN񆄆#H/Ď<# d5(j+0 ~n~Ӊ? X=.sbLC@j,pZb_qkԽ.G" ]aGGߑjʠʻf?a Έ{@WP `O.Hr؍!7}"S/-}n%N7da cN(tChYXV@LJP]IFБmMϭjE$<sRv&0Fr"wS'=Ȋr:֦s>' g[/?d5 dDUnpBb=HW߼EWSeD g :f\fIW ߓC qlϢ~L,.xgh9-EgqیhD3/~Rm-DPxƥjسq"?f9?5bE"O(Y%;|k=+ē5g,_ROA!eUC݁dU/76#YQKcC_Xys5$,tgvu?sfJ AC jo0\ IxJV'qr@FԐ;jI xbtz>d"=Wxs$[7j)17 ѮGV2^G -}L£z܆b6=X;FH<;'oo0Ul%_Ųk90+cʑ˚j+NB9% TL 9JȆjF^o+0|ux3NF"Pm%>&$o^lY"D99lDjO[RRJNN^SLy/y[{HRO[g#Ͳ0Цlf$#+* ]yB ɺE(uGn# J@koY;te݀QN* ޻7%:Iv4YK9zg_ rƣn7}eЌi* Rf]oˊm a$PdM,? HjZneAEUOEѨ'pD&p 5Ykﭞ#>Gv(:Eʅ}z$=>|(ǯj%/޾]%ocߵfƸl +  =}U.qBY:tfOd_k3l;ɧX#*5ďYgDI5FLȁ.OL6='oDB#}Z9qM)y^W2m Ks1}zAzԣNCf6(}ZK_KFǐ@Q#}ਸ|JJe]Xru|9 ߞcߢma&#H;FD}+WRM0-.$_v>S4\aA !>!=lJ\4UԾSy+]yiiKdH,3r-'9X&{ҫ)8C],Iᦧb~Y T-QQ!E`6 ńܟsBfil;wd$pd/[8*[aQ1IL(h`[u"-)I=?2U>npQf6H.n g 2S #b ֑L1jhf/ rӧB6s6]i|Cf|oon]]Gπ8/MUi$_-Ar voXy^nHj](BA߫%#v]€Aو#D~" ehBBv+ %1) F/z)7!P]r05P[[rta.V%KE,R_ ՠl'I3rF{:S X 4.;l2n N3}c/Si<&B< Lܾ,MO"~ X1M]EC6Kє?Z-W)9 vk;çA4 [\rBԯ ٰ/`Xemh4qOOoB# #잓o8:w)жC;rpka0i.a8Rzo-'zJjTf0czplzzyX3X?k]zTkL}!J3"#L|fw"E:۪/9Sd*n]A`txi fTPQmhue 79?-;\or*Dޫ񺆼[?WUkK`qaZ~ރ^wZb#Xqďu%J*IS[DE>$IP-{&iU[-zXgGܰʻI ]ҊtNjSoHGlSM%DIiZ2ꙵJ&"+ d&PK^ \sybñl#>m *E~f4_}cyU;ֵ=!X`|{"[u YRx@OF3>ڜosVRsYDb. ܁HOIT mIU-,gClu==3 =V[lESؕ}:b⧬dF0ļ6\{4ՎWh%1VĈN&e֕0 i.#: $-z'|˷g5pT +˸cYrJ[ao]% L dLׯ<|vHI 9HLC/>x!#<\WOd&&|S)<7“NXލ̸{@~[/öd>o"ړFvėe9Έt(aē+q-aA_HX.(A׏S ȉaI4EH]=0t`;$QAD `_ۓذv?-5 {I݈&'EēҐkY쨐9i+xS8kip usZ?9mWߪ uߵ"ܧW' )(-!3 [b6Q'K&:h-3iwfS}pC@dze:Rn5 o5 O/-5u%h%Gr0S"/LM`zg*228Or4,N|^i7v{tjÆ0y~F!\ڟ黵j ߳$ F-  >:w>E͑@X='Q^ʊrrsery> s؀v;a4ېX$m #R&%Е=-f20Hw% .Et/˞GRfæԖ'!]YLfVWAκEj7?|tA4?/gafXڨ!Aya-&j:c{t-%IZSԎԳ]%YBhu`dIVp̅ xm$ YS-J9 3Ê\1(Nmo&?`zWՓ25ħ?C6AW@@ cHJp-3%PC:a"0qZ>eq|A7V#} R`̜K˖E-YC~>1R [ W;0b+Te>%xT֒)zR}hdž{OBM$,%VQ%y}7vd ͝xeN|+m%3xpYIq88=6]/j4ia3J>u\>঺f~L _|f;eYt5N3t׊> Nc@eL" 808G,4|ڲ_׈ m+h]xPmqYf4mAP U.9}p~D۵l.^ _XCu<ְ.A8 0FF FVZ`-)VHҜ IȾ&FKǍr0%OW,r8nF (LV_H g$JK0H8zgo64/_Pzx-q/|-#O Gy/ӋYj^  lj%sw~>.в ǿ8u\I>SU1}$7rTZz@4٤*t]y\vz769tkc:$K& gXo|e6yogKg|o=C9yS6Iouftl]UcB54ۓ"^i.oH7U -X%p=B'IX%H;yQQ\+ |T pBtKmHG0qbny!xDMb8[28{:?Zm۔R =*# '1nqWe bpE,lW4T([ ~26*!g`|/]oFT>qzvqP95WH0bHg w8@{lj_)>!OEݦ60<^3,E51"gOftE"A; E/>k`L)% H4[#aK{}(Du ,d3ؗͣn*L@‰2RϳS1!oo*n &g99~E~S [dlDŽ^ gk1{}iGCƨύxr[xeqFAªVvJU&H`7]}{,ee.rʞ~1צg5 n>%KU~1<^60* vT!v:J-ݺwmA;4zRz)lm? * "C~O]Etk}y%)#dž84uVhUJg=xF2D:*^#tX藨L#=^.ld6+w*\SL1~'11҇J;rCJ"N4#'h:]|bR({ez;1,e?jw|? ;B7"xjh͗2بS㫼ʉ e,+M^ wG*i40umMhWkH`/&9poվ=1izN#jO CܶkMc?V95n;fs:˾=URY 0&v썭ms }ng8jlU9/pռ^&6߈(!"a7ZA3)j-@)+Ĉ`Q ݋J3Ȳ{XsU[O'?r%:IUE\}2)Boar/έW2~#U_ux!msoj$e Wp`dle(%O.(])o? X LT!vݑ2xjHycŽ]['!t-a,#xGdOC߶HP6Ie઩|/f< Ww~*A}ZS2ZzMχ:?h>!'i2jfN>%KkaR%㍧A*heHYLS-li__zB&xlxy` [o~}ֆo3RiQo K4=/ڻdz|?~Ͼ' (KPUF>BC"ulE(H %UKvN9L ~ r7I?UA@`o9})9v }wew*#@-C;[Gj_Ҽ9lǧ >aYc xmK7ǼK%ZU4w9D/-KCopvaG z n:[4C-&x7Gmt1$g=0Z4xJJ~=jqQ 7]ZNJޡ2}OwO/6.~g2A\$@x QLDzee_^v;sU~7Fpc b>[A?`{,wRh\(^ҬӞ_Bʮoףh3MboZy 0η8Tlm?Yl %+ն~5)kon Tㅢ%½KzpfbC_(!1( z#ܛKdCi&JwD{$r. ʁZА`dM@ J?KBa$v!lwwWTO@ rP{׳ŷgJE;kplNH/4H8jj(d'b,IZ>\\OT6T/:~顜wbQ"7J ?'XǛx9o{ůڽ] ϻ~sPgߋSGyA0$9@u~*K,Ұ+) T&e\gYѴGRbHrïGа{aP%cI6,E+y gɞV)[zŽ#JY\A~9/ ͢h}bV %4NQQGhO#4 gT M ^9=ނiy؏hq&3y=Ttx^c3$w]`Nz!GeÌyX\iud<%D¢ϰPJZ@}A= #\6"3eM ۈhE_ 0'<9Z@Ҏ_K$/ \ 蕨M_(Tu#mȆR#h`J$?V=pw۱3ӂ(1c_nhu ڇGM=Y-O;?="C߁*r''9$ e9·XEOY!NN5rYCז+J]msRxaZU HEͩ"r] H0_b0FVx/}fR@#T} eڕ; o%~?מ*X8Ai$#oeK -["~-Hd% :6~qIh{Y'PwwT[}ց \~rweπe||V':-Xv1gP XWS7=mw)q0o7aǸsS}6 PKS/$ҟ1:ӯ<+@b<3ޥ<iG X*z"/IOXI9 o-0NS3JNR Jl5> L筀g'1$ljϽ}M\̋떼qL]G!:e0Ǹ[ʼl-*DV[bw] MdTjRٿNsۖrb#:S %JI?c(BQ.^N4xn/`BgR`Zr^_R 9@{;qJAT ȣQ6iXfEH[rf?T4l/ojAؗ:$+\ٿnU%@HŮ_E<~dAQ:(N-"}pnw/Od%ȕt1a:ڎ^R4C?݃G%Md5UQjb2 'k%P1LUV`HV-}?gLښ |bY\%N_bSȏ|~@`É-u?AZnCБ9B T^L0xsS9 V2 :.{0 DHpӖ!x_b<~OseYLVt%(xK}d^/Mm>H௤x|ar)x+}wcG XW4Dh"GM/*BSE9Ow:L(M}>CRʒ=d e<ԡY}$dZ{,+v(bAO _m{h'&,9lܥ\t| ^.4ZTҫAnTR:VV1:B)}3yJ\6B)m)ȜBI ;xj奐U648QmC(+tMG 뺙&glja uy I}OX}Xw[T+nՇ_Z9u7JdgCi$~JeG|@Rj/Wv z_5yC$~gȗ;Ę8+5rh z Ȭ'gi H|Py|Gh}VxV[}*!ҋgI!ܞpզƒEJ8s@{|>zi>DOPuhAPq"UP[EV5қ՝U_\oH`Clp 40yU1T>V7"JϮlHm=Zh(Ƌ,+l<'`U7{z%xRbM7/J~뻟}+LэMfOU[_}[h'Zlh!F|?xXGkη~薂u\w17=1} \J~!PB}6Q8'3p={ݼv?Nbˣ+ߖwc@b Q谼_Oۡ}5s㱸@Sr7Aٜ90£&}ؔGr 4m=GIn}-Qnn==W,ͧJY{ɴCX]qU^h7$2tPesW@0Y;:*5HNS T}D=!HC-?.L .߶OMu8,lK'^ aA%}r d-n֦wL9.čPcn `\j[w̾+Y>ϸ[A;hyڮw3E+>LU`; _K\Bz>ކ{Q >LvU* T:ȉ"zTUWCGǽ^ }24C͠-*׋;iCYSDEm4ONv:M,?xOB#;k5Iu|>('t{:otRP;sm=GP:r ; j޲|MN`óIjbДc `H C ?yeqoP%?#?'8IW8.]_ ^ x1xb½i'* H (͠B,’(pM쩹iĪn+8ec@[ Mދ=!p;PO^OGLG dJGuj7QW6!ofOpF8]AG6*no~Ɩ&4 `0x|BTN[륧k2zKfEB Bg@f1Af!GP2^J@ K//-Ɋ4Ҿ8K:Hn*,=QP {@%nim|$>f_ei4[}'c]4Q8:J'% g1ў—/ 5>WK(b*"12dW|U i6JjTqu{VLKHgN6xOy(AK+c dF'd j;%iok1*1 {%XHh0]=~lk2#V18˨\![p&K}qK'Eynj-/(<ƉyzN_h+v pїwUv@Q)${+| ;] ˂h@ڊIsޖ}ij}tÛug( CGѵ7/d ;n?csjl bԍB1ё }eɵ_0 LJ[PUNŴ5u!.S 3q7n 䉁]%RRx2 :e%~ [t4i>4œmc=,k=2fxVxyl߻CTTF ~c3 XFKm#.;%J$* -q2Jg?֪)#] Wݏ5p;fD.3sMV D[$FUZ+; _?c}th8\ҚF(P=ruY[nG%<-h?0vF{[P"ڽ׊4sPw+,oc4z˘BƹҺ( e !" u^/Z`>DSҮ FHy]3G t FESn֟!ߛ4 -`+~8DV%$-7~:ȴ@=78%ktAwS/kgA#Mq1SU}>*{m$}kK ilOz哕ewaW tIRU)K@x|y:f?iRV %֯T^WT3p5Bs_[a}d ޥP?@ Q;}IY^؞$RtONKNأ1bsL:(u-5AsmiycfتA.-W'ڥ/ɉ,׉/ԜXJu&f0=B+mZ@-c306jsun-;9|)Пns&@Q HI,ILEBS:-jqhQq3W=/qP 94wG|0Ը#&`_z.uЯ3 ӗ;Dzck}^lHa7>;n*eD=?1>,HfM_kLuK|LM|M$:BɯY,%}/L^Vi(ɡ*Pt C af B'YZa.Hnʴ$-.ςC=A -P\%'9׷q(?] j3Ogh V[-[COnDdPBqE2VV g6hޚh՟$\4VN(-9O^7[ U?Ծ~հ;cGlo*1S$(ԝ~E@<9=&.\dU54 `!o *\?o AiL}v5@9;68kp}k1l'uW ̹ ?=>u('sJkU@?[v%")Lzdb ɏ^YE +?̥>t %?,Z7*Jt_}A}y !.77}TyM2}P:'p6lbRNe1x@-/{I L{{;(zs_#$WxPkKprJÈ6^];cL"u\R?O0dS? V`vҋK?dAO!] /{%MUdVzv?);>F!Ghlфijs$3/xSU6 Ak|5/Tr@iymcT:=XiT֙vBK**Xk[D")0NA3ǢPPg+uԝh1W48 ЉE_O1N<-39 |U)?]9ӽNu7"lGC]f 8 4I L :HRRZ;} v8BΦzsG>Rx|9B)fomQ6\Yݛoy_"LQ߭7lhz@V#c^æ "+O7.ǐ4A5jNPC$_5?CH<ѣi> CBJxl:C1hG\p\z;-JE{/s+ 8 >SoؔXޠĦy]0 H\!g}nMu:CuΖ@eJe?[Cn-҃~Xf{PuU;i!{:=Wcܚp@e;ߘ؆ Z۱QR~9/P$>Vq3mhWl^hB !&^$V_DA/B3V"+ }2ŷs|%, 8|deG4]X|fb?aKFf2a˭C{+R6 hIK{׿V/WӜ4Rf<,*%Ҟ Wt΋G./s/kWwZ%2^*!]Ư(`#;)8S-Oj3#X;R| /*(pw`d*>h[[o7 A%_Z1gK *4w&C9oN6CF{z z)w!KYsؖxn5|ڝC{v=%w|A(Fa%LWL?T7=8\<ץk }zS, *)$Ľ<'}^L^B׸RqC֝9:j8jĹ׏L0[»A豠P5#M/gDjB`0^{4ŕ^ < ~&]w@ʣDt6ClȲJVŸ^5юcC_O$rLN|j!INv\{J,wb 1UY< ;`aS(mywZ&,lo?Q'bsQ|x8V5r=(m1꯴[S*aFܕmQ7E8NkAq +C+? '3ٺǍQ13l(z(K _"}BR-طRoftZ9 ȄB 65]0{3dG}WB;77hۇKS~EƊ* S 4N$R.=۟yv۔20 (:ʕA?8;L;ODi~acTz1X-A %&0&Υx3l5_-3>Wތww<scd!G X?Jt՞I閙 w!:%^^W{[iyg@Vh>bb{fo| V{lKhn@?+0J ;fR3& 4fV.5B~rRm 0&҇*u BRAC-hXB9ltB}(N{"q +6?`Um<kP?|44(=YsCDc7çM}257dXɎWU ߵS+-Kdz﫚UGh>]J:^Ɔ5= B&Ιz(XGY55Up) ]AA+b}p)AOuÓ?jcaQѠȏ4B{"!e8=S dc'B~E()ޚ)zjI->gr Ŏש}KP<6,}jВhfDBkzUdX%JL,\T{ 2I==spwg V"i|28.B_#߯l%JAp6Z XXJYXי0 C(jK {Aޓ\I]\Ƀ9F˲N6΋!Ѽӿ LL+G8×[v>?}֝*jаC>>IV}R#T! ?ł. KP nb~\Ze-D]o#O j-9V޲SS6 1z!u"Eל >WѽBS''E =;AҴpG㋤JAx )thaM]z?dV5WJ mk3+|Šzc&`}c Iuѕ`Ri7Xuo *iB 4y F˜~{<Ͻ\ (=d)(m7pg0Pßqy6L.R8xD`5`Yl0ses{]$| YH_Ք1G/u4pVhhJ)f+D~_^š_BeicQ~j,;Q@'$2㽑y#S8ۮ}7]O"C 500f#Ä%Ņ9zUF*[8CBU9֙iس@:B lS@|ɥ t?l\o\4 <2ÅD&&[oRcNŊ^/lSB<+ JPF#;$334YYU|[֡|=o6B-/;X1jֽXnx T#Wv ߕ Kz~RgؐMC;1^X$cJ!P*l3LcpO ̝=wr'd!SkF?BQ‹[ǿ:h8AXD֊',`k9ʈB,`XkP*{A'(ꐲKs>b{(58}ON_^)jO俑4v/_%y k5Ɓ\"sZ Ls/6A ߼jM߾ E) ͓_5ItP5ÇUīPEBWvs?x| @qɇ`cuЋD3Z(BX0hy.oZp?> :<`.h?Ym[ >I=@ SM%v#wҹytR B !TkR&G@;xi 5| dxW Rz[ٚY3^beQsch_{F0/.hpU3Awxd=/ce'H UD8{i", f*Q_N|<7;W0Gq{5:K9CQa!?;pM$wUg/,raMI?14cp!lQ ~e.FWTtx@Kx}X ZDrA18NX?+~oŷgPk!~XBvtSKme@)Vx`OچpǎpOBth۷*6 FW-q-/Ƈ,_$ؓu|pVeBz8Gi~%`kEjiXpg}Rbzo:Qb,5a,Mi(,_!3٦]FyiC7ދba>luۍK)) }|4: ^-7doYI&硻&ݽD`jvȉz^LW[VɾI'G}7ha&U|/-:){^tyy妙"6`^#!<ꛑ!+|K*{Ac|h*EeSkw&OP sxwrfnru#}˼/$@=\"!T݆G^0$Zj졹w#xF`?,uJo;-odl~*o+=)!' At~A=;q֝]l.${I- ԋ 86w?Z|sPA*o|Rٚ~ŕika:50*h9%{0Aʅ g`p5a'|MXKIE~B3,?:^ΕN%EU{=:=x{\/7zm_YWjv'k6!MEŚp,(n~uSBN`A 0Fݞyަ7Cg=#QyT n֎C[Vēh)mfk:g&Z%.sF bDKQU `>HsͿ[Ÿm2C3S_ ~LG{# 'W %PRc'A&{moIƅ!CG,Q| Tƚh%uE(|-n#Z%NAO| |Oʆ.W&2ƾї ʙe|YmY؊Jf5r<p5T."`q E=á [C߻[L,kĝe%=ap٨SR%||DB+G<]U 0/#B_)DS" 7.SrOA~<䈴KU!C*8UTޯJͤ1_BgS7#p[=;ԮLI 9jJrt2i+Ө#j %! u\#IC)V >I,A  @g9,4VD;d9Y?.m%UB bB$6C6$TՀƻ6>ILs:1&)]A >5ԣZ5y. v -T /BH`WVWh/=Tuz`wJ$|̤p EzXN@Ꮄz?,Í!a\p i 8hzC˓ҎO _u?4u 4Jt=nġ r5KuI.%o?jG_\!HnL}BrdOp)ŒM5r-'#^"J\hѶB 3a i/(]L 7g$"ͫ1c CX0U$Uˤ'OMaFwS$PpmxmoYxi8|mC{KL[:Gs5"bioMUDm֓^M*+O=^Ea|(WƋ򘖥'{4W'3lDV8Ol*`^/[y[aDCLGݢJm{sf,gFBcOPHv\Iy@QH>-B _"?; Kg?!4p! Cq]mf U4S b7$Miw5Hԏ{|~PVⅸUF!č~Fr@VA+1įZ׮DA`°J0pI╃y}1DS olc⚷7Bz T3OtG Lg2m{VeQjCY};z!${I1У3PK1֟w @~Rg7n۫Rh xٟp@]fMO`A^֋JԹa[x>B F/?y_yߜ$M-PO`ҫ ڣW$Aϳb^<_ UaԷ'P:-6C(~"Pg}E=ОC &thz0Cz{:[1>͡VƜ~k6i5w)bbxXGR0ZyO~'rSgVGV|+FM3mJ<9[Ps~NE&=3lRpҧ<q]/_.6MEev #6M L :k>z+dx@ɝ|[~B=b1o[Cm"t2nJ5˟pGY4hIȲ#BZ( :*G+I|U *}Dtr8r)!!_OMF+N1/(Nv6 HgPE7-^پ`\^߫zǢq6Kg,O!)~xsguQjz=xlf=ltI: }N & v&d>; 9,d't 'GL~D[?tUvnpwD'/Xc 6ޘ'?·;%JAxυ䍰4x:fKM_O{u) o!0^цl&w?<S,AOwU G7LQ|u+J%%KymaW`"HO ԴЀ` Q C Gq'?" V{w j|3AM\Oɿ ,DՃ'֗Nǥ~CGԋl91μ^d> &-9%ďoArhPFzimϚBۍ~5&IC=T}TJڐJ8J][YX(C|qm췪 i9!fC T5γ_ySѸ;}!* o;NGI[ 'ݨNۡ<1+- 1e>Q{xP&ʽzUãˤs:;84T  /_xeL?On@Y !ǃeړJ|M{Q@/*̍w$6Nժ 8_w1 mf˫|\U̩goRݑ zzt'BT@>?BXo=«'tnWsT@38GQu}`5n$)j>A +jw֒W(_g>_6O%ԷYE˸{%XыSi 6rGJ8DXFWة({f}K"-_Lܪ+eƒ_=PYlˌ=L=zx{`u %'ǣ ~W9iz"֟K/LKe@?sz>B44x 4$^16AZb sP#ΑB#h7N}{ȷ#A$ߊFNPIRlm 6x]BJ ԕ  4?>èBRU0ݪ#J) ,DْtˬWnj6 ʗG U"\},dKz71xGS/kP T}hPIJƤTB,凭"b}Zz3y<Ur p6 1W`tTX}bGcոqӢdd|晖}MN 1@j : Ky&Æ+`?P9O ֣X? U(sރ*5:nPc!S@N2OlcVu!x5ّ[%3P9ˮd]AV_/1!`B]&p%9^? RovGv Üz+ y .s}t#(b*3Vfz7t漘N6zIW$F|NƔ۞!OL>gxoh)=zˠDV$ncY7"ζA2cS)ئQ>)8eWwAw!; *ظF*a;m Sy6syC: v'Rv1dZsSLf'}sSO]tg0$?X:-f=T;TFmn::euJj6y]b|ŲӰ -{BnR?hͮIL<!'5;'!]/$zr<.[!VJ8o{{G ijܷ>(T!p& oTh`לNN޷dlS@T1z%V)C,oN޽N)D0&]I|Ejl"@Sۨ^Uw=6n~[lvai\3/gۺj 90h=tPrf&^os[kp}|JZbR;?9g`QBPC~34y7/- L7Ϩg)Fi;?Eم/ҋ]1{}랪kA@j~󆧃\ݙ"a0jop>=E`+I~D\;RUZ[voWVitZ3+ (}rzQ8÷zk鳍wGH*Y7.5װ|뿀g=WǛ3b*gj3w؞q?9"$0N>t2{F='lsH16ޟOFvnDmn8~o>&7$=¬) =Zd ^px~@y~ ܾvg=8HLR%d/w<^+ܫ 2#(琩(}^|'nM?/\_q2Q=×)/bWHL3-;Z[qx ?1끕1gLhO2]/X`u,=tOgI;iWn 2AaXl0Ŧ, b[xXϡ|WDщ?a/h I),Onu.2ada]qsiSf>sؿ"x<-H8xu$=`}j' >*0TlO;ɂQ͌[tETO^\ IuW$ U')[wz&XqZwR80d$L͇1lWzW?f۞}3o(]ŀVu%b^d%`vOxWCG`0ۚ3 m_JsSd,[E[;Awh3-w 1:B >fcXY{V,Y BKgPWrR3;qQuCU#EܠX|u:3;J‡q5Mnv`yQO"2x0ڐ5h%UO ^SM %>}I A9I,"C l̥?p~cs {|U E AWpOmP<6GņE@7 '& pdtLNGD8bĢJBCӻ=Fbjmpc%wC,PCC`{D(\\! Vɂ j={e@QmK|z'˒5=+}16UPau5@mY;Uz(\5)$#ZE`vQ6T[^ZB:b/K ,bGPmJIOzPՃ޽}xLQ`w@49G6wvsd-cc[I@޷":5 Az>DPb@fv'T)ZدUE^ IX=uNJX{` 7Wgf\|ߑ1rM  aƩ/4{ɥL|T[x~w5-!>J>vz(QxQOX&X9sq 4΃9 CC)d?OxjJ1EH!㐷Q-0t{ [YM|5q2yKϾn[n=P/Q(1D+Үo 2i0_uw/{Iǁ 9˙}wXv? sWO|qK$+fۏoc7Q'Jn#aA}(#zޒȶm=2TB,Cofsy@qtg_~Ԓ~ |SnW:~9Enrߣ/Y=P]^U_9o(a/#D{ 6}KycLta^+ʮ~moYv7Ԫ.^\䊡-NRswqY.Wn(#K :$Қvnx SJq0@\f _9Btʢ`ïp b:8>(H()\O4n^L C×TH`8v52D3kE+Lr+v~&߱M^OPٹ~ \E؏ VH'#hx룣xnW:>p)A-k2>_ꧠڨOwDi6ӏ}6v-k[J~boӖo6ʗ#8 e>̌& iSԁYDĵ"\̶R^=1;p: zI/!PC$z8Eqr`-If7>!;^D3gD='4@0%y )TNFhiFUtF[T٫&Ią)ž_!ޠ$R%^'ΦǺ-@O&R~ole0-WPpغ }x]L;IS(N>d){ZGwVr'cC6XkJVNmIw }+5ia5A#A<4 B<)x}LIB8%nšÇZdʎ+3WY@*N _+ok=evTVLwS~(VxOBhBC ~lubEG s%c_ˢjDt?m{96;T 0mf@7@ko>O(.j]>Ӟ,#@ݒz~>H0 Ѳ$JU/;lN|e*횭>9a#)"ńZk>-$T !ac_ۼ. Z+,HtDW;wD4 OK ێl.z5וxsch_ udۨA_O28؅T5KeF-8BE/iOmG,)YW2x_<2Es&[.5qǶ)+=J2rOpyF_^u5O'dF^/h/M~_%d*mB|~O'U!+I~<HKbe!p229L)D~ͤgYt诸*x_L2Y7R.QWTd$$~ZqN_R+Z>^iQ*Uo17K2<FS(ϣ~CR.jA0}yV sh3O nX:s8j. F}jGsb/@xh/I:to\$"V>ofqS|<łSM*.µB!lY8ת e4ul"%m0m }.$ W:O2F|(Cf͜&#CJ[J id]"ißXS WkxST_1AhlYq9qo)OH8 M'x/t 2+s䋲*/ 0}=h*qؖM%v^"}A;L%Svt?yZJ]. ;D0!<}Ђg=%?ނ$$9Z9H=򔀗8(D0Wzj2ɖϾ,j &q€Z|X9o:d2)Ρdpd!8O>LmnroR,Tn&:H?"C !޿ ZU躚mQJ<|K11fƷhSf..tL_&b(c0Ẏr7q=#ºr!sXLɉCy"bbf ՒM=(=&dzzP3h40.z,tGAKXYOXYY0.*H_T9N^^P9ɼwg=Sr9Kl;v2,l!g-Iؐ2ͳK%~T3pD}3iV #C 1i|,231@1$>++~hF&2O㌤i#KoCYP.F5F^kcQس)>kn1y{J& ; Fj쵔|RdՎX?K\ J/.~FՌƓ1Ai5P).y Ѥ١bPff<)_N}m- N*"Pjot(,CՐT?(}rK0Oc|i @il2,j#NY! KPEA3nRFf VL%cM!{B FvyM_ݫAQY-iBܯk~O/Ն}\0QւMZxx|-rjĵgNO rK>mYx[Y+댼83uɢ=R!}&%)SO6!dh SP&EՖsetKz]`ғ= 2cTGLԨtXDrG\l0B0{jU5wj>G-hBP܉`+0il3QQD Rq=+~D&e Ϋƚ <,A9~-g߲h9<`!Xy3afHQ0u/ Rі5,oT6$ҝ#KVcn6=r4!GتI\Y@6z6E(N$W۫M, b3 T7@ŽU$@>o&V(R|!~ I/(Lvb., lH [P0aIG[3 uH"p #}*!O? O{p8p6oIPB1nϣ~*OV.c'.߲ͭy+y> |!ʋt =z cM'7l4 w&>@^ONCV?4n૿7[ټ<&=:CwoS)_$Y]~'2X_Tt%xnD?B|*:W,DM@hD5lzu9uHx((_ÅVԚd! :˾O5qg9-q$IDv1my9j';"AJpE$7xGN1exx,,/6>ג+_rF!eUS.<¸ } ].$UCmFg4ANKPO1-h'xr؞T{br8%lـE6z,Mp@ .سPсz3'?)9_?X2}uep)k[gto&ܠ;nxxf_G0dLDmLQhhر r> @Eh¯d'G`L6|io0r1 o~?'OetЁ' Umix|~Fl `ʾHgRaD9^Ī( yƟ2 ;Hdyt0R;}FS{_^9}m_6jD<Ԟ W.Ҹ%1'nΡF G|FOSS֔9v9"i^y֧a?j'h<Јd`4qי//s0Z0 z["#q&1N0T' j@+;FVɚUf_/q f$FÏ*F FXzaJFrKBMZIKsRCS@< bG 7к2~3P5m_y_l 2,.j@M&kgh Ot+rY=#poFF]-d;+Pp"n mAFxJ[GDO^ғ&[_8iJ-)^l>yuQM!{~yUP%w"b9;hVm |ߔlFcp]H gQ٫Hؐ"g%ڴ7t*#TPO|20 d=Gu]f)y1F=6n <@om4283F&))ȁV753;ԫ❆Y&rvDT Ewl=EwxD wu5Hw햡'/'K#3EAt4]#6+w3,f\v +nKtFCĽ~d[/>ёEޭg}J{N(X&_wVE7 b( >ZM>bK0[\%bJN[f+E LO"}R|gkW:#cG ށlBe) -7i8n${fov S KF2],'$b `wϢc%\"! oKLfBsJP$j*PߊYď #(݈-XUtlZ[?e#ep}[e$vB!^vpv3@(L[.˓X l2<$(^0q:Y$eWP)oU%^m:R4c~#%HJGXXpvwUq^g5;`?ۣCZ }'iWK ˜ei-/.ng 9+ϯNaK_K6$z~ 8IUMH}Q8#,'IVXill0*jǟEk~AџxX tXK}2x)?Mc_ނNk.EՑ5-s*@[m >bRN%HXэJsljиBa,)+,ҽF& 1ɮLdh$?qwbw.{ȣ #= ]0z|eoMcгwEsV?DZ-5q1$ IeDH!y~apd&RNtVКX,5\믥ڠg{#w'Ucx@ ˆ閏O6[tA%}#!OBJOxr}c fhSOrzk $)VRҝ'7l5-PyOw44^v֤&rlZWCy;)Ida ݻo՘$j(didpd3po56%Zc$Գ?0*{3NZ~< B ?c&YJQv7qC#YQ^K(w0^P,C,;zufbT& $m~ K>jIT3৹5$IXmzY'yrC YVx'M0Ij'3C CyI*8aM{| Dd2ч֖FiWǣaNSDc{ 9nJu|櫺\2E8^ 5vqp@6HX&>Em׃4)]&r{W15]ԕOG]f0-$: n\eȥ3upLVlo%zy"R&U>Jo[кz{{ l2tOzBˌmC;ɰ pJ EK$>k<{S|,ؼϪ h;i/yz,*Vߠm&WB3Mn ۃ ܕ$VҐE*MafrӏSBz6' ݀З\֞`ƒŏGe5}}(IfOS|8=vCՆ7Mw K%٭zb($-UkG@x 3ikg1xhqihZَ|:ڈhD \F$h*<{mn*ʐDBIX (ʆSY0p6'+ Ϩ)rΣF\L/ H< iBY"5$C"S~[؉`>bnW9=%I_ rqK1H|F]Il{ `0yN73ĨOTE'dMyx6/As 9<{&玙5_u&24z-.h[EAs@Ňh^{ Cy<]a< ? |0d!֗(~4ypA0\Iz%[wݹ[Lvgypxl{[*j A}/=$3k(F>V5Z]2:gE%Ժ 1Z Cnnۈd*a,բ< Wv=p Q8]7O0WgoU5]oMgSMB$DCt5aMAV8f^R<J7tkLx}Wv[?gI.C0—*>BȶANZ{7. gw"/Y3tpek ;LucRn%Gj:XO#Dv-1gmh 3yٖ=j"h( $@A'DS.4Y%RԺ<98oE7Gq|Dj{ăoQmUGW!;ak~UDNĒ v<0ٹ0B[OXlmW +m!dDG}QڐJxUېʌcqbj}Jj“:C%5sƳJEa[ /8B$fNLeEEWXФP'=_-zhqܔU«6mxj%?qD-Bk E;b5 kQ +ш>%,Ѻh43 n]$eRMSTf6_CwBU׌L"J20Do-wK}' d~u7ɓ8:(mDwq84%C3E *ޮ UG{nn~BԀUObAn$6݅tk>#GfuH** ?>SJψX̮֋`;ܜhdbygշodu $>P~(,y08g%U6j8G۬gp/,:o|8LS欤/ ,s9\s5WIo.(LG2*f6?1aq7`g%%b(kꌡQxڌJ)mk]#P+}[ߔ%.wo]~,@F'  *%he8#b&kKL@[zP?0vf XAˏ&sP t9 Bj n1p=53s ߁݂aUBoGu?:6&$Ӄ]bz/$8ڼ=kA/dpO ۻ6nua-0/m`>SO?|Np ~F)٣*~.D`;WIHd[p f ;~l5IEQwGNbhcoizohlͼmCf8zҵ>[ET| c' "2#-$f̣eЋDI~{5 \ mYA2k#dIF\6=)B@7#6܊_Z;wjK1JpPW7};O\zZa'Ҋ.фkyB2GDrL苟ka-3ižj9ҥ|H?acm7tabPY^\AY:T_lTTfvN΀"v<|-尅Ċul :8xhd-hV4/-'QhJV_T ^Tĝ:HJb>zs8" zUϾ}l`3co{6/` $[䨑;% -w%$*PnKVنpVs_;K$[ֵ;q-/!huВQ8{) N+?i3#h3G4*!hm,Ԛȁަ` ?`؏ka%J_[3YYDȗI"S,CY2~11?0W"i^ޒKMuV|yZeS&WcbWviJk:ќIW~Go]^y 6꒰$6Sk.J+QA5GXiO ɘKcP K-6+3CPS1݉_>E D}1;PY}%O=%x- WW_| 7f8.0P_=gjKYŔJ$Avt֊{oM+aJ ,ð[2>_uS8|QQUA7KgkJ̇ nf`f;D @?rEa-["rbz:0T$U[(| פ2ְZWWBN>|%;QS/ٌ'EdV'rW |ь?Jj^C.>Eݖ7\Oό,,Kb/L #8j vA_pL9G"6##8ݟ 53ɞo2իht1 {\+sش!rN*dxx=6/RPڇf @99p@):0\7c%1|ݽhxvQS_OYP0؏CԎh뤔h_,&,=+|D݅&a;#.WK%Y첟"DO`<'x Ē < EӪ}@|[<0~1kPgƽhZY;j^k)0soUUFAdI@h $g lEGbk`vo~#_n9/,S'fӨ+/w>ųgO HYFf$sHƬhuI:}NӶ. ۝݁[6F>[}KoN"DbA,J[]ϥ] mvD^Lg*v)w! SbzÖ{&!P?h˥_KCu%O[^{R{^[D!qp:ID31`Iw&HE,oW<^x΢8: G5DZ(oeOMmvcfv%ǹz ;wIgy(hX^-#QqK_#yB$ `i/a7'0ѧbAҎ`pE?Į\/pxJTTO9^偪`04ȲOҖzB̲11Jv(Gx]]< 0P7a'V)F9pu;> ] +!{MYO>3YFpnf28-0{*2s}̓Љ=IGSB;&.',v'gR„?IZ8lڎzyO{j*fctd~${„Kbx UЇlX} FAzn4S7snˎ7#ig)T!/ q(nB?FۋקFH{ ?X})D Ld:-˳YH[w]gSѤLnʳaI`_[hwϖJSb$zm)6[+pCg΀Qc nIroBKzSup ]Gx| ]YaDޯBDאr=#zfvLU't|k r6@>J$<ij͖Eԓ,LL]A1lQz 'OT9@HLa# pSkZ7 Q"%|ušF'ivbl?Ksac$2+J+yH8G -<k[ȫņ!;!RI~h:GM&6H :Oi@ԡCΝ[0ѵX5{_%wn!dI7?$'|sB3 /D,–f!It eERw#zۓD2@>NlLT  .tt&-éUGŰՈS4CwW*hsd}znDopHdSgyv4u 1H; R ǛVm,N+͢ix*25ܑfPoכ"=>IyHBW^9g0􄂁}cXl{<|_S$^97 #lg,Iԉ0pen(m;V5x18[Zfzer/x+PgM{B~?{FR" N`)TEnBMq>-bHy="hC|mq@6Ka %M=S|Pxq oh2j4uL'/@4@)ž(vo[wڝ~~`#ݞëa:g"I%:]mцP,D75js (yWEklylz ;?/(.1s;׃# @Ԍ{}Kv%%.gL `'yLAeWg8+~I4XH3G>YR xIO@ 2K@>r[kJVPv͞EI.mpXj¤,AquE0I$g3cWٓqnE7ޓKix#|<vY)ޚHxѷƤ V؏ñq|JL$[ޤ$C%JbGƟ( NCUlxX:3m'tx%?T-*Ntc7̞DQB d_W=B3=JBoIEJ&ٺV= zgHenSB*^$dzV( &W]1EF%/ TOmeC es uXy;kIm26v 'Ǝ@s2ܳ3Ŏ8f,f6h)5Rh3[SW8αHK~[-4N+If{b fim]^N/fP[wJ4w#^yU9`iÏF{bݖ]mݑsNW4AlG0e+q[2Awѻ#/'tQsٺýwM-' i"&$›y4'l; ^k=_sLMMtk7xfxL2Wq :|F^ Zpcx LGX6d)޲HooVh^vKm},vWmKo$VMT CF;&AY+s'_0X>GC;[bfM_ͣ8ierw@쉺l?x$䖝KFV(.}Rr+!Y3҂l׻fݏȘ`tDo鉑k VAӴyI:EY~Ԃ o5E4u*Ha^_,@SޚX {?t@-#D([?=3-.<#}[  ɛ,R4VˀLϭ!Qz3lGW lwPzE䴈۶ᆱFɫLݶ7[?G#TQRe%<*麏F5nz%xĤu‡02`j*}|usMc(K$iZrޭnʵ;<64gGxKh49`\NK= #T9*kx $R*VtH[O`p';1m+'Iޚs&3H6"'yGC-D{*Am횥QWpXʵ@T5澂 #P+I KPPh^&!m4~Yi"^Ν}7{t:8ʳ7&; =D[]]Yl~v-m6 :FxH &|0Fғ^e}(\#Wvru> `tIh эv@/m'ƅa$.2/@Să|X >m-2. Y\|+DkݢuX[<6)? h05f~:{hTJ|UeCcs=~ H32z˯(Aq3pk 5&FʕŜK/kfOhR,aԂe}-gxPHOSJh(Gc`g,r,|"̑^΅ѽyP; NLrQkC?~W!/Ϧ<|_@.ω?_|ߑcܬ~_C>el>eyʾ=(cA|s;oc˗Y)_?_ݏ S<3_? fZ񟟭y}Ͽ?>?F 5tD_yn?9p/8HQ/% H_~qۃ8&>7}E'']ns5BUg6=_m(90LsTvn CҊ{}Yn7_q3DT7_@O\#xN`Nן1ETCi /?(F-ctꞷ_O?o_w%>zyo,;gs~s{<_8⛏vXn,#޻Gw9c߾?,x8> stream xko$'F٩ޢ@\4)\\%l:~fDj~A>k(oRq!z/h8{}DӭT J>@=^.4krdM| fRRIZ z@[ Ҫ[#lic븉 )}HnZ C)РnrAU[ߤtR9DI+Č!g}K|6|<WSiv״B0S%hD!-?69Z0J$2U 0|!iC@?PAsk2?8ߤ5+tV.V-}~)qqg) /x|hqk!z^u!6_ޚ_M'Ҿ %텚Y+8c.eAj{i+HIBF|NgL:1&'֙nD\41p"6+l-:t5Puo xUky&6χVk7M _^71\&td@SZi{ 6}/ x\Sᦀ-gAk?90(;{1/FL?̍ڍԴ?\ =01}Mwu>4 R"3Y-`߉iJcK0 L" :Fc+7a)g<5R[Rf* [Qej ]uRmKL)ȻꜾ;pڎxɵ#=QB#Qz$wTN8gh8y+}ƀ҃$c=PXzsT R`~^ )N.ڕ!$ n % 6yB3T$ +l:Έ,B؎YBUPs1-|j&3dG;x͕f)'6KTDTG98";e!%@t ؆~'Tt?H&*oGN5f2W-ij;!ݰô-<*x, !2NՎj۠=mr#ƛذKh0A0Wƚuc}#&Qw E`.2d Ɛ" u^|_I $ -S[dQ˙dL"_/cTs; rGjIq5ِZs>Q¾:ջ`]+\L3kŜA":i++7Q@']r3RL5607D/z; Ɋ%~Wi==PL ͯ^ P2کrv멙niISa]gfK ob SV}6Sh1:6w4A :S\⋕RKn_vSz^1ɀ!* PQiaB'|zVaq]'1<^N 32:rW#_әP QPuyb=S-[ʖL$hW$F$D8[ɥ(ĉAq`⁨us;2v`|%9,9(V)8(Nbµ@kDb96橣-*n7:7"h6Xo$ME&Ahama79 O1/FAGyo ӮF3X0x?f"YB =Aq?uF1cgon(gfŚyơaQ*-H1W%gE_/s? vB]ыn a$S2)]`+x̘;Xgj&`&}M^XS&-0tzT[tM^TcwqUǧG%Y؜݃Ӎhn YO񨀬v~{WF?WS̺Ć٤Ȗ$O^i/+O}k $w1t_&E ;,>*O:TUU|3LEaBVvf I I9BoAd޽MݯiToiFWm+/bMߜS}.PUdcXo!f/c`^L X6̯i])mjxv$RݎD&E"8'4 4V*~#Q4Ј e K ~fxٸ0xx>f-D\ld:iz{)WMS-rȊ֗4-B!4z.r@}15L?F!@cc),oG,hI!4$$(/G'8ɦ2hlDl㴀LOMXrL.ꑪ7"Y~86r\r%4²\vW|% k1_ _g!O<C^9a>1fX}W!>&JKmW}|4QN>5YE䣑㌫^t -2BYƦFoPeDmoMm:ۅW7~K:ȘO`[wuͧo7*Z]~kƯafkf<"lT Yq9ɒ&g͜={ː37\0.ww/;?ntWWו8vھ} xfyiQhL t1[Zz%T=ʐ]WF]sܨFz/7'EJYk7g|%cMc5Qš1ǔ7'] ;AM,Eo[9")>ERJQ\ҡ|؄#1}[:f4&'ߒ ^ꢥaH}Of,-+b<|Nع9k2аU$ƵX,0emee؜pgYqGuc۽a{livʢa/7l,f0⢛>V`ҷ'QS^.wB ­֍pqzq.I1}dەY:<׋Őnj&he>34n_̙sN 74<,~R2(85-5F}u:c9U1O&6#  6U? yuUW ~_X;Cendstream endobj 390 0 obj << /Filter /FlateDecode /Length 3905 >> stream x[K##>Èsmv&ahV3f٩*[ҬIVWy)zy) r^HeW0B]}Q^^HKBoQ˫ݗ tbPF}8k g,y(,Km{vKU|ͥBu-V^Fޚ. M (;e2KJﺹݗ]i/߱^:Eld4XYƂ̭J]i>Mik2d+fu}[Ҽ '穝kݛULJsX53)LWtvra'ˬ4wnn rzpA*id~x[ya1G Nb<)HLA]._OQ}w4$/z)9M&T/@4?)KTY/MM=sFeSSyOԧTϐҖf(Meق G>!9%~ %95.;M)USYSRMfa5mIypUeSSj:i'\̠5WMh죵h x01bsn"QHMnAC/ZWnX؄lfHh6"tVF1`u#6 >(=o#A9Td!18wEʃEZEq>Йz X+#VÊQQ/%]f7 qB{X`ͬUk#fv c22J'II}yilrG1|*HqRmiޗ&شRd IJ-v*X"$PA'E9i)Z|).@|7 O]>HO3nqSDI$Pܼ9 )3 s1K ,N:gDXsmcA ,t1L 4XPB[.MuZF͗ަ}8>úBdiA}S)CuuKr0rtݿS>^hpXQQkf} F(ͯKF nKLЄ>*w]mvU;EǢ!a 'u9 Jn U7etg`&ZCSFizp~ֻd&@ZJOHhJ*e4cI_6ڹ*dh5V0ʐJF0My x^6Ȳ$ ڛށ,Y!m_Qr2(.~"SmDw&Gp# 5ͭC8˚l΁1V!*B\SZWQ(q`B c= `XtjJ@@?!Nh!ܭh3iX1B|rn ZeV+W&&s&fk:\kf?&~2ٲОVŶTs[]inyo@uv<0 3*fj ęﶵ{`5c(]s6_ qx6f>.|i*ba|u%ϨܒpL- ٌڣ!vη &,X~ 積~,ΩoB,kY`R)e;&AJB5|&2s$v&,\79Ot1OX=fI Q5!8) ٶk%Z_!9=czF th;4d$C *ֻ"G ^!9))Ӗq9l4вBQ,)]htVU, Ց) kR"52ۤɌ?nǩ,zu"hNi41^n+b H02ԓXvxbR3nGוy$ʜWŎ@$UVՙ]ﺌfg2{Xa݋w4bǷ%ss{xEA@Kmcxab&/i2w|B(8l m {.r(<A~;>Kpkf_wÓjvF>.xyѝT"g\V$P,|0f#-P-z1٘8sKj+ 4ׅ>ci08zC]g Wr,ܜEwkPA,wjw-zOw}6W%T RqScDnȣ^Q` 5-ad-/ *Œg4X=&4ܗ!IG2մw?mU>6&7w՜,*lh4S2 lZȷ06FMtl*&_{~mN'm>6gMKfl?/`7,SOsyHt}c@?o=.> {")B@_IS[`)a2)3+:2 ;zg2jBq}GX%F'yQvGC [J:h`2W{`SZ{M"0>a6vç9Sa=u2G6⮌S6Wv}z9T8IО'WϹ5HYdeR7m};ɮؖ#{َkRkҶX12Y*B j*\;~˙⍪j,0P>`=i}&u6 bQUémI4h:ѩ\Eq+ŒU@ >` VЍ9+l@b| MfU3ٴAzIddKreu쇌0aD;u#| _> stream x[r_i>΍}'ؗRv%V^<\LJ0,\$eh4N^|#z_7_9:G2Mbco(?9ʟMo}_uRmRD>hAb|oVelЮ۟nw1ouɓ3wSy'[ыHe>Bx_VcTwN6VK0VflW`hj۝1{1XA`bMm}{FmwZkO1"t3$&mN"T Ami>XY+D+ާT|G5^['2lvPAI #OtAuRBRWYvŤR*F|UÃHk)xiG:!v=v>FK Qv?Ik{;LBNkT + 2ze &*U+m2G6;{gIo¥%|xÝ 6lˠ*HhCA}\H^"kŝoH v^DR:ul%'4쌐آ=^bdn) !8aOjȓIC‡-3ž-8^ fY U}ڲ,![D9& VOfh:E '"3 v8˃|QFaFNSꔍjpf \p 7;{kʠz\r\ Ni>KCP;5!b?&I8)2xʓCHn=ȉc d()6ߟ'ĸh&Y|=z^2E /laM4ZlD CU%M)Bc#\Z.A AM憕!7΋*4AIʄxLF) CSo ](`SjLjbbbnH|NmdsE[.?nnXuLD}ڪwN*3.|7Tgb~}^v s`|z )L2s%W^%ßMD aۄltq =y*U.c ^!T }_d B+ g! SȨ33Y6~Z ;4~T3ӪF٣N0佗N۸Z_Dp|0)RAs=2!'I" ȵ,Dŧ[c)(P0_EJ8fi42a,:Őv__׊E:RqX((5Q(Dh [om ' Ue#C'(h(y0pOzVej'ƭLeV)}7OR3aŹ5&ydle}QӢȥEā[FopRjHP,N=Ȍ:AaOҏkFOͳzphɏ6PPejetxK-/L'9.xs2&aYYZ 糏JSJ+SB}OyhɖPר*e~),dasR>imTHKxCo}6cikGKPDm[4  wzC.Urx > T^i>Q}K.a%HjkwҖ3 3\dI촕;9bG^ŒTm}e3BIߥqMF"-^CrTݤHwl]?̺E +'(AGӸ#Z˙4G˨Wށs&9d$ *;B0N$ؤ'LxiZ:6lf+xnJRۦ[UB'GD[[le{7XV?,_.Pȼ7ԟdGeGΥ:>6Q>H@u$}%7˫B8d9۱y#yIؗT91R."?c5uQz<ۤ EI8YqR76<$<GGF+#XA 'ovm<@f6&޻04;X,"Yf DQmzei? Mʏ޻m6 S0b7U:&P{S FD>y1z߆DYIr ʮ!TC+J ih쟍;ɯw4zJp/:+Yys쿬G=AU cMvL/:B}Y9U(6qW[36hTJnwzv&=m} Kv<Ȃ>g.g#N0i6fo"3QZFQR{̭wLQ/sYB + F㯒2+;)}>Oz(y m;UT}t#ߜ}JESe$aو锎V(of^mEz6W᭦RiC AVzI`PK6dNp&FU! zfI)d.YR"LZZK~ti`Hrx0a7 Efn\]P]XY[ I3ޜZnJNVNI_4g)-moWÉ4[gֽ:>vЊ}4{\& :/I΀@= aC84vNl]}9Va6Q@K<}5ȸW\#ho"Bt ~_W!M$>q/\jv/VccȬVe+MWpr~b?`qT|W[=^Lx vU;+S9>2#S/>aŀE4Q>Yܭ2|=V7XOXXKӀJ\;ӥ)%|t p02߸v1Dس7h.]u(lI>5FF b6Mcr{j׋k˄uci8 uaiM;'p`{_aGm|'zzKHPӒ K͍HXMMcRLDKLM2B s)0mAū򕃼ۃ3*uV~*GkV Ckp%ڣ\rf^+tC`,=yV.ҖԽdoWZ'ZTjHx(/c{A5Xb_m:6gݠb[=7^6Rȇk,/ ѹUm^3NC`(g( ,%L~ldD=s/q4g򞕮"zM Wl7QEޝS]؃\a7}5C ,9c/(OYhͭ`nzٻ]c}n%&orN-Ajt o3G[AwOK EQn8iK֡_2XNsV+mx]`PEwq+P7;{5z(4m9J&:F+ϸ9tCiwŢx aQO|kꌏj|('>qRbTJpt&ɮt"КiΘ5m@uCvЪ~;2!w']S)}Zxó*kS/Qݤ6] XF߭iӬ%rsUֶЎ듮-x +暨f_VCzͷQ;7o"gP,¡p6G*"72&b~ǻkI;ݛKG͜endstream endobj 392 0 obj << /Filter /FlateDecode /Length 4430 >> stream x[Isdq*B/刑fd[KXÇKåK/V/+Yn+@4Ld~~%F<:篃[;GUqz1VH15FQV v㫣 ]4Cr\ocvYEP5Fzph?9HN8ܬ7ʏB*I Ĩc X!SZ smpژ6m" iV3|N61-1Jl-V6icn:kͱI+P~46,WcVkZ!b0~l il&e*a wc4%I.e7ǿG͏^[Q8㳣A46Nњ6&F18GK_XF$??|YToNaE8i&PBfz(ߧB+"=Ip LQ{-0iկJrr("=v?ͤc͇߯a$yģS'9iX2LA_"iSaƘo+}^!%MP%~a:^DžL gLCioW8z`vMeIґn .D. -t2e' fʌɥ d2INeH zdk&̇τ~9d_W 6`h6RD)`TQeCj#fTMV;7>A1GR&;,4M&"& nj |%E"}0V硦Ct_(gvu?l bJ(!\96>'`r(Bem/EiY\xdN/LdyJiWѺn"ZOӾG: }jSh䖕4Q$[#B=Rn7/`QSӥ?Zs(eBh fVv7 xX$ v%& UOj%$&2i"&fDְ>j")gfc!u*ćA|8y;_-P@N/ҙ̔ i8-Dx _"2WD6 -Viه 2~mkcPR!E L;1dCZ9qL萆g%k~@Btq%C :R߲4MۇK4=< XrgcphM'aQ"Z0IuxWopo+ftPNjK`o׳L۹rOomX~=gIa?- &#Igy9:lu(}ȭ 5;!#S HE",  T;mie^%>ʳi"o쿇Ѥ]v@-L~'klz|-nli~!($r`Mω8zn`UoLݫSp25?u@XְKф֒ JڋS;u3~=/M}kןcX5En*a]7cFb BJtn(uEۢtЯ:h$uz/M]@1%( = h69iޗ}}^Lpu /q:;:E[g<( a_1RoS"q~w5sr! 3hoDiv{5S0r(b!yJL.1咓ukͣRfZ>p~\{;w]h[B0el_;<tr,; hrw;RQG/yIEx7( Ҕ^-I zsbl?<j> OhnR4jv)EްjSm4|[![jֲA#ོsy/8,Nti{?>m}P;`fD͓ XK^SV.)2L~N9QEl]V~C0]p/iONZ>6/M̞>}گ7Xt&}1W.KIr}8].ȿβR޾Q넓HYż4 pI{/k')}'ao GG:|~Kf&׷c~[-9*n+6$@v|VP+'fXӎhbSy94t{EtCWgstV'Y^xq>jn?o E(n颷M%Th(D~X.b"" +ฤRa!H$4X(^Ӊ P=P֎! pA!iJ(ֆNxN6q; (×s*981J2b GJ N}u_c\O>>/n wj(%YQ &>$K:|Uux=QpÿM<<:ÛgoK*O;Xeo;vs۝:2 F:I w聯('sasa:|)og?Ýϒlg>SIvC$WOIWuS=)}=IJ~a~kL(OX> stream x\KsCe26~$TlWˬ\ Dr_ٝ}@AErʥ~Rr)_jg-/nbyxej5QD z pO=a>e`„Qw'X7iF(ټMaj6Ӓ,([.[Q;#NS*=U*A,Zʴʩ:.,7# ;^jHU)Gmt0qs}" Qf} O7ۗlcY0/3f5N')YV֥DSc;,2sѥ.$rZ6m4w}j`iUdZx6{G+W Q*nߜ,~Xh0π^D%')zZX)c+Lr@m:0*hiaeuEN sh9ܘۄ Q8e{pVwMJGQ:aOzEz"ZrY@NaXg}+K&/' HWS`TRw6D. I yC}eVVnTB( ]*RRN2j S{$H!Di vX2nQy5@\akSMF)<& L[kl"Mnx; ^ T^Uё`$m0 HN1Lڥa^Nj`&HzA8LCv sK|zTl .wDoW#%8L^FE)'\ yr-G n7PmygApP듹OjA+Gn5gӽeơEN!Y1őcnRwwc,ltpSUhTMTPc5mˍ5cnWcUj_J ƚ[1VN3)|a Wuke0H& ơa".3vՊρ(p\> qqӜ lfܪhd"yiυIX,w[%R˰)M[RKP;0_%uʴN>Y9>8]Q J(Bȼ.ɵrj,0&H1V|#0*創0^@ٓl)c?%}Nk8jt` Z[*FNQV-]g˪ U 8Xn9FǬmb.elahjw8E\uq^vbyټ;XW^"xGk4).ҵo:&'.q=<;['B(lG&h!cNYY$4ic$f1z6;p@]G*0 "'8 Hf]}XQAV,b0~O#֩шQ}WXuʃnuA`5!W. lI H&Usx-Rcq~3/3cN/ !6{ags4gz펏>D8L+r:)ZK'!Vl6Lf> 8;8%F`][ot-@wڇ@Jxsos(6~N]xFզmy<+0)9'g@3sZ8i=W~P_c1'+dHR uۋ-XX UG\I tW윱a'Wjs@]1m|>\AZ°E_>Rcxद pt. /$+9tϔE5#z $H̀ܖQ %W9.a{/ԥyA2Ԭ6j< X5!5p#!/f!D;^a#g!u/YSwm4^B.*Q=ރP8-yT N[nrx58>Q iU(w{|@kLu+G/;JZ˶/?^7ei9. q[ h3 !C[(#p5aנ񭶊Ҥ8bӰ3%\f|qM(p!ȗrCtiD҆L1iq  wiLcɭW_혜.Ϲjr-S39"Z[T?0N&CACE[Opy*؜O!·/χ8J :$q;9'زkHf=,9{Ǫڪm:rGܕs?baV4~]&Tk]9Xy0"ᕘUz:S*2A%AWMU@Oc_@%ZԶ|6Qi<^U_>uҖz xgW/N$.QCip‡GG=5ޮR)Gզj.z H G®(Y{;QS}iRaP8UW cȴ=b"2BϤU- 0yԬT3&Vu}_R9}ID(;N+~bEE7}p=w)5-DU}&ZFqA)Q*%GUu"XiU1F)ocPh>O}E`+gahj+J< sJ:[YᖘnO9*!X׆&`S3Lxnx> stream xR PTe W\̥fٽ7 l C+,"raAX˱ ǂ +RFmQ&Ȅhw✙3o΋$BC$ÒS|0L_'ʼn!DwEቡB$+ВEdC~Q茩|\BB| ?366u<>U-h5z \~!CJYZAO1d2MW OM:A/jŚL>Ő'z ?l #jظG PJ"xxG"B:69tBb[*N2x<>?~cޮG~h:q hXꠂ{64hm~ͩ8787C3=;zi4>zSkU1g& rʽ Uhy@5ʂ5d41+(dwp4>ʹF AX8$4(e&iI!ʅ.e')Ġ2[J.3OnA"38 7InsHB23y<ඳ#ýd P]gyEOe#A5lȞkVC%g!}mmCc0:H/ \jϻgl2 s,-bΑ!z'wrBWJٺ-]Vtf߽jK ͑udQݥi1um܈ԯ_>07h-S}~oa%V̊&렣J-74a`V|$#8Y* "'kAreզUIP4NxB.67uSh'gt-ҖvrG=Cg}aCFT$C>w wqIYeMml[@7VM$Om.u֒Hk~R_$uBzh}db–/retUܺVz#Tr//Kn;:G4JUܐ^MOVu8ؖTrmX$GXD?+W4ܘb@]2{GN(^ApI.endstream endobj 395 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 597 >> stream xJCMR6$v-  ]VQmqCopyright (c) 1997, 2009 American Mathematical Society (), with Reserved Font Name CMR6.CMR6Computer Modern123OQmIK%gd͋ǧj~$`dًËËً‡ #`$Of}I|:}O˪16-X~_ȱЋ=:D\BEKmlGvR%I[Bp$^sjpmza(S(S ڥˋ- 2U9`up拔s8Tl+'yp|{vCoa  7 ޜ yZendstream endobj 396 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3541 >> stream xW TSg>1sTA<#vT+V/0` HB C$ $;F#/EѶ:>:׵^qdڎ33朕u{ow8Iq yq;.Qgs}EY3ЀD!,U,OR$&Hyq /]( qdaH)DJG* %Yy%Je%KT*H/W$HJTJibEptr4xY*2M7E3ԡiN2]::?yyh i8bg(]\ʁIc_VJ()]j+s.}Pm(7". (C*_J^RL &@]of<4s`nqgɣ(~tw?چg_N|6Rf?^7vy& ppco?&ٹj7)Au>.Y Fmc9Щ\&%h֜''dg^O!O *6 "LjngzF=7IjNl#AS#Rٲ{h=6Q`}I;޾ ԝX兼2ZlJmɖT@ihYh?SwM ;tSP9FZ fGlx3$8c+Nֹu:8Hqs5=vKƛy}MSKRٵ@BFNNyI1Z M<pi#ʢ{j+בZ]NQ)-m-m'eE0%߅$;2l_`]\=2_mfr \YIb-kEViE"ȤԶtC]xBqMkv1s&W wnKy|M"\8%`gPPWO*j{c4f}Ͼ[7U6AbgBePCjzN~ _E@5@sh<E/ظ2mg碭rR yyR|ζO7޿& |Ab̪͹PFV(G"مr- z EjkJygWмZ7;RP9$@ǘ{0g- vN3Mњ mTRS`ɃZ.$ ٘}|*r4P UEO˅.=e'ehЂza<]{BN[Öx8ֹBӭb4Z8 bȅt )|mp [㇬J}-v1JSϘ4qu8ЀX @6g/j#]k=3[- qx^uf7B#Ֆu|v嗩Jkj(gU](MyFߝѪ[Y-\ԞZ=y pILS{ d[fK_LN`nˆUaB־Q))X&QSnAU! Ý#|a40\6J A/ÝGUUvɚ~*s.sN(tVk P uum6Uj.84!;gi={fVvZpNNNTsjpOs]?c:^G\Rk0p{F̸jq t51-Ќ{1 3&NLܷh E}mc`lEd9hIphOj\zRtDؔv:HDK'syOX4V?h=<ÊMbh zF5@9(Z0iU:U.-#};$l_dk Uz[8(KfR}o_6ffUD_;gg@ Pc~ls@mCnqPC.C03JTL6,6t\(dX|,hzu4jfS# f NPoNj7f|;9!ʌgJMӾ p6*dRïc&gi~hZNZhϜ<}LNPbBk.2rh>簿ag<~h,(sk~*tWқjU .UIy frK.iȍzF[R/RYf [zW,Zz_ach{VTh_AGn;p 9#@=!hAbͱbȢԕm M5-\{\r:AOi=Ԁm̢Ց MGZ\Qؔ`͊̉v÷{2ߊ7ûv"îJvw zŌJ6s*(6aC̔cJQAǩEV.Fa{55ʨEj .x/E4LH:&Ԥ3̜P~?pC@q7kM;a;MYx%-}'gQ1ܣX)-L<ܭ' TFxB`yA O iE#Noڬ3(aKSrkwᒅk 5y$)TЃ$?y=j7sv\濙t@bFh7]#mEif")Q2Svh_}Gv>#δ(?vJKG }ϼFV$3[7zuv~t1A%Si> stream x%KLQ1P3@ynH FL4 )SZRblKSB@&j:$4ą4.tqܘ8͟$眏* ښL*_:IHi%F%:%ԩWE\Ԛ@I@zlTid+Llv/k .c䧓;ܜ]*- B%vOw-0!bZ+=Vrx8?k9z9A hA- e  <i*[ѺHKxJ)Q'ſ X{HT{\FY6wwm*, biɧ̒' oޘ,|$gɱyagI#yq8Gr8[XM618]`;;bZ5PX^8=",վ0 #yrɅ"I  4c4}RD XLA"}cnٗ6μF2w$B-V\[KKL'}Aoci0sAǩkU;-tJ,xRJUOOLl :;=e` 4^+C{$=܀ّa:$3Rtu. E5:Aendstream endobj 398 0 obj << /Filter /FlateDecode /Length 2431 >> stream xn1 !3wd[Aˀ"/ÊH-CaS=3U=Õ(X꭮ ɅW/[^=~]o#j8颈rqpE o}]5=/J9]^7[;#oVVe5v):#9)99#;em+8Ak6 7BhF[R/Bϰ~_Kct\1zpS@X$Ui;}. ShFNcu;ƩΐꂔڠN@NH oHA{4VV b\sM$A[rDCn1:31.D{d0B="F&tƪfu€@nLP;cM U*vA^izt9RʄR.8o~1.?өjW>i3XOg{_7%#b&*.F"O$pOeZr]/$ee#`GhJD U1iF+1f~&j5SSf :V,PwDAI?a95U@U' гH@w?3̿&c.YBP3+ \SL s0 ^xL%[U{UUE&@f*(#%<}Su.Z N)׈BѰ!m.elg4q߷ m *F,@$j?6eEUVl [!!=tHB4*u^瘀5X}2!Bч)BNX`\fz1ED!:#lCB[wyXhF5>?ll-xv {n.ϋX&eaHelPЙ;"3t.À+&ѡz_LwBv8Cܐl/ChsƆ(ZQ;)/J~va!@ fIP*NjC3(1=8PFoN|܍(="GNj@:G0͎N |V!d_my=cIM-4TAedEQXRrk K0 & @fW%KU7yqՐ1>6$x f_[ + GPbNE"尢Ɵ*3&ݎFxRvIC3ӧ0ZkJ5Cȱj?􆶟ҩ܅j{7c\sv4df=:iUM;nV=tI't:Ga{M{jbUMf4:ށ۽GRZa^*dR`dO rENC0SZ {mh^D9};Պ5-ȁ 7e|Hw`pN)#]ψ[-CC(_]DJSvsG}yDQp.)P;L]-4-_!A5Xo7UwcϽax?c??s>銌!y8s/WX␮IJf<=g\/v؎Ak}1T'{/7endstream endobj 399 0 obj << /Filter /FlateDecode /Length 2108 >> stream xnF] =E -j uԾ$}K[_=(ΐYݴc;Y,m?YXwѴc8WJ{-mJ'u0e3 /dfp{ S*.L6**k] &lxr)8/oQ;Y\Y$f~SZgyKqD6 1TvK1dm T@7|J2ɴsƈl> 51hauOBJe+am%d !qkEި '(-ٟRUώym؊scUP0-su[}Uc cՊ)&mރE!<;&-SZdË(%2X& &]GJ+NpM50VR~!ui*Q~?*܍ң<ƴ>Ihu\E*C}c^}3UKzR+'7bzH'rClL %iQ֮\8):^O:;{@ hu\vItB:ղU!BTLmHqJi/Ux^߈ĝM< Y$1Yu&5n\3 CEc{5gbv@#$-1J! nmh>8vCʘ4:r1%iHpݨ|Da&tbH|;ke+(cWVO_d}rvDJaQ9ocRq,>'wH: !@obqCL=h9)*)aTh͠. lrK!vL531YH n^sr(ZI70LZN@%s?ib'7y>!.9Ϋ/@b3:(=0f  HmHm3g2T]qbxFVtt(uFful @MVKEm \99"Wc@ OK2^FSCG 'V5BQ7k[ ^E">3[zZEcO ۀ"C!\dtD8/9wL*tAm{ 1J-E {X;xun;%-D=5yx]MtCn$j`J^soI~B1lf.)|g]M2(q+G]^k}-bG Gi/Fv.<{1y8 :7!𹺥jflMI ZwK1W5,w]`Q@EuԹp{ӭ2[PI7[Xvd6 UOMjCpBM8flj^ 9 \4۟ta܆6=>ѐo7aBwqo{|ZNwJ+RNҶ<钌J)'ݔf T6yCEgG4&V, > ƄK(zmzscRE)$"=ER~Q^?tYUio,qk^3 zM/-u=60:# J+ JV^fzed? Q%B t^F&IN>Z8I9odC%& ixU& kRJHX/ya /}qczb]qSZH?mЈeܼX[ ,J1~;o8˛W]WB-S6{?4?endstream endobj 400 0 obj << /Filter /FlateDecode /Length 870 >> stream xVnH +t,%JX y!@.ِE@'FlHۈdJCAЇ~]DRBg~yNxѹc~~ߛ #ˎ>tkD6Bs̖1Ӳ;28/s 0:8#oN 19FD,OlΆgC%8L, ɣ7#% I 43E`}IT %@$YcLbEGBtTj9g_"21q}WƖ]N!&YpL!>%2/meYZ B))zJBGݐ99&&AQZxD?w` IcЏ-TyG0Fֹl.Jޢ^la1REA\7 w:ۑMvO\jjy9¸@q 6X\up6ԲsOt21C!m07hSQ$5 5ʒgsfOӣnu5/3손VߩVRͫWyAj*Q'RTW,Rr/D.U+PU/sU U'VHrAUZq; q3' eT_L >&Q*z 7Sߩ\RI[Oؔ>3q+N:x~ҕT^CVשIm>`ҺŤ-"OphNGNޅ"rWÎN{}/D?OʋjJڪ?Q6QW[6?ѡ^v\@+❨,AAQTRNժSH+ʫ .Bޟg? endstream endobj 401 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 650 >> stream x=_Hqe~bf2hL2;knNӵ~fsM]e >RKE$'WP˗,q2[JUPYҵΩϻlY> stream x]A EN]htS7]hz: t-`q|p\܂EU$>d,+L/O| .*gRBh)H;kkY0d@ kmL\߃Ĵ#p\C 3xK> stream xcd`ab`ddds T~H3a!ann/ }O=J19(3=DA#YS\GR17(391O7$#57QOL-Tа())///K-/JQ(,PJ-N-*KMQp+QKMUML:)槤e2000100,cb`fddO~J3^.:{aE.Uv,-}˖? 3}< 3'uOX0?!].S;6vvuO4xOl妳ɽs.20~Jendstream endobj 404 0 obj << /Filter /FlateDecode /Length 3314 >> stream x[Ys~؊2ksǸPT)\Uy!!w]ROlT~p4}|h`E+"Wr5Gow31;{?_'W? ) A9?>o\:ZiڠjLQA6hm.WH#;lZ_):eCY,U d Z"8U:zii!O3қ(rVx 2 +\aYtuB9DaNgCpk;M>30*Ԏc!7]ӖQ-R I&zL!-P CMo7EČNI6t+~9+}t뵅=tH8u4FΗڶ޹8&gΚQe`}28njJaB6ւ`Um5T65L8yQG)Z%70&[(H=!kI# *g4xɊde)̱.ݹ6?/%~*sBAL:h_ry*Ǻ ht9!l.:) qBPZZh.wpkޤޒ`[[ ѣ)GbK[k BIOpBVE``b L64 y4TҫOqYw'v$'T!CRn/Q)F=$/7_ ]R ׾ K%ї@J 0L*݂ ` 9Ә< BjN-g#.qGo\#y Ć,}Qz|OHf8Brˎ^!y ;J8쐌_ +Ki; (%k9!KNl lѶĔq%b A#.9! M+v;n=A {ї8%Jv2\ yΒ'`$xkSՏ%U$?rA#-QO3+ʃEV#μbռ}>ܯ>6g-sp2aЄ$[sl##s=<+ ͝\圾vIb3j"ۄQAޥuJ4` 1D}Ѕ!kA&X :H_fIwBIe*<6>Dud՟2t8|Kt H @,K۪BAe1&pERc&|AOʲBk$If""Ksɉ;3,(!2T\^'؋J&J4-kX=H#d$8'UrNͿs&QrXG37D oPquo[Q'߱waPXG7GplxA ϊMcdTVؓgdD_/s>ˮ9;yhCn#`oq:b#ed?#I)~D['}g[]8$?"ydvD+uEx[& P:}%i`v KРfN MkKCdUuf_+L(ld`.÷8j ( w)m4@BuBS:'ڣA磦+?H YU)J{uy<Rʟcb{v(QAXcﯙWsa*G܉߳!Uo=0;%qe_pvHj$ ~NHr-u;Td3Zc?ACӛz1>X 2Mp$>n`'|yOf[*xn'4I: i2Ӊ[d6[r oжjEwXhAo|enz󛟂Y|rߕ(EHI& 蛬vճ*+t3*˟2`*;Ⱥvz5%ޕs /J<^|gb`7W_?*.`Ʀ~}Gf_?1_x* z7z8ɿ:ƉBWJ=U'\|$1X)FK;b)7ϺW/}CISr'_ElW$Q;Z.w~xӘJPq]o J5|k#5A.GXt A) D;v1v=1 sCH>މ\=P./<];ht_'ϻEhAϠɨtj8!zjPZ׺) 'KNײ+*v/ar# d Ryi5$M#L&EFendstream endobj 405 0 obj << /Filter /FlateDecode /Length 3469 >> stream x[Yo~g#Ff"È8 ˰ bbať($RS}Tl-K9FzPY]gW׽oE'EW?<۷ozX;< pD #]Q<( ]򠑦=70K)"}s:y*|X;P*U`P0 #І~ [$/Yr YqbqȨc$D2S r4؜g() L1MjJ1) xr a m]j0:H1Dd५ H$%eIUQ n/{'z}*_@Rp3 BW+$g$Sf?t1(S4*AɶBGP>FF¹NX!m2E-[t h^OPږM85."WHmU*0ѨY~`EI~up)Ev|ƚ<+eG$_gz?!zgxWB ;!i#E=QUw鳤!F]#yhVr%OᆚC)&%g`B%f Yws9 ΥʻCN#5lg"LVs:G+]6<8y;fbB2:[*۠=j2R7foȄ {[K|]R ;"׺nyv r/RlC+ 2*IcܮcC.Gu%z]F#X "yL"/YAVmn~ r q=z=k߳=hetz>%&\xj\C{FN"aC?|i6 ,^iֲѹ*[n_\RU2rt܏A߬R5KYǩK$H#yV! 67ΒKv?gw#Ul; gxG2 $g(|+$oYH Gx?gy_SHV%+)kr^7SI=.PYMW˒gLx/X`L&=,1 azN^>Ɨ;L´q8jί9mXr$. ;v{ w|ː@ozkT@gim& 6.iҫmK Hkm;}WD]1ZG+G\J:xډ1E*e͏-V70e Tn:g(:v*q'}AYj]C jCWh[Pn5Ni %$<@kߐ'5#)c6kש-10=H᣹bSM|餟1:間`ɞOЅ=-K{"hs. Ր_ ԯO5R|~q&ϧYNlvp@yIIP"Pvv; 0AtXF5HvHw )d呦[$y" Tkb}$UH?{œWeԆQg6…_ԥd\R@B$@8$49ϒnڑ#xȁi I0ԐFk/`m'`5r% Lv]e@ZV]t$|-"XQ]7;fx?&KH(>,/fws W)j^ӔY"w])@rhg )*bPy d6}u4=n3pϭ z-?# ܬ߅=j>@CD;zwv}ZPTnxVCMtM\y^IV҉I;B\aWzyBtڪרͬ#7?yM?t 3AP~r5tվA!U&s#Hȣģ IؒF8at}~~<:cԒCc/) > stream xuMoA +8+|p -+q8DM[6@z<3iv]qn 84P>fx{\0WWoI!' hˡ䘝hpf\#I AರD{]1`Ÿ7j4Q a>&{ DBϑ"!"d&-T(Z*pUQŀ>}l>l5ݱ[@mR8,$}"dz)Џ^|?zuFujqN[#\x<#E}W E4Wp;.yK 9hT| 5q>zxbf!xH{*12s/ϱiK3lɓeb6OU[H G{&}"= ^뵽-׭? /i3]Uk/*0t^㯴.Zb19yyF-b`/kJ?GbvBm"K81%Gu?4?W=8]r58d!endstream endobj 407 0 obj << /BitsPerComponent 8 /ColorSpace 168 0 R /Filter /FlateDecode /Height 672 /Subtype /Image /Width 672 /Length 32244 >> stream x %W}'֤Ɛx-"plώmezVǧBS{. s)Ձ > '$3 6d HH?,;BONԗK? nw@rcaeG ;ը4: qomA JsF%Ϲ ç j(}Pn|}KJ+)^t 5=mo~(I2ƛL2C|8ʱu$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$\kI HU[[9cI%  }r/a?Lw]9uF@aBgIv~ЮQ@Sχ\Dﲰ5|&I" p7&UcQ%7>w e[une{hZ)蹘Zy݁D[ 5 { G#/QmU+0y(VKN':$|A/\$>zy[ύFY]%|^+_2> eFnE^׈}UJFiZHRwe u(? ]l16ϧ tUۏ(9m%V BU˟9c TVGO vyʻ,x;g#D6W5~>Ҥ*5]|Nʬ :@E^H2^T!rsG@$,By]!+c$>d#BxI ϒ=C_~!%XV#[Ī 0|H;J3|™edtE2>IO!!doQQiJNryG/BC*>D;˟U_-j \iKRm&3ZFvq5)7|j&hy]1}w'mOl'!@)OdpxY/]_)b3;&C(oL?q6֨vDع' mjQ~E?Ay4q)5&)阖qU.勤>ku CНOP?M| ~+?϶ߐ7`J[f`Xv^JWV^م~) J^䧪"~哧 :(?٧^Nj gVoRjV!><gB iqZ !~e-qt3պoJnYQT%UXCF(PvIdI-oN7C]?w(@~*S:eEzzį.p_^ n O,>_~^ xB[iGv|!Y3t.#h2AHh$j؎,J; IջJ}áEX$ _Qb+>d޶hĺDv%J ȇ g!~Ǡ7;'?W7h|Nɟ"/@YW[֐ -pCHGwG^xG~&T0V9g;2`|?RJ)BjD)9u6vdGa*~JeBOlbݚv)?o)*?BiKRm&B r-l+K>KWg"?u~k߻Ww@)>+'?Urد2ԟ(F%?:ZyٺHi$HQq;BTgbG#]xJG.xg[\ԈJSft7yGvVHJ;UfяF--ɇ,"=ğ#꠪בO5LQg4"Yfc?#f|FT5\Zo@!!=įL+w%9 y߀jt]M D# /oTJ #c߭ hmSyIj3!Q KXuhY/]_)b3\:?%K~#ᗖ\/)*Tx1!6T/M=!BD0\;j]!㏘?ޚJRl$Z]]me i~x/ϛo]6w]9Uh֟VʾBr Y~2I򿥾ȟ\oEj 7|K>hvMH8|T4E >և_[>0>:YJHY,(bM|}re$ԩC>iy+U2`>C䦜=-bUک-X'~Ưt۞i)߸,?ַ[ӿSA"k4Bmn]8E*c?;اCAC96st>#?|K(,ym@8rqep|8[])Ǜ%4WH|>/Zy[}~8k/3p@QbGD+coXl:?)@exv2av!&X.9zg!/l/mCmϖ*<(C?$c;&g-NJ;U.$X1*~X s˕?(xer r(;նG ^w ;_EjprSo/Gv1^Moplrr/=HY@++p¸x (JA6Q~Gxq ̡g $[.P +DV!G-.`k7U"0Yޙ7)A^l d~6 *n3qGMJLٟP&tf5:)zCYÜYY1(%ZFl$.:3*U)[ .(BSUC(tJZ8R :'4a*'_q @*nYpIr#jv!2R^W;+r<)95VR{?YJUR"x$Ro%TySHZv$%W gC|*~ Ʉ5:o4?RJ;v$dS83Tzk*!T(Ԟ="so?6WKW)Vߒ?3T-PaG s\F* ˡٟﻂ?kXR%RTh&@T`O)Tn2am6#D/o{:dQO apIVOav'ӃOvrO`r6 Φ|g.I?dgǟ`_95<uGQԊ?ORRB# =U\Ud G&g[͟?6}i/4$ = VO> ZxhG%C1CTvȟcom.٠+ry+2q %HGtaW㶎?#RWWG%2µlR✥q?z埜. O~,O8u)v%e򍧺Fϯ>Z'񹀾!i9(s?̬%HA!NjD#_ xAtO>'L9{U%t*.(g/ύ?B5HOi3?8 6#;эUb3:LTß3zSS?Vǟ. :rW2ypze}Ήs@j$>Q9Σ~*4OOi$?%A#/qYٟu#VVCB)?QCIJry5H'yo3PMlHt\;_JzOi|hy3ty 8;Ŋ9;Ov1IDACs DX|B{`-A#9hE:!5ǜyX(ܚW|뺟?d*3VoECg70gas"h6ϸ\O׭o?5?i 1>"țk{ A_'˟̟VqvGi8AM˟ 3h)Ul 坫\MN@ePXCi0U}ÝHrlvV$5& 0F#s1Ң(#(#7"pI?9qa?B 8pqb 5g['!H$)?:4s]ѐXv)ϏGajW @QhB)TWc%G@.PD$5 |t~H *(⣆zv? :O yrӕ,^LNIZc(!ϏʯW"Z|2C0,['/ h~ppcuh)+rEG>Z^zğ1س?zS?p5#qAŽLb ??W7wGL:@n FxWQ,Sh %MGcGmXȑ\Crn}#?[nƟd0Tqkk,%X7|׿7@-?j8f:5B^"oJZuFIc?]ɮPc-S+ȒXTbf|8D`qe<?7 cM?]aR-W5&S^uf$(@eRhנlu!Ѧħ98766ǟg[#ό(tw]r.s\sc㏘ddF"$H]CӠFz)Ԡsc\bscρ۟4GT鉓CRޱ?;UY=cpڑ̸ *b5 hŸeOջte GM-Ϗ}c9I"H+09>i_[-Z(TM@*%C$ 'pt zC?)S!o+*@f3t."#NT0uk]^'%J^ܞ)MElҵ`$爤zB!qzt˟[ß5ȟ rfrn@tm9aɢ!?9j5ΜSp;I@,'< FL'd`UE'NY?#S_G_[-U$E´#T5ZW2y S%Yu~ڟSRTP JʴB!>9+ϟG )[ b%Ҭv4 e<qS0\r7o(TxQK1YwKDHTRr*F#OcsSk \`vIfgDڟo(M_"a)*OE;H~Ğ8^mϢ4x?juu B\syN,gś8c OA'gB؈SKB9$1W3[whtcN Iǟ[??7ٔ?f(4 J\Scd<*IyF#LN=4^ 49LcG5Gqr!m-fS2b$U* n2k<-Jad$SmCǽo_S/glQR,9 zHF+3/U54#3z\PD98kIbIN[hCq${ \9BnfaA^gY`kñNiPbͱirBWM%J_?ƟT%+!nAYhv=,xquQ@s̉ICvlLnt?S? L*eBTzKBX4jh,GcI%5ۓrd{$y)M t#慕 +DTF]aFAI!-B\cIULN%Cxx0u)r2^n9:̉٠^Ϲ3f)qKQpPfwZ 0g@$ \{đ2֯~|Sج%HwN^$Vٟ9n!dU;#P `e7";]SwÇ8 sD lN@J~h$FbSzbPMyC5UHuCc\Z7^7 fځBDxuKZ]h!c31)E@RV{4 ]ڟ]) J>C4tI`:&gsPdĉ!>Th%(/}>rQ>=1t2ZaKd0LѬGY>B (akC90C9"'{ϊ8G%_hl5}a/!{H= ZXJT `zl+\u2,4~ưϲ(Ax-a0^>vն X QnrXxzwH4S#SmNI;/ς$H,ιm"IGNsp^_?G? GހA&|G%Et L7hϺuKw1&[dqZ a%Ħ:kΣG0??Ӌ>XG?3Ft`;ݦ+w) ^UlmQ!@ك6AT ˯U$ V8Hsp+˛#G^T/nO( x"8*NcmԯNBFH8A8ib:/`JA%ΣG8vD).z2/N;ˇޭàl$K9-NLp,u]'@-ΣG\=^KMOhRTODdkYNu6X;nh=tխLPEfIxlŸ9>? қhaNg929] KEjCG] )1w'?AZd۪ (,_DGD{?)Qd$f$H )0fcW$cYԊ3ם͉Y'sRݩtģ. ??2_4O@[sԣj]xS'q / fێu^>|a,i\Ʀ[,)3*[ IպP ܘ%Ü4KelJ(Ktɜ žIVfM3ܞ?4Bs$2]sꦃ:2aҬI L8ig(y| m۸r]6}D?Lǂ7`L\ DT2]aKR DNmCxrN`͟^'A>OUSxz5FHRb RzVQ%ԩF%6kyb3tʟ}ڟVKl 'eKLOjqB3F#(JHyĝBh%fL50:Kaʸey@Bȓw \d}j< R9(ɉ?_FaNA3BXȋ4,sQ&kU$(ٌiEWRאY7QN?< ؃s±p:DJLȳ3 ?|$GA(Bw6iLS.94sUBnLԧ -;DP@!wR %1IΊ4vcǎ'>Vœ'M9F_}/;:O@Мu/."挳2n RLDTc`Vc)gpr54F'V@//)s(~tYBH``Dc8kdd5U7&sJ$9^"G3g򦛣'zN97#$K!*.n;m>RѯH  aLpIKzօLƝRcˮ\b=>;+!;}AgIfcImS&F *b>KÒ|`jB`tNWX.^vDjfR XϝD]|ʕKK܊ϗ x&G t;ۺCn<*64KΛnH`fCy?C0:O}2+k6/]g=ڟӊ߭Ga# \F:R'/.P!~n)f}uȱ!ZݻNPstYJ~فTDv A&EVg+dŢZ8QF'-i9Q%EfNvr~xNǝFٟ}I U=]lE6C8k|ۢ^eL{~4QVW̹u%J>DgɝgGȍd~]<r鐡pʦ κ!l;V: lA>' O0ѩχKNZGuyDG$>":(o W·0:Cew <1i"$ &ȟ4pʼnUE% R"]ęNYA`dm7peREi $~96WcuV̉P\BfEQY`n!? 't(_NK(g{0RMl8yZW4!P܆qN)-OOS%12wnz%BKt=%pgfa (˖ls؃N tfQ q.QعMu 4gh}k95>;1F?ra% " d | =uh]wI`f{G "u;Q Z70B?:DgFyeb B۠NYN0TmwW@_P.ce<ڦ'LϜ.w%PbPȟ%wƀ>Z_ S,$wiϤ\w9&U"̝Z>FW`"+V{t?J)D#*ᕽˍ?JqzhHMblB-vI?zf$3DU.;$ԙsg{҄Yi D#',(HNGbZ_HXEj)8]א݁XQ=cQ*jKd}8|RST1%08={8q~FܐEFDyґY:~HaX5j!π }#ߵ9iEGg4mjwY6uz8q9:3? ?KjWvyڟp<彷6Є <3nK[la *j_}rfz f1%K9w|xɟwusufc|?{}b181*)=cH"H5D"3'-biH Mi:|~vP_ÝT ^gDqE N[;MsaNF %;iyPfL R;{nlY@"<+g,4nLВ+"E,s_A}3~G]5:Lp'IݥK cMG' &>Lb8=e'Å!~v0tM;c>][o/?/VȟB\ Zj碐%'t\c#M0!V7LʊgLy&%:Z(yǀ5VY .-,=O@x6[Wf?Q[nq)>? h'dM.h,QfL54?s./^|\ZΓxԤ QJP:`4,Gdh-U~#N7痪[dVT ~߭V^_JGx|QaxF1g.JUߩR8@ugd&Ns"vNĩSv͞N"7}J;Cx[ C2 BY?;iWO0)jbwڠtٞkRx<%$Jݷ{M<~/S\{L6r;E90Q\s㒨r?:pz2(M[j{ί?>pzF33N!&YEAl`98y"q9D2i ( uLvFڗLxwdXg!Q}'9]3aE 18X#lIft% t$!9(W|D'$uIY2;nTRg̒~-JcI}xk5Qo4Ѧv94$,{=cs_Y'_3ϱY#|r@C+0@\S!/(Q N`&k޿9CBF% aBP1tt5R&RßVu}AdCJGz(3g_f%WmOQgeqyo}^?3r8 2(MaNfʟm,O#0)gm.\$%<]=qg<sM>sjsótK/xX4 =@]ORRֱyž4ydgV™Jn|mʟp^n+|-KkK؉TMw0 w^ $@vĮ+,,gVt;YN8+"LQ3^B?8=}ʶ,zJ8_܆;9:trBmӳ䋇i;iJȞOnz ;Pu±˞hlwLIw?'&8#4 i)<g"R5; {,qJVisc9H@?ɲy}6G1جy*&]LzO]G!Nwjorr%Of,Q4g!kpQ2:==}?_'Oxi/dʳDu'v'0 @vDZ5FĚBT5|=(DS_{?;ٿ?~+ϔ3AZ@W4 <1h|^)HМC _-8TmˎBO`Nds$E|DpKxI UyۯIFjBordt[?h4g=?~"GyPS|3Ɵn8=t$!pe*)ui~ަ|2P֧ji()I-s۞'.]ޙ/POO%ƣLQD?^CN,cIy"\sT;mO㼜fY/}|FL$MGOyb#wו]?(yFq2:-/m;Wbⅴ|jjΑWh=> ˀ:ϲIZjNK\nO5)C˩lI'Rg?_'|OQ ]'.]r$?O٨^, r0IUĕBEQ{fsv%9\uUu|=h7 r|: RnS-@}؟r8){oI _$'0؟'ROϛ^ycOǟΗ2ȀnJQbL01['OcwZrv8s?[_(̂9\M' i{h~B߻mǟ:<)ph"؟u:zAc?/~NW#_֏<]#mg>2T@tef;Bga\x ,5$Rp ӯcU8:~ ڟŒKf;v`n>-_~r8:oC?Dޯ]r <` у]*xv|o7_Ty&v>!|κjd!ϷYM#|ϔ#ny1:ﻫ _o{W^R=|j ٹn84jxC:HO_q Lp@Wͻ/y{~1yǨ$"MOmQ~!/v"|ۙWwl.j:MtSK] o6~mwZ٧9<cy2@]}%Gc; X9loǤ޻G韠-/Dbff E, G#|Ɠw.UT$Ɲ.2!]&܇{T%;}t$++0(z˫ǔ_,j<MlO(iLhgπQ0:' ?i%|2)}5 >v~ZcJ31;T/׷+%vϨυ)ͶDբD\%x*2 h ]oi9ogٟ Fy_Qzmnm5ZF9ao,2VNFA^$PhAP?NMCp6Ԭ?;xv92adIMO(' (DGl1$? j%gЋGRCtRjqMfmşGHo%]<_{Ĵbke(GL|, 1h/V4| hDA1EV/IH "%L$7{?qm%g1΋m_M4ӁyBD΀5Ajbz{50B%$Ӆ Ϯ@%RYU&0@m(9( 2?zA۟[w J$Op, +X L*RhCWO2dzyx0u rA$۠[=ֲS>r;}љ 9+' &!H4(y C˿'בf#< @$iz Xr66->- }kpmIuq<-"w.B_[diZ$&2!eG @G\C\ !SR `*Lhϒß \{6y!3Dם% A:>A7ϭ*kVX,L:K1 7貣/"BXP\^寷| :ǫQ6JӾ('oΟ3woK9 ?Kş)xC \6Zv>pc4!H}=DYX(xj!Q4#/ӧ(%"PHv-ߐ?oms߬@ VD:=DذnXZڄ?뼷mΠE P}iNKZ˧`H҉BHx\4>^:V^O]3ψ#A[">b<{r}РO Ь{ (1(ntz6 '\,Pǡ.,J.As+P։D8(Хrgr Gxq2\|y"P kAO\J7}J}@2XFQQ7!R!6Bh'!֎%<#{IOOH#J {#:8b&&1V@t eGb9BwIZntB%1j1& kJ޺E۟mtraO̟DQXҧŷ҄D^4%vIMd@#-Fi{ek$PFbi*|ykvL3gST)(sGá3Cի۞;ȧ<ɟ7i3DOG4J{b{),se R){hR:,j¡03_s>JgFg+/94~*E JW"@1/⤒GBA*Iɢ|2^̀D/;y6e2AiˊMJK>aψ?%4}OǝFiy6@<#}MAJ%6l:C7 OG( ٠+]LO\KB4vГ[bJeWsȄCFAkw58<`*ݺKSJ{qQK#a~-Wz3g7P-;?q 9]DYzD6<5Hg*?2" zEFL)z6.ɸ5$o^xg,<| Ož)χrRwM/7j6`;`:3B((jN'WkcʗD-e9I>sś,`H4C! L`]SDra ۟tu r|ª K }"f)zJxX)7(n5|Qo֙a<~gX.K.}y>i{Y7@M2'PgjnGpR t/I&P̟8L:1q 5]r/7P҃L0 6 o.7C}>^&8Cw|f!: IUDk.ȾObURx#wEh\T OݯtM7!t.y͟E/,ttϩ8DOUɕg=zP#p}\Vm|"K~U r‰eҍ1T]ZY:$,_=m(O2 D(ƚ"տOV ^DvrMb;!|g5#Kb`<+'u5*C7=#ƓР@`w?^X:?ڟ!61B#s`)l4mS]8tS:ª`|)  O<~c‽Y(z4.( 8!ul nUG!kz%0@CywfV]ϩK[v|\ ))Ӟǫf9BQEGP"u拊lL4ڝB+/K^՛s_gy,?OQħ4>Nϟ@TӰlv hVhFʟѫQCd1 E4Q,űU2x꜡g(T*LQt!M Fx~BiL:!>ow8bcF23(0O,h) zC]H5t>?OZ7w#Tǟ 0}gD5}ˆUaEJ^iNt'Z SE'"e?U.%gAF4AIsOnOECcZ@F8zWқ̬MmS:B@j_~gmHF Dg$&:KLZ) ·DL7EcG},*j BW/7uIiR?Z`~ɡ[|.@RYD .;J:ژS ^tshQiU=Ԡ(ğgvIf+6<`RPnb'XǢ|| }c_ϗY` -F۟a4 NGQ{rZ^:m4Ħ _#h%4_8O= _x{3S=ᓍk!'l,ϓ'Q} E}18f6J q=y| _$=G7Ͷ KZ?:S3! H5xT^q<*~y?Ն"sD[?oЛo0>K=4j4^@V_ng?U/0A:{K0f=eeɔELy>`J[4ɛՔ{]=]*M"lыHGG7㇁K==.fp5W`ja^\cV4 cu/@UxA'T+N2YN5(cYS}/#>]򝞅oŸ13R}a{̢)aUk;-tW#SItDODB"`O7Ia6!TΕ6R'mJ|g:Tˍ(wz(g/OcP Q"&jxN3VBl.CݏYtZo Yj2U?&߽{cN,J$LN^5|.M{ܗ`ٺH#P[6.*Az! G43uL2am CEE9V+Z=])ϾH'HZd}gϖE){3Ehs%w9]ڨhK"HU^h&?")BD$b]p'QlQ[sC.rEǑP=XֈScU>6݉'CEc(}NĝjB|Ljy#oXeL6@H4^G?͟=D -nU1OL$09TJL G0l{?1+z8O"Rm~]?.Dw`Tyn= _|5gء^z7CDbLHkF/3T'3?3o{btl4w`TJ(W, Ieуt2 J(>`|ճC/}hZ :%њ-s?N(E N(שrs&7^-. (WJ|~˛??ecdD9$6yl VH$Kfɽ .sG*|ο课be7'*"XcWFeTD0dgfdK4LP||>R[R>׽ӯ|rŧ?kuk K5|;QT?ݏ^G{tZ,욕Guz3`~Ɵ^w77/FKFOSuc^tldT"Q&=[#Z'_P{YWϹ؟xOkhRm&2feccT4E7^w6'ԓII)*z.% ]$>t3',:Wӏ]x9䇒e`v2Z$|a$ ]|o p'h08H/>!??i1d ̎JO~^' SDSB9^: 0ȍQơ´xudv7O@ˏ!A,͍?a ß~GRP8gR0sr?iL;2MR0w#|h>?s75t,բ/?ag:uHE>q"z1jIuxqO%2wt_`ȥ%md4,o$0ς89kz4eT6rOßa @=?k'z2ڱ1 #Ed,hxhFztCEiN'#/"f9DSlC!(jT=OoJ(:SJw1=Z}eg)O`Zx(g8 44Z NePtWQq ְU<ş.)a"?JWt/[laBy$WkM_;6Ow>}z$D+Y5 ǝhߧh'c/vQusrzPH2(-]nwpqdx].=uڏ˯wr Κisdڃ$hC IOK,O6[^8F. 'PĠtڝ=k(iN|].}1I!M)6j7"}/1hX|t~sv;jxA׋/vS893c,*a|,@%k"F⳰?!gBQ 1d n$&47#?<êYo[["*Ѭ'TRL`s.|ՌnZA5]grSrhMnfZ~DZBbȋ=Z'詗h(N]SbO ϳo<$<#-g(PO 3(8 edcTP}(XwcmO$kʀRhGx?U},ӨgQfHqH tQǨ`ՈmpTşP_"3KЋ*}zu#g>l|7K@Xa%c-`)ЧOd:2ZFRIIRK]h3~wAG% NFMN) u8e;T}R v~'i_K FKu˟ bZG"IG˟Ϲ׏^Ƨ?9Pp1Aa);2@͟1ZCDE8nT #ؠGH}iWIo Iе¥o=}A}>{4q=J:G$F?%4Z:R:S0~n(?LS_f)li#V2azΝ?j5CrI~߾V~$|.weR/q` $(,-ljBWGɊtٯ=7?;\MuvDh߄Fώ?Uoy*w=*3FZjxCy?V;`<|Gb0{?)ʹN;ܼb/"ǟs?3KZ=?kKA5=/̴NGP>R~Jyx1wکۃ? ?3 ~ɛXOiğ,a2)w0 j^:ol<19xz=TSUg](j(fxuQ32 Fc/H@_L9';h-B Hj(#CCɟBjx)BY(Q{ύZy<.H0 PJH)m#?3)M`0!IR̢r)?w6s84[$ ƒU;!zJ{^@i.si1ȟsݜO?DЂ9q"g=`Oڦ3۽-DQk-1g99oBU[Ԫ2Pv +/I%@WQ!*Ӌ$Fw64#[&#{OR ׮a=F4!s(bw28x1| j9تf)B-DŽ勽,lŅCrX{Lßjȟr:OrZE(aӦHisWmvK)3mg Xv0$I:b3+քL5*Qw`>aqkÿ^ƆtP3%Ig_PH0;$(hA(0JAv);TN]>)xFnG-9 Yت'?Y5`?;fZ,KP;ཛ __˞u|O Of T'I׊?! >kk@h`=>o?9biڋ3?; r4[gFv_`\Sq(>҉5~ߪ'?aP|23mW}*ǟ[$,,P :=u4ͦ~d R1/93P? ٘?3qqх1&$"_=H,MS'f@NvS@p iJf;s> 5}7w:g-`)pAԔ'V3<Ĉ}^bZ?>@#gFğ?iS.?Ch`"+ӡ(3oۏ_.]v:2MS,6y?9h#pRB"Ȓd;9R!|t|"JANp=pTG0,ц;HF+Mx?+t 7X#HdBaZ/Kuet[482 ]'HN͟+ `,'3?32nvC)a_ FwF3d U\,.^B/E]>fzlf hKcJPE P؂ A XԄ3)*]0z(Wamfٗ >yT2l#3XR88ez$L*$ɲE:A)W]:hs  l$pE 5"}:iI^ƨPRcC2Ս?3ڣG}BH# 1WRxlMF1>F#31FٟkF Ʀ%Leh\XY.\"Qj`Am/ѧ7gӁyw8ۦc*e,JJ1㋬Z-{ :&υ)T pP=s?g'F- ǪFe N@u)x3p薁?J:e,23z(?C|v@#Ҍ-_b9w1Hj3N!k(EH)J*ulaEVWկ}|-|" C 5$/[;pU+u:a* !&ܽ`1̹F_uÀ Z!#MZJp<2R-IOoW٩Iǭ[ʁ;,>6?GիZبze?\Dy;lZlsfxG^\6lR N# "}nEz!Vf2qGs}TGۚilyяo@AP:)Dۄ9N*pxKd(PYep*۹՚C:MXhSshddAO >o|܋(eã,I7\hjt䂇焟 ?= vkD$8]HERXpt\oH2ՑA;f~& Kf6gUр>mk嗒 m32BuG&#BqIh7#RS<4!3lsΟm1)Z Ѝ]:ɸ)|ύA}W'U2GSrhӚ2XR:'1\_խ'Վ ϛ|h(,64CKϏ/[Ps]&)XV_ cܯ#׻cE~+_Š'ǿYLP)L%Չ*oph= ?IoZж@Qri{FД e#^Ѫ_Fdt8zulf?Z!o2sԤ jCOmkzyXn12|nטb;X.oFs'!*q1;lz)Mq~=:~N^^t|/ɜ)}Ѝ&0$vUFfd+0zT ZW3SC?G*<(LTDy# ŭ(aE̎It޷I!Q֍2;U K>U~ŧ?W P&QE RXquΕrC)Ytjk{(Tx;ZNgisWwͮsq9%̶N/Uȕu4<ʁH2677KS+), GZ֮/\I߲9`ڣ꿚!g-ߕG2_MK]zr/ \`9ݹuW*Ҕ!f.;E^߯i 颣匽;Q.@Hq PeoǚE 9U{JC?}YױfvQ3Crv`9]2b!v~E š˟sn5I3os1[> 5cfjƟ5?ЁlнCfQ3yo{Y3sX3u?.5k5+iT{c= WWp]O|$D"Qs&7k̎T+?Vo.,,(_f(II6ӣڟ)s/|$G5u<|AKu2_=W R9pzv= jm_`pwܘw۶Xpv=Zig.-sl]Z;=vviÈϧFܝG;^R#ƣ -Ԉh {hҒ$I$I$I$I$I$I$I$I$I$I$I$I$I$I${Pf~H;k.x\AaF6ݸ f? qLdFg\MW{RGW4a3]^϶fO|~ }əgr>;7>,&>bgbG]>;:[;Z>?̢; ě33;R6h paFevd듣ǙE $I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$N&I2ki$$r*j~r7*Ppk&Ls%Qܗ b`LO0l$ B}c3 q$Iz,?OLҷs RV/8` IzRY|$}IK33LDħӖgߓ*>m9> stream x˒%q8rxgd {ЂAF(KBy9=3¡Q( ĥpt;t;?_OݟwOzJ׿}_RU(XJ>GmhX~tO)s:=Qϼ>qԔs??ϭ,wy~se:گKɗW;BOr*Wȝ:ѕb eRouy4Ćkרʼ ǼA}|+F#}y?q=ߕ=1ǽқ|VT4גs/>rp5m\sL,,\ $%ZܷH"9=&]yRqtAF.wwS&}Sԡ/:Z9A|g|(mR_ ~MmRuVV1叿72F{&3ް%L8χ7IPI$s~MuC\"oLQWi^,ôvTI`ӥqR8蜒V 0ѮNٸ~=3YߜBΕg]mIMzGRh4*ZR?!*~nxA|7<=<#LL=F[NTW:=?\sZm2KN3UΕ+9k>Qi%H)eFݗȔJM~D2:L%}k}٩5m s+"mHW^>r j*|olCٰ<׉zC,oRx-FpWqR$<ѧduA}P]P[.-55a1AXt|Pztp.c:!^5yqGAf_'RpX{v]ѳ)>Ul5%?i2՝g<#zJͫV`s|#7"}MF1%| :%ua;U 8n+঄h @[{CoG MbS>dʇ-M0*_D>3[EwS>\Ôqʟ/dB|T|coz<^`Kؼk>k/`b}.P((8~"[ܨ7=rtAaacJ}+6F)6oq9l8H)b5^9v +1=wrշz&sHhX\^ !tFcӿ=RMto8|L\c;GEX!Fᡀq'p>,}j1x=e1,yqe<K]FJ)]ڹ".PzSpFI؛k 9?B)a/ ^'¡ l!ZIwG@UJL.8.-d3F%|)@ 2dc nlA -E"0ZJEln`AXo Z 0 ,p38E\qxQ f:,Xvg`F V=W=+JxDǓ-{Jk J=f9%d '<DJ)P|.Tdr?T2DD1QFMeٞ@*(P&v@Ea=*$8!=cB1VOP` ޭ<O4SyCO`+㉘Sq7S'5 :vD{x0O&PW(gG%eKEQ割# 6#.L= dMz쩀! !uqi(AJOB}eG@33kBH{@B>Q¶"Mۊ[#Ba[`G)r*I²'>EHYlepMEOatH5D~ m4H=ɻwd{#Ǯ)8で"(0FPCň0G` Z@"F5tDk A H u @Ws i <ցD@w Y`DHE@":t 쩝nD—WW?rY,#LR ,W3X0I1 Q@J抓Q\8Y %aDm#,0N߃N:L2hΠ aOF(Y4Yxa@z> 5;kM@HKYb%Yv# jhdA+,R#JXZ`xEvghA Z8EbZEOWZYG"*sh"juhɣE`В>8{{@"g% Mf$%H;e(U4;0 )G BO}RE8<Y1blp?0;*&dB!ɎZ$G9˳1y!;qEASzF~\8~PzuVS)2~d~X h-U~5Cj=:Xc\0xfʼnC6x=DF9z =DrࡱՈY}u^`cliXUU!2>_زq`,|΋I'g(e'+j@]"%1ɠ)*-Q#N?K9n)Z+ZJ@ M#Z -ԦѢS,Pփ%ݓOZ%ZvC jX+ -h0b ȢdA)Y{, \72.x^mp\J-xZ t`VY0Od›Wc_۹Npk^Q`{xRex2Eny @++\<.]V:Jψ"zo>VAz*asgaw?c 2_)ݟԀUNz\ 0#(Y9oWh #hq>pĬaŔ#jU0Ѿ3{#qX]072 #FXђ +xa5Th+ +haV`FTf7k+Us*} DNdTU *V gI ('>WʚG+)^L?^ '0p%%@Nf8?䊓 Q,?婅jEl8<` X ,(YoWh ,hE[dQkY`1%ZÃ,9B-v`dYHF8dQ5,}#d,ЙZ4@FȂĆ_}uk: X2e3,%dW?9n|(XyT=@ JDtUJ6%9Z 񀒕}%h%JYndRdʲ%,*kPRxM>LxĮPB9T>{T.xԆH(q)}JQ%+JPQPX(5%j1C (QJ9J %CxD:f(z(J׆0@CՙDh$ZIDю$zG9$pwOd6.[bBy.,dk?.(GXMymNk{ yYV^g߲Sˍu]3qyoY cZiѭ,<9Gw*'s>}2UhjDu]eV+WJ-9+iġ%bVt\BՏ:$zo!$3T=C}Tr\_)-}pIxS{wvqQJR0oË˷sY-빃+."N9w :"9W99 5V1(ct=_>X޵2w^)8_۱eRW^p+a{*&kע= Wq}eUoQk/_u/u&Hx1/kM>lwysQ]Gĭ{ԡ]هxl~Je7iNژWKϊ*s:Zr&]ר5, ;FpvǯڢW^u*6RŦ,ڋk;^Gվ}-I6i NT^˅j;R7}R<}Z@TѕgxV'i.tZWNCOOqOy­ڕ?7oc zGu߼m gQo޶Cop%XY. o6S[)Q-ͭwn^`p)sHAU!hزXPu"}Y<^Bk)޷L,`8V |asWAWּw59^kYhܿF>54?3RPT6nHnjTW+1VTbac[hFaCRWKL~b\?st)~97<^QN}'Qh&Hk?rBk\ M 忩 # rʖĘõZ4! o#&ZSy ω+ϑV ?5ojImv(T~mf4)Sϲ\Rs*qϤO5*b?eP \gSs/B\^~gepM.?s߸j~qad[vo+ @:>O~Mңendstream endobj 409 0 obj << /Filter /FlateDecode /Length 4388 >> stream x[Yo3fmC8HX"Ф$E]ԁ|U=];$F`hXS]]Փ5덢OϏp7WGjőn?盿#[P欲?:*Mқ㜭M:mVYrG=;㳣?&N8nM}2nel ۝m.ߒ<<DwUį'~U+U7SNV 0F$m d7/nyvfm\oHg PlAiN)(^Ɂ)1m<<( %(7+;?Pt#U=K6Lq4 :♂T{%$[08$<N/,8 gkAyFv3hgbΐ`lԳ:ACKYPX!^\ b/r"']xރFb؉楣$.8hoD XbN3o;꩘ E"HXIڱ[\s-%@rPrY@݂(%~eWdrfS6l נȴHΓDA#P(!M_xP5ImGTn,Y.5jsfUQEݥyMZDlS,RC&Dq&1&BVA+bAn"8 *a9`D7C%6j&X셢!Ўx!<%i-^1  9Sߢ!["EK6p":'(䪥aH2'DVٔ>I61{ QfD{PȃTGRBcK+C6C.-,Ժ`"'v |.oR%m>$-Qrd$r<[R J' җR*-#m2l"*JNp'O3{7'Dy zqO7@߆-~Q=hwEiP?rSWV QjA{ RA ?o wE *|[UI~ ,[ZԪ~t +oE(;{2H}r{z-?, V6I"~&HOXx!~?4ď@z}%ǹ'[+hxj0X=6(>(*+KdWrG$g$+nk?:/쇂#^f,?tKC?w5O/7c XcX V%;GHGu+!sD.?X\ɸ+O4 '[|@DN'$xQA7'X䏡#m ?$gWJ3 &Y7h zFU!u@ h F$3 3"эvX\?@#r3/J4~:zI̥ 揊b)uB(!+aT"mq^3( /Xk*9{|)~/iLR0V:#t*#X ,$R;mx>(3]<*iIJi%g9e?}9ivΠ-CY geT tiW1OfM?Y Ř|h,/Ƈ؈fMTq:/rA kb:E%vEp ,Lj`w˖^3EʣY6}Ȏ{YDE Ie}*nu |!Bzg !evtE+j9a4?sy|>džXW_{*|eUԧ?>FRƎiw:ڡ$4x'8lrYCp7;jNPDiZ[zUSUUUɰ:lhhZ]-Iv%[5FJA\}n~ts% WI| z?~V%^̻Սox.-~Ajޯ.ö*AcLM9xQ8iL5q5LD~髭%"]ݩWGV4BcmʨCFa4v1KTh8KHY-QNrm+^7]uZ>r5`rBX@cщf@4N~(}otWNUyή+ՙ ~Sol 2c(k09i@Rzlp`2e@ptKW9_IJC.9A`pD5~|A9qWb0Jڈ גvt1՛T&_ E(K^s H0  ne(i*."pT)x@pwO\BՀAT;C+P˄k,q(-nKd CU4%bBidҸH:Ji5~Gl:D>p7ޑY˚!' aH3L~"V.8oUL!:Q)0)CzP-\^3vG~al\3K7} _Fo;C%%C9sYW>3 Q<|Qߡqkpa R/WQ j1:oP#ƭlI踞ejxIr9E)q6uң~0xƘEqo׶buGEJ8zWjw&!FBeH 9?ې5Y! gF>+W ?).@rK[O=P:+Wy>z-q!aFWva[S;_;>)V¨jU8PkϗWĢ^R.pkNwʆ#+˚Uk=R6pE-'?K+3=SE2y?ed'?.Uz20|6C*hVv{/Sl^ Ȏ|bx8*j(CfUjY>)8$kdUUS};,$AX;|Sq6C Y"2 /^ WǻJ|EG{.Q RO/|2/{#H o[1:\3$L'l>g2` :І>1b$uJbNa>BD(Xͦ{;zyʕȲui[U|oLAy"bxs0t.S:ձ>]:uשV_G1 20D~J}kbj?."{M m#bF&%U> stream xZKsNḐNCJ*+-RZ)HB"73;AP|pk{碕s}Sp뙘db#pHFdVsBk{ۨbvuEӬ@hTb)ZCYZ^\4k7͋ꔍfTR ZNiլހic&d) y$+l c-8tP\ecY]vtB9h"$F$9oeoi6ù_'H?%Mۭc4DHKMH*7CR`1X|**a(۸t(KŠzy>jjzma`a׳Fѿ46N%u̗ڶzؤR4>tf+ҿ|猄9w2CfE.8V4#P֯27 [ӱ-'< jo\g&HW ER}ě6߬7AhzRL:m.~& x.w_ e;%碋GB'nx+ g?v.= ^|\d\TgӢao|L]r`Xk&\2Q8|?P"&YmVJ-<# ~Z6ӝmq,Tu%,8QPAم]@pà|\6Yt4Od 3.ncuSXB }Nֲ.` ! ;3d? e$łܜu$lRx +g̀Fs- uRYWrBDȦHXl':FdZgZ 6?rk69b0vu2JuKR)H ?𖣛 SF *\Tv-9 x>C ?/ {Oq2fflfi?-Emv\-]Φ,Ȧ 5QU\Y%lVcϲ&&x ෕%#P|)J1-=_~ '4S)g#JdbEcً;Z.͵\ Ui\ޗr3l5C;x% կvCBtcXZVӁ"zn[aSԕ,FZm6ʃF$ ڶy;7W{lR+&6SԷ5*$iCq VTSӠ!:9O*]*dW6{̨`㑣0Z-A;N' 5ϋ4 $Iydh`G5r0d+辕/w -%+p-Rz Y>Vc #LuP/v}zuv8GZ v,w{)Ck_9dQ`ѝ;;㪧Ai=5~Y "!'€Dz."]r wMw|VIe]=*yYu%o*y3@MG/*OzBػ՛JU^gWd ggGNj>͒Y<J^W9+݃ ~r73swg62J:ܝ(I0>.ףk }N{<{TI~gАN8E5J% LhBT1aۚXX`7){CA)냏+)X񴒲BM%U%JǕ> stream xrN#tɌ̝P%C;IQ $EJ6KKKT=h 1\K>tP 4ݍy`_0?:KgW{lq~_鿣`2xd/ VK88~͜yAIg^u ۭza~[l+_|8+ ~ޅ1\XλnѝŘv(Ikr K71ۜuVݻ&Ohr79#dqgsݶ,l3D!yމ;)*ca: } ?q 39q˖1ªaJ(wE B1ڤcJn $i-) U(h) ',.2w/%Z#XRd+il7K/Q1 -1KN$1E[G=q9R&q]Eދ D%Z=H҂$n6΂6ʍoQ͚YW4ix3`\U#nu1蔚bzRyに UԐ**;K5VRH* X.c6XaJX"> VB L$' " el1i4ɞ`qozCŴaॿG~cHރvZB7rYqRC(]G!haY4бFtnG1%qmSl nW-&xBؓZm\u Yц\&bbqt4(G+$s~c-~1.\xT&v$aGYdW CA0G}#j -U"S0NSʢT!|[L P. 6&TaXN5,:ś%^32`) B1xpvҾ@noz& QAvL#PyTA=#ZdRb*9RPHRN;2:;'?,' )q# e̎wm)%nIK Icr*X=Z(\(px,5hL"I:GLa+%ޝnZH#1he5?tt jhHjɉ 8F!2 '8G/{nMIH7~1j%r @C6OE3Zu jD83[KT3@6UAST:`u)@UgO~ɑ@Rh}&< dAn0^k8~% HUw|\5o*!Փz]u -n%g k/7 9 *e xU?!z(4m .7Oe.I9kb[~[@]|gz|U@^s"𬀟y_ep((cz:~I& quYV۲-wɎ?Tv?zdK=x,ɻ(BaWdM~UAW*qgU': (~*>N]tbzdvNs2\& 9MSfJ"{I4ItDLGPPG͇ Dt]W]bSEl'OF =sYXWf ^Ie@.!4CwpB44-ۺqb7h*'&veB4 4hryy}vGmHyfHe},ƙnl`tu`p-m9ײQa%<'Ͷ)})qgB|PъR{&iWqj+ɧv/\/e[|i&\Ԟhu7m Dlt!Ӷrv'IATplV5v+ pr4楪 [ qz12LӆEmp^CG`n&a_9Q.WCh/9>!bæb-sF;ce":lQz¹Tn߆åYEg8hu?t; J8OF句`fp.mH<ߔxNJmڑT8! _HF)v2XIh[ػЛf$$N*on_3կaM?4F [붧e-3gM]i@s:V዗ɜ:Y̌VM#M~ U8j#g5wڅKX16K<K؉gAn|1;NxD$8!*2u kw#_ YXt=! ;=7\/22*(½g٫P(&Ggv4'3UI k4&] #0~f6q\LMAj.?Nq/P<~EH/FcX,-",}OOOv2yJ`,5#g4@wا o6U]ޟ#47as}2xlLlevfxgƾ ?N.D\{@>Uy|V^tJ-G􉐃Z ?2XqSdDg0vW&^JŮd*mURyഭB.Tk O/cZ$xuځv*$q8w <{$7endstream endobj 412 0 obj << /Filter /FlateDecode /Length 4624 >> stream x\Ys$G~z`g身`a^lƚV i N]Y=՚Y{!aK2+/_/~*Y~}Low翹@*I_\Tuypa;;]\>AqO VVЭ/گ\Զ¹Ų_lp=\ϪE^oW}񪣩C@?̌)vZ0Fw8K{0 FX#k ,R ?],5+B (pO8ݔ{1z4bkS y*cIoq Ju[DJz ;voaU*D~/[19\'8O'F)k4'K:LfboOt$kNc+fX:HJ%ZUԣ*1+2k"Ηƭ<) ibz)Y,I,GG#u͠)f3@,xlw<A7籉-E CpA 7㙤ZQʝ/5HH@:."JpYt`;#* huVVMl^A{BHr"DC7kZQ1ɧ1צCe^>Pr*f/'j5-3I6 L,|6hG؉EHR.dE X0Re&Qf.+.Ӗl-aе|}tub%mt .{y !vIOap*^{y}K7Ad? vjqhS[h{/c;[wboaqT 1(r6JBNDofR6Tpľ6<Ӑ}k`y&5^n2Iź-х|/}+_C$aQOЂU.*YX+ EDp#;VuSu$.:y r5)Fw/ڒᅽϛ?֋AImú4Ҽ*ػ6m(v@`t,է)T&R2U^a|hΫ"C]ZqlY9>k5(eos;ܣ-.A (OAR; %y.Jla>G؄2$Y $==+Aޓ0t>ָUh3Ͼ!<{+8JRU/h˘8j#% ue+t5 3mWicsj;+MizoD^=*`+fpC_-*Ti|zp7pRLhHB,M̉F̍@܅"2N! S^|DkL(hLYXhTWjɽyIR ̙V8AH@cK_>IGi U矅#3h(ꂮ_r0rA";σP]"$j~kвCkEo ߣ^BT]ÀM $e@e93ނEq6ȫ@bywō@+Va:I ) M oүkܽN3_SKqݤѣ(}ң{z/U7T3Q@l)=;RlIf@mRoFGf"')IkQߛɾ-3{-f&2^BƘ1`tjl,&l9Nh)"lyC(eCԳ.%7L Ӊ0ђC~qpny9$AB{&&y<Ⴜ+2*Kh+D" ő,9 6fbo+n&_4y=n), ޞO0bgӱbȶ#d _M,{_Op5+K(R$mJfQj4Q/.Q@0ϱA6[Pu WƚFā~юvkD@^U 5"d*WCO uyCm d#l-?ip (~vPpd .yMh!c"W *X >9ʉgވC5A,w-A?Uz|i A%((s|l}K3撫wMjT^*0 鄱όQEU 9;aΕ5NK,|C2 §.Lm` \YW3jԠf`WC78ЁˌyWe^w,{Uz6lvo "}ׄͱƊqs۰Ŀ4 K尬Ag`AܾI}&n:,k]ٟ KsU46FHg&nBAal䝤EetJS=5I*W|}sڛ6}4ulwM2@82>3Hy`-+lz Rg00OKuk2j H?VFB+j]*1 f#Ub$UD΋7mfyUh/^u 3qlo g: b^$"p쓮f2q؛&1Ｑ*Kwos)iBN<)ωX2z*}Fgq"q7էQsz=Y@B% ѡ3I:g$/>02p^ VxKU[e"$&G9W)ܱq`RWf) T;SrP'bץ4b Nت% [j|Kef&~婍|lܿi2=Fm4WS"hOiCxk-!RI7lZq+\V nfo /vV;R!Eb&hGkGo-"}]՛ئ9-~oKy=60ۮ|OX{E9FYIPxĞ oyZ o5|`Egcه|vRiiUpҔ|`OvEJ:.섌l!|:5RZVڙeMsbOmߺona+\ZX&Cז^4_W&}ӌZ#!xH D[(CQRA(bM4nX'M\u}/sZf|lF1vK|㧼鹊)圩^~׋֋-?EMAHuYzx 2lj x&)y'}TJK*;:6f(ϸgQ,[/7H:e^ύwWK+j [Ϣ$;dd7; )ٻ* nrJ|\ Ug.?(O> 8 K"},`6JC,ALt2^/st؉J]vTI?`ݗg>Vendstream endobj 413 0 obj << /Filter /FlateDecode /Length 18358 >> stream x}ێ%u{Q0`P~ 6L ` ACsf8rfdEZ{S]Emن zMȈ;C~ݛ5&=|o2=vŮ<_Oϧ]<ꙟZM/{[Se>~mO}뷽?T㇯z.=ս~9_ߗoSڸ>?9O _?Oɮ)ₖRlWz? ޠ`?{Y?~k+`ٍߥon~jcZŮXkzw~k=n-]iZ풽z]rq` @zc`sE4aKFc/gh4X21ciͤ7kpvqdڤw[)Yv]s]1ŷ t檛n~G^?m+}Jp3u % e0e@v P(}K[K W emL`b:b5[n11#2!% L\c/k;vll+{WCV!2qu}w@$f {YGpʙÍ1i%am:x Q쬱b5d` c˽l.^({x c[rx-ni f'p64`\U@t Ԅk&6g{LqB*´kwbfva0Qd6q_sbڶTöau Mdq{\}clw{XU8rCzD2oN\`)хCtL_ LOڄe{o hVd@rt&,&1A]@ WĐ^AO||Kvl ʴ²՚.{ſM+m{Itnk>*J"lR6%' KvQئJ,=J5M LУo.%3q-YuH61W 0 DCM ,iֈ O;5n b80$ljkiݳOa: %6F 0 YuHlm[@ 8wvGï5&@ Xft#פ@1 >B @AH3hxgobk:Hg:Z74ۇ.ːL񾎘Y0d?aVxvm6`jr!5ʼԂ5iE 7ݶbKܴ)فYxMжmt جD:א#l$ iy cK-B$~MSJ8h&-^F!.v\6S @6MYbj,9b)Hd_ lPSvC`J#).&k¶C ,o䌤ݕo*Fh6"ܚ@h#.8x9߮Y^9¢OT @:D"v<;XN¤*$0p]Sxq; xn+pOpͽ4\I so:wوtd 2ôWa֫ßS"p\Y|zdC257Dܙ_Gq^ë367V =X>C`#5tOmE8BGv0]HVT@J ?H1JO$ב2BJLr `JH2ߡ GFC<|IG$v>d;%契l)|W__Rv`j %#zo h"i悈Bae9'GXc4KU-Ȝ6k^*A&&MCY ̬}hmCٱf2yEHoWCWה S`IeygarŐ@Ud4؆:jh^6C^*B5(βUdDl,yz6)(Nb)_;`>P+*M> }0j;E͕XKXU'&wA*KJ6K9:9K6t -gfچBX#.STHj@@i}6=1)٘IMɸYT*$9 ^k  vSq&( R 0v8~"UVud& r szB 2qi66Aܘ~>#K5pq34Qي|k gП 8Y>[0R0ːoRq ܻFn,2IDqe9y~Meyr%+bpge22b xK|#䘡=BC:=$C^пEc:IHتn"+ C:UB5y*GKMxYv,@X9梧80N@ ÈR66l@{@XGӯy @U.'!1Ɛ~3iq<BFĵܿՓc&,5G`c'8绬t8gGD㜇l Q!tfl+'`fǷhsUIDFbO?TN`Fu0Qq%0&EK` 5{ebq"ͯ:%xkH@*%bq!% %[DtX 1c+2`UբW DZ(vC[b o> p;:Gf#,Aif|R00S&ֵr{XK,qq(V'n$ /KYp#џDh[E1C~=T3BK G jGi_ЧUYN@Y%I`-8m.8q(µ -$w_Q[ pZ:p@KţjėiY ڴUzK Mx7˱ C*Tϣm<2`0HC5&1-VrnbTx;=Cv@iM!&`I(%[ b'J(y C ӱP zUA!4=vDuROjgNƥ؀055 R*2a%R]lg쀴o-q[64Pf!i3&FBny'H^  IYo'U]ȦI%""rdOIP95S E\lG0DiՐ dvD6 }VA~ ,ˢ8 Y59*[iV do gG|Wl|gkV>痆/ï:,6 gVG lұ3cҳ30͏}u1y#a/c|BNzs;= OxT،nY5bjH\:&DG" 7Eb;9 8GYFO0I۔O~nKGF:; TvOb6J5 K/ƣb fv^@ zvZ@9dG B9VҠm>tRRp<6j 8i0PA [eU=܆4/(.Z'REeseb H, (2s|jߝeùKrZ sfL='ŀg ]l >4֤@ Ȣߩu 8嫻+NX*F!Ω[G|D `}}0`@h+`ȑ;s@d؛A"-Z!h<蓱]= PKnU߈6{@z1KmRw _i*X "ٖ!ql9&gC;*qwU1͙m;C:mCiud86qMN OL/ 8 nS9)G€?{%YAOFщ {Lw5y}4yi֊2#U\AaaʖX#haщ ^.̢tDk#85%Y-KDg=S &: ;VSkrV'uX#l !/M=,\AzYO?ELuŶbԌo8DX /BMpNMlѪ @w+#'*_"Vm}%G*Hi߸&\@o0?Iy󤺈J@_. !id]/1N q&'`dKE`x.S۱AA BR yC jbnsuLg[vDm[u)E_ A KN欈 T?Ы[^E(4\|sNo#Bb@ qbi& ir 𗢨ѐ%-I "IםgX[?- ? Z@.SHuAXO#fyTeS K67嘯l5GD {;+Œ"CDN!6PA[=Av4g\[g M1œ>MUQB\@ @:-jHm0f8A Sy`a &u2d˭CZRvN+W7b?.'B. +gzuOy:IýZa*hjQ Zj3ӵ[d1B3;)_Z ɞ.avXaE;S.;@H5 -XGwW"8j0Ѳ7d0B<F 5=ʐl08@|9ٞ>2BzwG?hSš{0aJ1¢Z씀yV"ڊRنt%pϢlN ~rEt *A)g6 Bn%`x9Q6ߨH @ %S8ue8^Ahf;.fi@V#ٚEd6Kb1@@ Y:,C(_$s6j.׈;6ܾLR̨"%qS|h;HAʪ'|+̎y_Aw]eE&0̼158N,SӽtP>Ǡt NDjG<: n">\V)8pDĝLG-axoA!V=PNDfБ[QӰےq~R:.C-m1]By <)c!kdiJxǣ;NBБ#!S= dJ͢<9"{L#uHVi.MxR@};hT3 #p|IN HV'ovvYD8hgJt8®N)"b@|1O:*bW8;+g ,g []j"LK tT,N֢h[dzĪ(Wmf.y a^w]ܫNWI^]).瑈,/wʚ.'$5r: K/H<N\y8?V`LG,RR=X-ze T>;i 32-:"~ۯ}lIDhpGɥqp54扩u>!" ;AJq1ZhZ£uP\F({9nEZ:B#Ϧ]s|D))C4)Ȇ n-zJ GZk @ A Ǚ],nPK}@;,yއ)o텈(w笕Z#P=z_2irݴ/uyq"xK4Nз8E0l8k![4NZ|ogF]dG+z3wwt&vxMJ5;LQFdxR>PZxQ:ۯ!ՋxiEߛ(fBMҾ{$pYS=Rwg^fv Af&3BaflFgl0"6*rz2Wt<w2OlMdU!u[d"0L3{7H] ROMvEY(ZVF, d9kW Z {IG=& dتZ(Q&nNyCdiſb?L;k'(z 5xA$NeB#b @w'%xCd: AAoѽALT+9aBu@> ?LX*{=p55ީqj"2kM}f\ LwBYdXS4mq LO :DS>ݩ,\Í(eVg aFxʲr *_ RT&y1SK#[4F 9GNҐts>85L89E91q9ǴI0| LOs77xTuU4c#“;kӎ\}@2ٮBKdRC sLMdt,:d=| DD\s C|)T[ƿ9U-#~cY$kwD)jtZ<Փ2Bp_' SjNKh֋Ȝ|:{V/jTDE ǔ@CsoG?}<6' ԓj" '/fM : EKMTET9LzV x'ʬK|` z:@O I J5%yߏM\N&.gSy#YB4x Rw,l<1Qk2Sp+].Zdsj+r4ŭ9l'gxv[Ov U%Yj'М)ﰥfH$9.5ܧ;,kzNR'|_8Q`4g (uԥ#JBΎ 8b[m#-+v D)8kx}p tחbN,OOIQcll;Uq`S'd.%4t1x]&|)oNd rk瘗ܕӥ|i<?; LV lpI 0_i[cW*% ,JO `s-@'c4STIs/Z%@Q`0]pxt *`1'ɪ8ɜp|a|6(T>Q NYZ^pw@gjwC[/ʣU%;M[ӯa zNw@G*hR3Sd$4a.$[yu] hFz3s ||\ N'}:N5ك85KlS!f$=9a0-+t `YO`'&\Tg5@{çg/`@_R1Gc/]Vtcwts?3(.z Mq~F wڀKW]~7bS0PPfW~&&{waDysk -ߒ^?cZ )&jr݈E[t>Nd+n̲_#@:5H~tN<)SW7[NN`t@:<\_,49o]_lʵ l'oWBl5r\,׭|[}9A0TǛ@QRl~>t㟲G88z)>|MhzV=rvZ6N4g|>rx7o\٧p3WqF/qf$L{"3U\9VS{[q@p}ooߔO:u%̪f~eW7䙿7o&=Ig.CDkp.0'ſoW8vn܍2sEzf%=oﲙxf?f< Hi$S{;%zou|nlpg]Ro佭IqyLAp^&Gk%[scR*{>~? zo\g8Zw}_a~&#߾C&v_EJg<͉[_Ol kMV0 UxHohfw(ӼwC2̟Vk_a5K^"6;a.a~?+}*Z oj#MIjX0`k;sa>{}gN撽Clv?NmQӲ6|W1ؤq<ϱ?{я '.2נg_bI;6OYa&>52?oۿ|=+%W;Iھ(ڎ䓀e>~gK6ݖ, #oKM5⾼ t˗FxMV^;:=v}~ն;|Ae;[\ͣd>p^mym U,*TȸTp'n W?R;чoȿY|cuj s??G&0 =Yȕ$Ad옺3NrNQnmo̟d6]'O7)s& ;^z/*M AWB{}!];k0T$G[v!jmXPVJ*n㙰%1hL6! Ǘ 1 D{܉)P(]7G::G%٬FɓMmTK' uC V^@.f&}6\[Lsxvu) ,s*#~jۮ`*]ލf)-_C GLw yޖY/*8? .?a cfmIw:€a#ǟ6>{hkޘqU#w4q;/k\3W/> 1gue5j[o(<rlr/(WCR `f:,$xkrvՐ09O<䏽,7;[lLxw+2o+>gsݨz j~1v|`X"[/1NN۷G9.ZedROrK/hnB]_~^4Ir.v#uQ p#W Bϋi76- *m0k]+P5g^׼SdsMmh$r嫬ӛگzWmqXS2%F E6?RM|+ER\nB<н^tP' .{7}_۝RxA^W 7P>^_}@#sM^)jIj,:26OYU6%6}<qMi]=^_3x15xVlu{0ms-8 ݁mDMeeg׬Pk(‹k܉ByQl _ޔ Cpf\@0~f!zeUw]i?vlyw7^I \狳fjgOAM}݋K.+bavx /n/<d[<^MYp),$g\_%* |@JJ6X{vw*W̝I8_Tg L _ў5{w/)d ^DyKNi`ʬT=z%gy[̏_I&qϲ^ PgߋMlRwb=ˏx6}6%ٷ_>0=)3WW0p_He]?,~؎wH1^3#2so2,Vg}{=5;-KܻpIF@&T8;WYxV].͌Zlx-Tj?z(oqoJ;{:l .Eܯ,tlԳ ښkJGJ#Wa裒eFpSWGWm|6ы`+1vnσ~.Gnj]0\aYߖ9q Tb.g~Y@̯f.pZ/n-xJu^}AmwrޭڟwtxMP%ktJt1 k6?Ezʾ>_(Zݤ.WY6e[4+DW@b'@sK/UY.ι|ᐆ(WYJB]?xowj,NdE }yq,wh },Muү;onqɇK,u/(-/ʟ5#󱞒!ٮ/^ ,6oDp'ma'Jz=;Zw=,NpC|SpY>|{~YȀECbb^b(y_]t}?݋w%Kymgp,~fq.F8̃=bK+R >ItW!dq,^/Rt3 } aknU.U;ٕaf*3ڑf.s׹4?&w VB.oY[XG)dn7\_ L#xPƻ 'ti]|4'}IOڤu? Ծq?/AEh_yA%n~s۟_|Y|q\yT]ԔB&/n ]ZQpExhf w8^xH]\6I/Rq :c<\MƇCxd_2ærߥwnQyeIwZcM(W7s)? ")4 Fe=_P'·t/{lplyn싫Rh>+%3n|y^CpO ^͍f[p> z_[\$eR,!}@k6g7a<"/u̮嶩vM)Lܗc='^N7"uz"|$I7<3xЂn=옉 TzJ|oxWs ؒ$׈E~'.Ol["6?@jw~_c_S|vLbwWe[HBȁwlNW?_w$@JJ~VE{ыy3}v?Kh]|33=wNiv'B_==yuce'߾C۪bDo_w7]L۟,_-c n˵?{iA)H7]39|3 /Orn'i؟Mg  6FSj 'c&4Z /^Hwyam^it+7xQ~T87|a\~=3R|6,3`Ns;M93V?<_߮̔k_ iendstream endobj 414 0 obj << /Filter /FlateDecode /Length 2583 >> stream xZKo#nj?gA1hv-h)}0tD)Z!Z$NE8ρ`uz0!?u(?ʺ*.\ JXM!@xWA[W*@usE魓dp&G[UQNB`d1}ѐU>&8mLxR@K }Ae.I^z&u[&duuY }vC0yga3Z R5w̃mDE]SD:?BVZmr G.cY9$:ڗ Qrh*_}ZlH'VOK#~3bu)HWJ 7%**9D(2u*pt.] [b׿fA^Nl/ h-carY0}TgRODh*뭨O ra) -Uw\6/裲2I1`b#t wh)9n& 259нOIxvz16EԹHe_RE!ǧsiS:tL]#LnXl3:LgR!Co7esh P0<x++e :% b+`NHA[侑e c[0_ ,P\x*e@ j+'D~0r~*ӀTj>*5)ᩰo6H䴬J8;/mP:~;dk LkAFPܙ(@ 8MbH7Kj[ 7*@<&/GSvt}K*i^x3Tٌ,vI󖆲f`􅉬/B!4,SV*B*>AF@~Trs٦# H>tu󪀖OY? bld,r+ ve/3:PcZ楹Xm:i'jw5;53MWb"c( +΢u̇w^>i2KU2]~a }ylӡ1Y73tP7' c׼Dq@E"=޴P/ph薣5Ԁ0%U];sp١E=0Y ~w2(Vtcܚ>؇ײD3| \/;Sv۠c'(ޠx b,3~ bĘ>.;?FOn. Gu3=.PFqEa}>K+]j)z_[IBu[сK|r 1dT9Sn7F4ldѣh'Oǁ#{k?C}J1#%t1cx,k|nyXA#G_QW=O>zo c%[hZ FMxN8(ԥ)Y'w4%OF);gg21.XsiiP|IG++0X̮H vú7ןwx: LwryOK` _ oWGkv_3{t'2=ͿyZi;p6[Kk֜=6Xֶ𵋔IPh+V$Yi#j/؈H6"D _<%ž=/+Y[viY$? :yKyIE ` Q\*a@lFdÆ*bf͊hBIqolF==H%} Y`It *߰E#Ƒ(a3=EMo )3>| ,f1((?&>W(.QPb5ד2qtcendstream endobj 415 0 obj << /Filter /FlateDecode /Length 4497 >> stream x\mo$G 6Гh:wrq:Hql%`H*7j =U,6Yak`KQb^H}X X _Wxڟ '"vY z08{wB g\YݜtjX!NZ wKz-Ki{giL/ejUڙ譅)Nj.~* K|[~1= &K%`V4c+ㄯ+U3g&dtR <ZKZR~#RU;]_%1j >xb/`پ{Z5. Ai`O;`> 3wAk-5TȄ>LxS~FvȒڊSqy쉢fFTv*e̖Ma{WJRRbLﭥ. he]/WfelЕ67@ , !2Q-jK n9j0*>^ewgD3uJ4t%m,!sbEY;_6^^ gR{WX˷pV lY&m0=nEa+Γ]b2῕`~ZH΂^:3=8b%To*4q\{>yz_&F4icȄ\ Pzۤ)0DI9 K Oh;ڐX30mh75n~|R|L}SzLd0ZTnItTC3 +fD1TQA'gBW!.?V)3:3ds[F_ yKS"B=mHbρ3 }5 X b8\p2~ҪV)5GE5V?Y"A-™Z8o r>,q ;x&l|$RY, 4HwU76#Sm*!Jk-8v+]$HjO)E@;rx-F^χ{(±˭6j"Rs<05ϜL/if<c6zKd4llьD#CI֩;]Qɹ"gobt£Fl c s),u_W#Ux-ߖ^!D ].|3ù2 :*9;XP`=wb@C/$X': }q@#R2$!R}^x)g#@8&Epȇm>ssE Kw@*W|14bhhॖuJkvONYcaBx6paӐF(7cGR~דDAd#(/Ol/HF1갔`NJ̐/N|BYf{iVYxAӘZ.fs9Η|el&>yAD쵬DG7җ.JW/DI/E{o~%djOi'P+#%16Gým푞S2';P>w.:mEk64{(9|dɷy SQ1V#;!D3 D zAj3<#JZ`go3`w@)+Q)2p7F!Mc[`]lbȟ"0tˣo~_(Mb| GDm1OSS%ǥ403C ˁkb a8+χhۦvT0nV*2ej)|̅#uq dsNkQuTNr7Xɜ4:U;nQ oPb@r&L"q!eKKaEI(oIѭØs^[;{,k͢+Gey,d7康1gt*.t/d|}}[4)7 x/`6^SN6^|c<-=[j/xoYNr1,aǧ#GcIBOM6UH*k<,\SѠAuٓ3]"E4vXqm,z`f/S8F1@)cz+-UtdOn@m95w[eto'7̐fyA.twU5`rU.#̻ zA1-+LZAb r\;W3 kf,F(/[La+uan4PCwVnC;]#Bטb"ؗ&)Iv]eI`֗$mxrى{[z1JNDE,US1P)~^4^rR<B|EH o `DOXXk(F<4Wj?->w\5c.Tg{YϚ oϟQqʟmbwͱ:|el&Xe'FlӜ"óMyŷl[gu fbrf~$Ʀ`PPPV87Mb혅yҴM/>EI;еҦBU~/W:|}z7b`;6euCb^T$ *i\c6z:"3>_==K3_;Bk`o_j[D`rfס$_H`e_ufd~~p!бZ`?Ƴ x`7>a7iYF5c;j4<%𥦷t8.8.W,~ú$}M_x91O9) qp0~d>FV'Dz9puU?|E1wb?vdQݱ?^gϩNGG|D^tQq5QS&vM[5h¿SP%ȗ1R?H!|o_endstream endobj 416 0 obj << /Filter /FlateDecode /Length 4602 >> stream x[ndGr_9?Qܒr_ږxjВnQ">-")i!;"ODȼǍFϿLaDm>Do7oOUh*釓WotH~}ӿn1xM;4Mv&jSs)钤:d46b'=ci0>O۝FmNև*cʹ@ۧ`x\b NnzC#LSR9kL-4l2\RE&;~kVhrLs#C9|[7^}F׆T;m\Ǘrrq4d1rۢ)e&g Ȝ~,&4I>vL CNƙOV8q'N?`7^c9my6aus𛻋67'b͏w@?ml&d#\Bf7(=cgH3hq$%))m|z$9MIώћShf9`}4KYC=xgE:β$E10G5$ 35fˑ6ء >,'O:)Ϝ`: i$I!IVi恡XEG%h Qd«`:ϒ4؎N$?;jϰ,t(#sU1:ÇH8p/aTtp,,u3K`AWu<`Bd/&TVb˒iuI C6tyS)$ѰaCmN ^HC\JatR'Æa) ߳r r_y59 ll k*mݧiV( 7UYBIVP4Dj#ZM"#v(MbWدHFkdyK U۝s'Mm4F08c&9$\u(˖\QBVY̐V,Z/Dj!jjGCZUi)D4vt,:;Qgl=FH&px` 8敓pPD$!eN(}fσ0o"Gԓ A5GB t Rlqo5vG 6wl LJۛmPʅ;2SLJo6k"+lş@:oEzyc 7_cx<z_2vRķ#D,9BN#m-TrftyىTvኳG9瀮AN|Цo'̼O<\2y#(tsœ@'VjT \RP%(>+AP Ll3zOD]XP!nD"b]\d.!4$˷/AX@)ym@Ykq3FK>@˱5|`pk$@%2b̸)-3!b2\uU:u|а x11SGøGA$I x4!i$.sa: ]sasajw| c Z ;"S%.c+%5GUCF@WKkQoUz7".*_5-pCVIUVm??} g31E̋'+%?OwT_22 ro,5drs*Ҿ}?^gПL %t4O2XU00Y¾@d^ gT·(}*g[aMPWy;9h^ĸ?nk)3AYO(' { QpڂHp'M栧H VBH44P5L+^kaШ ,P3D'0;{RXF:c]3nzwV|S) Xi߉[g\Z тeԽarޔċX^fXLARqiC%eWAqkAp~4ߖT}z,?6)Es<oWZ8~4FS\a^MqGs?w)*<[%{i*}X]õ{nk.:-;zeȽ=e. —گO#N7 9Z,tQͯUZKt͈SbՕBEˇ'k&VdȕU2]mbŲ^p7z:/tOmsA'l_v,Ꮦ7;gc,ZKR2#;qH<8nQŊuAaڔ5d"wjmU !Eb׷Λ1%jw</V\RzI, *QGk}G*}!dPF:'yjL ]wPjrY[N??SCHpI/J?oE9h`6Ӭ1E<}ST `]^si%|P(ggANݢTM{^62b8VMy© g۪\xz!V]w2fB>>ݣdMOKbm+:%*ov6~jUrau Ҫ/ M4 S4ieaca4_0puO[/n\/E-bsĸ77~kMV).Ws2/nGz4ѼMqKu)kvw`Z@gi. dp,:Ȏ7~34Nendstream endobj 417 0 obj << /Filter /FlateDecode /Length 5159 >> stream x[]s%q}g#n%sU8)vRq*=~.Wk:$jɕ.ԇ].p1 }`V{0WwyI7 =; ZM__ȣP!ǼV/./T;5xCϼj5XWGX\XO՛KZCz;ghf5ۅdS/Rr:ՠ[nC0&ְ|{=׏+2x,֚[NY@İ ^~scNe/(%9@ْk)q[vuK"Z]XZBZ  Ujjq@Ϲ:oxGp6&F .JmA[D0.ߜ[yJrx'T-egյR>}q2xj!ט>ڊûׇ/q9;/0|ͫ - D֥FR]M$ĭX!%O4k'Fc_VI~#2)3s>VbXj7&]cX5Ydpꌯs,Uц5j#S<,ۏ [ʷ%|6# lY/xI݀]h;% ;l:K!(PԀ]Inm%턵IJd<$y +TL?<~d9ٖaA(G7o~nk=G|9TT)S&bz_^ ߺxAꎽ`tDPxsc^(<:XbdąT SqȊ k_%pQ Y@ ֧W(@,BAHvo }sһU(@,BAR |I^P>B :[B#I/Q+2o)HzJKdIEʏ^Kɨt=z(] 4FAz䙣DINc(t (J(Q(t#F/QdAzxAz[kr.QJD/Qi ~)HzT(*(ԖK`fW-*{RdAZR(+g1B)к,@)HQض n+P*(gm@I4 di{ 0H)(P@@IU%Z%clJ@I ))PRI^ 3ʻ%e5@4ȱnZ/P8"ʖ*W`1-Na4X(h+rf X,嬃"kW  B"g%x~B\vZ޺1!J'/_mU4$vE%X'R R`lJE_hWnE);:} )QXvG_նjjL .v',@]qU+!tҮe 75Bb6J/_ ;}.Y"0@` w-8sQKPU99Y͛RTw>lٴJh}|<~N=vжyhiZ<6-gCq⺇*wdea$T}gЂt2r.Z0Ѱ;-SQwQsъmHsZ &C锋&Kg Nhr,D\4%)圻hJi#Gq|4tou'%OwRr IGXN@g|Y: @YNЃÚiA *8dTiu8q|L"uRM nl]xm:3~MkEM?t]NPv)\/|zCvQZ3F,}?], g[?ͦ& tjڱ{=p[/޼J/;zeEr1D$X~?އ7G~5U{~>Y!X<ȋ9WCZގޏp{V^M6jBG;C~؟Zvor/- |Iǯetv4/#b kʫkM_z9@Ghq ͻsc_Ht ܼף0u e~4љ)hoz5}NL~=I@C+Ѽ͗~4#Ș;%\v Za~ ߭Y+;H|R-`LV ܠ_^Wjߥk"=ҫ#ݤep3kH&RǺ[y\Zٍ ek]|m bFȕ(ԂZp?}-Ԍx]*_QMmtD姊9tUsbǾ1{=O$j[[h> ,q)pctu Ka;'N|TS%_*S Z'jJlɮPy@wg٤]Ѫ6tW)T<5R$w*{pY1Y~ęYqp!Omy }IpPle׮H%+N`9=upZF[R$'1^fq359WJLw?hS]dsC)$[_$I.j@ pD=~OVhUWMctÉPI> oO Ox:oܪtg ƇE-o apuŦ4]|9aWGDm${3S :g>vMgq޷$})ЇȥB:y飡")QT]MOYB[_W4&_6+eޔ.> Qy;Q%OQ.e\).B}g.HQbeGjwf* N{'R'BNyn/Qɼ8Yn4(fU:s/!lӱ/ÐhgwJd~&Dx.qjTU@PvsNYQΫ8o߶Sc~tIcܫޝ/G*U/┰cs]ܱ2̰ufMOkvxw׼oԿ:RK4aCfz͟oxi;v:]-LJJ-mCLStY/xUendstream endobj 418 0 obj << /Filter /FlateDecode /Length 8866 >> stream x]ْq}7t\վ!GؖDXR0Q̬ V#\ɪ]?|O[9=ȝ?#/=wɗv>jG 5COkw|R_] WxLϮc?&r?^]zq>x6p[-\/!3^~E-do9UV[=yt6B xk}nj=jsW_?oN()V/|]N;z!l)GX޿?7kRO/!)7ύ:$KCV˥) |/!V{q]\Ak i^JCJDahǎ$Kt O%`JI&J26-]BI2DױC"< $0otIl'yXE=\AУ-"};xR$P()`ªR:Jt6-Z"UQ5%PWKXB~ ٦W[Tz-"* %.ĈI L%t T2+`Kӷ.6ѫMBwP.=7J-h:$cc#RuebLY)pB5 XyvUQ&e~N`'}agm(XE%l g߲ $ٔܠ.UPmM5HH2̓N)Aq`1$>SDIzA}ܴ 6Mq*zV.\̯ VJ?>؛Lu ȞMpPHLWVmg*fH6($Tm*)4ѡ1>As04{{NSaA\8tf&Aϣ$>SU _:&"*SIUJ.OU)@&m 56g*BLE&V&`(RuиJz.t0 -a.A&e#)x52<$Ma*4eJ\6*"B%AK}bltbSiXF8 4SUKSdmZM8LCP 'FcFcpj0 E:LIEȘ6d(+q3Bbӂ3Eх ԕ چi0Ea4fV*#! 0XI%Qa`ÜvLŢo@i^L);]_"Z~4QB />Lqk9'pK@|!N7^Ňps![mLVHK!XX:YMjeVS2^ZMri5%K;^z/6ਭ"%BM"'2 A(oAq9mrE+u cD7BSkỘk#LFCkjmLkړ v ]_{2xk{nz$=F1me{lxD^Cԇ[ d)fn.duֻ`ā;,mlDg4f4b+ ۯ_>#H'!R ""0G 8t  } 0GA>hHr1j^`bGibҰcaL+ ì' 5\T`, 1FC %KQ2Hr9`VS!#^< @h Sv:HIrlHE UJˌQ@ ˈJE D & D$ae- F`(Kop0ul,D,O,dt $"0 G(%F(P/efB(Z͠`) ĝ}="b)0\RaCyC0w(y= 䞳UJ  qF7$qC"H!.*¬>qHD"ލ9:4", aӚ"Ĵ$T5 D< a"W XH$01 "ԗAJ@"%C"VHQm{ dYeِH +Adr@")H!AWlD DʣjlH`~_[^ܮ"Ӯ"o`":p"&P$ tEq8D]H`寬H(WD"<~E"̧ x4HZ#x>`O,N#hl@U}]H'?>ʜPFB`iJ2PR FŁDOPb J9'n\D+}PbĐ%HC"y+ ?CXq""h+$huu@EbP.[h,h,ۜ hU { J|Zq(8cS(8CeW6j J a gl0p%sglv3p%iجp:UРj4A 7OP8%Qil3FZe}ςV&~VRڬa+mjZR/19Ag1Z~,6#(Dt9hYSڇAYZ,Q O3XD:g1"sBs@,v (ԐRP"1/"~ H6PR1"eykbθ@bQMqcJhd(ᙕ,imJ8T9@Q9tcC_I?~*/>l<(ƅؠ/U L,6 FW4w LE0 3DBx4Xt$fH= ݃P∜d ԡ-Gʧ`ݶ38iU]ɉCS:$h$nlXԉ&&m!BUl k7;AHR-6ڦi}n^sVʤ$;MUxgT Ԃ~;%63 C9 uP*,!gc2Dn՘D%c q4#ZD5RR٤[T[1Ka_e(.mt U<*lKbMʓDOib׉7SCR8BnRnx $skڊb<ӅGUAQ˜&jZ,/6bn&AάxܩH|mQ턎|$q:\&|RǺP0[;ƍ+/@8^qnsh)G$)Ǩ'J}8LF0lӆX\Ð,If ZCJ}/cxF/:!FJwcKԲyYEc3<2lKZ\u)rjsjm#OZ[[d׊ۭ#ɮX؍h]+[jYcKŘuWmPr.&s?k}1Q1v=WqOrx4RvD#j>XN'Eq'ԓJمJ'xwP)ʤ]ڨYүɥ&Ly[K ٸTZK߸T %K%+hJ=IFX(6T陾eT r`R<[6N4IV1~(a ْQ:yT9'7' 8Q;yT`B9(Vu GfGyݺo)KJGGyxs*QNY>x$޶xT,DyT!YiTa4Jn;6J +:*QDƣC`Vʣ IwGD[x`(HMQpGAQ`MĮ"WWL !N dʘ`wƤ:`R= qֳQ)0:ȕR)AR*UXgJJ!4J ȣcRzE^2**ҤRVwT|R)A KXv\[F:9bA4T1 #Sڏb K:"2Օ,d53LP@ .BƮKuPZˠR+x%EFZ4T{RNT+hFzgPrrR=YdR,N*ŘȘT&IO&2s0)c &գN|ڣɤz,BLALi`R=LVBR=:-dM*Ցت1*Ń - *IڌQ6dR?lLK7n`R,Ę`Rw &Ց&ţ-U~'ܾ˻+)j( ijKa 1HKjIEmg‘҄# 78RrfGVcpG#< a#Hz0cOM+D($2$,L;D޹+$~Xt@<< i H1Hk~@^IHPWHB Ix IA$ab$<"U; _Z nLH,j@ HʨHlg^$}IVL^cbV K&C.e[! ӱƘI(5$&IPHsQń$zNHyE$< kiWhg gj;D|v!MDC]$Z-Ns$1Iкϓᾢ^-h4-:.h4"`\#BBy4m`x:; -A @YL)JJ0"VRٕcP0"AH@#=F l73;8RhQqA#BT4d @b?hA! 6R;_!W>@m[1{]!_@YGz}~ࢷ| S򚃆 Nư~pb? y~4}yŚs쮞׏|ܾ^ߢ 8B#:)x2782A@ex20֋An'2wyp-s QszlN]L&2lS= ;c.nR[W H盱i/L~}e~d~E}Mk:^Pn |! P ? i#7 /} bqkKi\U/ʬ;~ejbVpרC 7f`L]'x2(n~kQskk͖!oǧ[_na큚QPPcn_lor{\4#{2o=h#V9o?fd{pօ<ZҠ=A p[}=>;|m;ӭ6y,ϋm2ſ}:9}3'ypMO[=V@OW]X OX >c^)]Dgh> &~Z=rs~ET gd< ^.o$"Ek;}EO>]l7Xdne*7RjL?] M5_mo)#/]/ p|q8w#dɦ+}%j+޷{@ v(?ͽwhkz$g.=>Byj@k=yrCy_,/'͊Xt~h^4hM!'{wlzfhF!b%/m%X Dsں=-G:BjI ++dt_1V!m=K2h{9 % ?0C>\/tZ12S8tTWHeؓC;#2^Pnr١kޤ(r14}UuFȎ Vwv̥\icmjbږya53ɻ!NxZUpA?=cWwՠRUVď:z}$q͗f+(w|~|t[r{|}=4eýrԼxy\\ն(*ղ1A!Pwwž`֭QwF3wwKo7w[^#¥vyE|] UIDKR*j)~>ia[`ͿFxcƫK[ 7.T~;.C>yY*WC~^'qGJ7ȱf/?hpQꍸVzNws|u#ȟkN<U*\H'Z~B:t iEOmU昛ylWM.6nl{l~{ձ m]b*wCsf4f wg0wvH%EY׫IӮ nT, (4 yJvQGz䲲;`}k_"~ /a {lN'k^Z 1^8/oCg׻ F AvPe[#j)47aym Cc$Aa3D׮~כLK}&ѱzο]V1.]='XCᜌ+rqjdT*eoOxmy&ϧ@ջ,zj a۴V0Uu2kD4"ڜqND^ד%I!3/`v!gʕpd*zȞcwbg {f7 OMvZLwNįd},;mK*huӿY,eIov)[o.4)\n_oݼ?܅]EGɕԌ6=^HTUGV)kKjuu,y6ӯdgͳ>"?x^`Yŝ+(P.s_\W$ïF5!dC`[q.:}_6nKwK<=='6ֺ ̽=5^QKf!v,5,zM{\bkendstream endobj 419 0 obj << /Filter /FlateDecode /Length 4605 >> stream xnGCf #H~HÑil+\$&?c{kvf)9@`*j뮚! ?/ҙóvxvz8<`p3w!7n>ڮԇG/`qo7 bV;[DwVZם.RJﾏOо,®< NjFHѭOH cE 4w{VÆC:a`Xxַ ]:}(aas{k {mjp1`S4ylO~\8 Kp@ndSB݇Bf6ߤgb%x'op^⫗iN/A>HKiJ1uz װ!ǘV .(ϋNws;z;zgDPE`27pJ+/0cR|Z@Q b` h IޟpIB&i0YyO $lOOW4}{r]8I%AOh7MC!hHAҶ* #A+ xZnm@יɲLPzī acJoH|6GjNLޓJ i|.v/aqR8H08I{4)19WN@(=oMP)RzK>EHiVzK呤wfyZ^gmzo ۂ;NnV>n r&M C/ԠvGr$H+;N l%PjKqw6[գԈ鴟VuTTh$i;V16ZNrz x&yniwG6%P%oHh#ud4t.1T]cV S~#Aw)Ei\ !53}mHWEOސѰH7Y=9WH'U,tx2=yߙ=߸OW*WyJ*t|ֆIsSd_jT6st/Q6hJYWJO'tNixOQٞޓ̜Nw'tYGZI˫Y Uk%&=W5;5Mt7-C]_5XŇ-e4[=q­I^SX ӌhv&y A4D 3ov҇lŜ]ZD;p S  Kcle|/z$h8+WV{ TD}3)sUynGk4qc<@:q)/gy%8ūT  -b&sCitՃ o8DUѩ@OaD$C-\׀q1㠯d b*@E, 2X25-\Q>k ,@닢\e:z~Vh `(uYuϰvp7S%Ъ@p L*i*l'up>%ɂYN $ ]Hۄ-A6Jz`:H]S@h(1&U4[z&e8 )I>j">仟A`!o_uY‷)ঀJPU-?)CLOx} f>άi Wq1LÕHp}RQCк`o)q 0. z5 !wQ0s<8WOz vlLU0~AHU8%<.a6?<K|рS &| KDm}Pyi2"5pyx@>4=N nd:6޽$ъc?F3!F*\Ik,n Ѕzj3 xV@I<) 67Jc'VVWc8Fa:}>Ѿ-%`FzPTgVlrIǘ'84픔bԤv4ˍiLZp L07o xSM?/x[֡ڠ\Ӝ%>@y0l@̧eqd/&IH!.2 Fep)t )t)"|!E {2)(^'k:\9"좢i j(:/ ݐ'C|lFoc P䮀HNHڞkr]t[ I䛖(mHtOK@16rPZ.Tc%ٖUH 8.Hqz(5NJp`ɢA/^?2jJ Ph&+3F覎1ڎ.;ш-4v߶qdڏv.K$/ƽ%Eیԛb]3nNT&&h\dhn0/H@=|-8 G_}:"eG䊔ܐ_TΧ6)HCW^k"Wү˦Y,A4SirPRHON!on%N;`LBRU._Y#k6`hȄJ)߃\,]9P9u1to%PB=_@B]H$yUYuJTi"HQ:Qnj>La E^eI%t4.|jSѦݹdEvBq~S9O;3 Q(f#|MƴTA@UX+\^Y:]K dF]>h'+'*ocܐV|l\cܭ3'>R+J ӝI52z`nDFd~J[78T0[/t2:#? Nh~?%Ck *YIFe~:S9]I`HIv[U՟TL4;#g^lZalb6U;LY/Iv<>C1D+l67[s(4{#cGQcQzLj"o%WFE<Ѣ??$ =Z%#9Sߎϡҭ['l>GQガuOH.Ժk9`ߑǸ)+TgE/Yz-Zh> stream xXIo+E[QNmަH ^<8$Fb$Hw{8aTZ,|փyW\o hf1J * PY(҂-*[AbLķCT\0b FHUeB%4Pʋpƿ@N n#UDYub28.icC2"IoyԬx%QB4x+F֑Bމ^ʡ'2G#!TB(Cp$ve(I# hGx%de^<U&$՛F)@'J<*i( 4'eT$aWF]MC-[ x>b~(B#ci[zD|Qe!FR&:]ZT1~;VnU9הEl/j`1bd1N)礴MÏ2O[ &eU6;,-S5"06~ꪦ1e*yԖ6jᛑ{5@!V^[+*MT2^)):cʸ^1qgL}&3le4sG;#9#2%>$d}fdIzOde,̝fr}JCSliƦNM{ͯ S!;TS|zJXl.49"{^T%:QwH-9e%wG'oIqŨċL6IّL^H!|dSsUthY6 TmɮWÁqbUwB]H`]e+ddSL^ʚHKeGe˦(@&3 :R&( *cm~6) S/ʤ21fcv쿶pp@}эz*;Nf)]bY\eDH~HZ iQsc/pSZ:`Ҽ#d7t 4nxsq(# S(IAt;"VWwlf}y>]Xh0 HC7lolM>]|TME͂^*wimڣ\ /%>衁&ޒI4Wt|YȂ߁ Gi-PР9I(U|e%/X5N)bwE78jC1oIƎ~ql#;"Bzǂݳ_NKYH|߲5=S{ޚ6soOx f3+Yeό=o3ֻ|Ml MaM15bsc29{K{lw9wr׬gy>6e2%*^6z깰e_mX, Sw` ,w[I Z]Vر¤s&h r:ĵ3UՏTo<#Ê rYH?:ݹ/O5o8\k?W % %endstream endobj 421 0 obj << /Filter /FlateDecode /Length 41698 >> stream xIeKv6/T:"v kd{ x@H2!%AX>W ZAV{ڈݬWQ?珿(?gq"N9ǟ?Ǯ?XN~۟=>z_= ~_omocj%Ͽ˯8|9%|[U?Z*_]rV{L82N3_ :{9koZO e#?#-^g^g)گ]~A?=׺vz x[t ~ν޼?R&:KoOr?_po7K?-v[>˿y3W+kv~ ~},_{{~~ۏ~Q֏|_?ߣ1j? `=0 ҅_)$.!{'C:BίT cf$7rWsrHU1o$~EV:8u]g2,WW8տc~s~w:5|7}&pB*K[>Kx[.v,̻B9Ad֚܇D _z rX Dp,ϯᇺc@,&^5+u.{kvܺ|* }>>v"8踍jb׶*p}↘kȺ yDd_q_ Pk+tH\QCǽ2\a_p=>sO7_݈uʼn{{w_,~?7+@`l,#B| ˋ A6F׸rc@>'Ixz^(Z\MxwG?6pWh7Jve<$YNIVž%2(]j5zߥO ruM\V"% =!rܕ~X8Z"cibso9"^+Cf} l~0:DZ?s _䊶~ڳ"t_S?XIzh맜qj2﫼kڻ{+|Vk`"[,}+6sV"67Kf+#}]Ǻ ~0/"+ݽjbD4D&Esvhdn!ƊH]sc^پ=B`\ȞB,M-5џphpE.C"઺r{Od f mwwrp;܍fzm DŽ9C_n>աYMm׼H}Uf~u+ Hbyp[{#WP]MtT m,Zf ZVf*ȹ4;U^8W_ ~[B[%rfexQZA]/dSZ\0[fi1K;V*ωz4 շ6,SoW=F{%pp/>~HkK͚ȕb#|gb]>Nj V}&kG5z"0;$nPp"\w]C޻siX(>Kc1Jks+ sWydшdz{dŪ6]*Z&p&O¿ .o-}Zp}bՠ1=_ՐzZ@"ƛ侩cFZ:뚭-pq>}d~\% "a~PZk "V˞_W (PxBO[4/,ᯄ=6# [^LչI-Xr{K`O͇ z2@d2>ަYd9늬ގf dW|￰6??.232 >&Xo7_w E2k{dY>Y Țߗtn߷^|L<5 e'u\ֵO.Eؖ-ؓ .Z4:V\X{1YZKG#.sEͭ`aH?pX-e~MQu@U.MҪ{hZ_: 3 -ܹZe#KBkT 1|Mca5gBws UءWкF17ZZ4{"ZLmkBG s;'EPne,Z"rk\4eiu r*\MfU^5=$,~0W"3RK_l-kBpuԖWǮ6(bSwMWV]\5Z>]{"'Vc Še&yk ;ps=a/CZ |HU8 vIR64 lyV`n hge>WqV:?ɵ& w_ډڅ5J)0ڭa10aږ_yk m;Q@fM@{C倡KЧ򗢀uߢ8Z[n:sJ밎U?%.e&qd Б hruڃmbdAeF6ݖ~_`*C϶}wrߴ*o*W9^,ע i? 4e M2F'!ɬQCYr*ɠɜJiinMk MطW-hVvG @>1v =2"@4xP 6X[aF;SJM924߹)/Qa9u. b޺3HӍ4#BmfBC{u(0%{/.|ICJ,y8ҙ2ϵ;,fU>1c-9pe/:)&pm4ĻS g  [cNy)` ,P%]tTWN[Q Tͺk2U`7nʘ)GE7TAs?we] ,*]iã=,8 V]CJO*ȶ/'Pwz\?|mƹFh9oJe8\^  BWo\oGQu]sͻɀtL&gYGVՑ:y2#޾jL \|%.0`EutϯE>c%?,gʔ\gdCO~Ledd\ZT+-\DvBEY6@ yRKHh!"]4ݍu&B-<įL']d_Yȉc[d ]t?R9|o[ ۱q̀buMmyH)aq l)axȦĬ2 :j~fKtJƞNufBǪ_ 3,Hsk6 Q^(զ#RsBPqWZP9| wzUd5bFʳ.AS(jk݉;Ȣ޷]}.k<1v!+K!XC웻؏_c@3·@@PsC\Nh/@MS"y GJ" sX253i/3Չ-|! m\Ձܬl-\0ҋMD"L mL@Rn2TBHw;?@ȳ,Nv"ˑaKє _?oWd ma4Lί\L &rɽvb x; >N2˓pf"Kå{\q7<=v=rcb~4~4~,ӹk/W|OK X<͒(W@]d$ |rzŨ|ɵ;I*kwv=TYZKzDT,uAژ @$¬? 8%)ѣ}ܛ695bv !`kgwɬ9 ɬqrG!SFRb;ŭ!EvH _˔ u˹IlLlfPHo=r;DDfsEB4b6Fa>J5e,Yl9(cЯX.^kh@7;*"zG!TuW9T-HS!PZ" -sۣ|(k=H24Wd0{jeof\\^oR`t01tVeXZ@=]Z9.tڌe'mWv#t,s[;N%ZR2iVZe4i.d+BklPT6G%^;"nǿjOF: naΔYb/z,\d(B?^O@x=i~Ћ};;m"GN!ί"6} |~E})| '%G6_J y]w=r>gE9"-ɣ_/5&OE`Yx3YJ H/F"e93Er{IBtPH50R!6f ų ^kY;\[E>9(BģꠎIsLr3 j PnTJ0U*1:}bqfJWЭ'k!INf/pށoD @OaԈu"WL"9 C?3֊K: UJ9JҶ-`%s>eiӖǀS.'QXVv̓e4>)d/os$r⌈Hdǃ@IGoW`@I xum5}mmP:6 5 _l ̦/ d~2kUdzT}-|l[^ 0aMHdk:";]~%nTgDۢY22`-!*2D:9d$CnC~d+O}C&wLf?f/%MxT&P<Б~P(hy0@̈́F|-!o1nj.#@e\b0~6>VZ3߀+eܶwb(io1L5+RgGC1E,bkm1L/Lv;mYE,C(fD2$Ed wI׏aneXfvY3|xezHxel4"BO4"+m'Ax G٬@Xۧ;,[نI[Y@[̲3f|V?i[aVW8n}v,+3PK*`DhFGG dl])^Ŕmʯ*!/jlT%:e]JMT2\F$kۤ2zY]TF;K<#!&0!"(!hbݬKJ%f(1?)pW$G25N1Bʴ4=,&")G7)"N,mNq=S)uH%_Sf֙nǜ2W?5mS7|NrG)s6cP#̛&ɭg@s?uSgKMNu^"?qbHW 5a2 .iնhe^'p_[M|"/$|Dyd=C6$ui'%|ېGrG¼t+Z6:S8C=(c= bKaӎyemǼ2$V;1 ƹZ|j[fIwM,emHs3ˁ\.DřHM6>9s83mԮN{:4w6# =6"h(h41eXc". ܃^tTTc뱨w6d̪]zZ$&DjsQ&Qaړ$seL01*P,V;{ȪܬD0-.0&glUwǘ,sN|&,Ͷ~Kme'G-Ga}e=J,;6q]}{/ce}gD ݐfͰ;DJ6,=1yN{=-6}tБ;k3' rb"O#أ-(Px2k@*4y L}"D[psu#KPdBr%c"3xLBY3OtІ Ѕٶa{͋+)Mf0+6%^J9/UvLatw }cD]ZSd`CmID0+SP1^E*oæx,LSUfA9_(12x*L1Ϗ< ʘ4eDꧼ() @?y#ȷtivRY1c ϢAc\Gt45<',llCZ_Sm8Z5=頫^NO:@j&1=h!@Ϧ 8mn3hk璕5h|"% Էl(td*Hq\EOY&(2 t{.(ȑ! l"%f,K@қDCY)Jq~\vVMalR׍h{ҜT}XLdۢ,na1а[L=}T.SFK WoP7.39C i'䴃ȩdT:"O"ǝI>yϣO)vgOH-9`kO1EqP12{k(v*蛹<'FWsF+1H:wftkN;9SDi'f.8ĶhY34@f`j WGϠTh7.ꀜwp0}#lkI,o^ܔ)Gٹ8!QDov#t=pHr|ήfc%@.DEv/5d F*ɇ28!Mjvv2lf>FWc6o"KLMŇ7s;,ٓ/gZ\K~f EI,,ƔA丅^1Dž"3?yN@p<@pǎ B)["xXXl/(JcOR̩xU:=k"gɞ= Ky al)EW`Önjl'jN UF" ,IL~KUQ/ˣz0c.l3]e}<*`s?#9F_=˒a?AyJm쾥$uWMUj ;f(aw +ݙTU5("*k+wf;tSw' e2H.1,1UkJhͽO"{jw!>yңz؇$@6[܁R޾A۔99jYƫ4Tahv5QRQ"ȡ"5)h^SVvv Նh!QV>}MpQe"_Ib&šlls;hEm紷< )69&! dB(f˿C|O Y (Elďƶk.D 8&){YLϨ">'OTAU 0UJ@#y'^X QxVW"7Qնs&ԈhN'5fZ/H$0EIn {4ʞipeKɯqW$R6FbOn v$[wL5`L"™;L ~/o^%q{޴1q' ^MS0*555@-#uW*v~h*I;jPVVF ?⬀dK (SsO@T7h!Ui偪,Ո\jN|qYn*ğD3HeF'W'BV .kn-'qVW'J~̮Uxt]WfW_D,53li(~|`"PG|G#@ج-Nޱf&p]n43kkbj"`n̲G)\[ W,+l jJDpo Hd{q 5+ij.)55*PCv[QA{y%S$C1ps3`Z)ni^T;Zv`vhWKH[xy`4g&t jTvS[PKvPn{iluiK`KNC]]fmMg)x 'ָ޼k#rQk?vuvZ []Z{2m{:Ѩ6lO*F#4N٨[[aӞt)!".v"˘j6#L7!bWV)䄱oǃ+@LNKh&@4w'<壥`1)Ɏzcn"?Jeg'<;>1ꚏ&^Gm{I Ӱ1o׼'`Ը3(G2jFP >jMʿ$!+d"꜏yAT͊)q=w4f|y}Q:1Ig65D:ylH) |_Out 9'OWcRK T軒(nXQSqCR2ZQwFf>&<_am:ڮlK:! PHo)烉P-8 W㕿VlB2iO?bn8w* 9g;_y{: GK3/XO/ ٭AlkqD"̿I4"mv\mZrzNJ\7") lWγYhb<;I\Ry {f0GxوqcL(wxv)2F u㐀 m6uu;Cr~tt$CxUd^Dˆ2=KZ0K n~`sZPO/O0$rδPj5,2Z~%#ӉfqXKg`IͮsNE·G#呉[3擰GQGWT7Kʻ͙Ws.JTLKМ0A1jЗhHoRA{FzM 7Ma%Nx:+Y 'vuЫɶg"Mo D`U\d>,'t_x VF%iID丝cj )ն9D뜭镟5ebg{֙#]Ě' 'Q}Htwœ%hua)ܝ"{{`,1jt!7\R c=Vru~4f?iGtW5ӓDs f`4聰ɲBe9)|e}kyTBQ<yDG9*Q{3׵z ~ӧNvqJ$Qb ޽_"dJ(( _@>QCJ_Gl]W<^OˎP(gY1j/TsU5qտ w}> [e |A=OCP?x(zq_ Qv؟j]HFP07V6+s.;%tDoٚ6f 淁'ĵ/?2|W]0Xn&-~ ]`!>bmǸv[&i$Z"n/3%y}]ˏmpy m0$r8ӟ P-]@w%x,1},)#LM{w>**.?p/2"lۛ#pK^,'35#z{ 0.x*0D贬4AkY`rDp3" nf寖&-==A,#f0 Ki /G^}t8-f1*+ 3ܟcd T1SfV|cJb=5n2nTxM'q##G 7myG g]_q';[|ʃ.8k\#3'=8n~Tf먼R&:)ۣLLj9ٮLG@n;4BLpҵ#p{1]'lb5 xn9gV~Jc wmE 7(I`0MՋgg/fل;L:y*:Q!G WDY5"&q{;O:M(D4HVW$#%V۱9$}pKbFaFP`꫘uZ5&AȚ2/הz|&pUڿSk3c \t",HRr}TpҍԿ;XLb,JdWWN4 > woGR %ԋ)Gb}̰{1Fn]JL[<וI1 F 1 .ޯd |6"£xp7 ,G$:J`c1G7 ƨ4;@Xto⺓y~%GpvB)q3'{'tE7> 74U y'nw{fMJrj,IDԄnţGgpX*3[:9?uSc$-^Do3O)z%>h<;$&d" ^m#'3km L9֋'Hǣ$uVBbܨ^nR8fQM/&.SYP ,BE:N($;Ӊ:+Ov+>Z\|"2F6r]Y>'j${=G`hωIpl3=[-a$O쨙cr+FE}O5ͤSeF,m1ʪ3-:@Gʻ3ۤ~҇HF?M"m7A^&c&Fl<\^Gc^60hO_k='fzDNndf;jf;TRddQ2ir5갚jjV*z}GȦp[ɣbnSMmjjcOҕO%v?MȚo;Rު_WOj1ېĝ4yD^D+}JL'JLxǧl*I6w=Bd,cV>m:j> {:MY݇t 6$+{ЉU#bv . XU(kXvlpNa^|l䦖ȮzsL?4>+wa;J.j% ŮG *}ue10үC kd$&iz`#{Ք Q o=ښ~)d>Mאs'{\G|]"xo}@"2vm)^L޷|4`=mEnJ[lP\Ia46[Tg9"oI&ԤBxپ 1]Cd97hvJ*yQ\(Cg$;FnyId3+8O:4Qh#X'lY]v\Om>{l;MWBp "#Cw>F}6'vTͱwRN%IM @%/`=$=k go* iO[uVV]ȺDQ8L # q3ygwX $Ńv4ސiqַ"s<'ތXkbr}(}]341l޽ăhKӅt9 t/+q16fRb>19jnCM͡}X%>d݊<_0?ˁ9 )t9QWS!{a ,*qd_KPo4GS. E&66 KŦx69Vb\j1X:`{Q-P|i^ '( KUNRZm?,P17`7”.C3%>dz@V "FW]Y O&>:1V`Wվb=9 X2m,ϱO{X&BߘH}~V뫷怅w4!~6p'J_yTgX)>LvKy)U٦{'˜E}H_NA!(׬ĠθFװRA6LQWOszUֽNۉ.tXWH >ςɾ[c)CvY>C|:5I,0&FD8)л'M%j"+/43l3j Q|ؓG=u[z_}?!n_}ME>?xuc}uN3t@[L_xzr'i<_ oP[y6O?Z$>O Nm>OuBk2/Rz񂓺#B^(tCEc4"WbU!/3+w*h ґȂܮ>+&\!hE"R4W|+&Z\Cze!798;bH^l-qG9[xԐ&po wNS r!3'T\i۽2 ܅Q`7Z9@ZӏCSPg"=UUoM 1q*[ .qL[&i!]m8r x #8tDv:5C]r5BC;y!"⍼jE6,; CS9?Z41ANxQjخ<`BDU#|6\i-eh_xi!eηDmIx,:i@DD&fp t񨰮 `<,G\Ԇx8 N|5^(bWK f~1pa$n[ 728OW.5vU8?ۉy Ba#db ߠeА47^0opY,Vay4҃C>~4B5IY` k⛷DdDINydENH"py!L2DJ3!=sdC2DY)_' < :5;V5;VMaX~L N;D65u|FE 3Yf\ YD 㘘嫓 X8[߀O{|?$%"C kqx?P u$iN~$f˗C2TQ,zy~!Fmbk˂ u${ui8Gxthq|GǯL1!ӱrhUɯ}Jvʏٿ1ǥHǤZ >nhRf˱iT9bmz,5fɛ{8cPK< , f*dHݚS jprx^`2€U/iC,Ĉ *^cX%zF 2NF*?eC,'"@3 ?bLOtA˞' CK+飄d;I"zTBe}J̒s4n%[/@"Iԓ"Nq"(YG:D Ɓk}ȭɻlW"TW2daY1.61A V&ԥ4uQ_$$hkKP<{%uAEL ..zA!jW7 z$%(‡z *f0HAN-CZ ֳW]H󶛬 х' X~Ov '?82SP .i!DA7!N-6SMhy8װ͓HpiZ@}@lXhŧn/UW(F;~rDaL ?W{ʄ%{f*ŀ^\5F AIؐWb ~ +քNe[c$|⣲URMFb^›%Y6Kmc]&sf0O36qhp_5b9Ƙ-7uYk7,ys8$ƲQÿsX1n p-y/BI0 qdS"Ŝrg~6v晒Gm+q쎝|@o,V5@k&$E{C}0=؜|&3!;7zll^FTt ism0˜D|Enveɢy*63h6gʄ1vMgmI]YF#{wRˁ2"چh^e )~gh;a˄jM˽W؋7 DK&v" =JR[9VF, "+ xyNuՇh(}]U/ag3EIQwF߀@lAn/j^/sL{l\;Iw[-glTUJ]J18`ɂ=݄XMbRhe݆۠XKPtOq:R0(9Nz2d3@6_}pk%ty Sqf" S,3|G3c$hf14lJ4$#[Gy` '>1r)#_Drf~D9XrpIb&۲_DKgi ߋ -LRxzEk"k12a`.E}~/k;z"lD4v<M݊Zw#S|GIh{4Q/e~t ɘ }!23Xiǰ 4l_ dOq^ۍyQO:F@U }ɞVg5ោk]c_ :>s~8fpZѠAD ɨ.M%ј( ,ҍאu5@ocU'RJ >͒\.'BK.,uD`_Vo7ȦuFT\JZDUC<0QʏAJE1Ik_k_lrd5x#3޳ `2Re&0{r5Ga*ivF@طۉl}R4p \+@s+}թBE" 5f](}bPQۥݿ|EHŮcl U*Z;l]NQWpAS%!,I$}í,R@I\ NV6> =VZkU o;$$kRxA/9X-K2zN~Wi z'J~,T.q:~xRKyZS- JbH$z$ .4XV{$_h";uI2pJ3 䇸;N hs=8#| 3{iY^5 e;zA4x=d˭ n˝LEh[j -d_5FhDO\BM9l5iᦿUWBZfs[CIf`XAInIF*ЂU R]sc+ɛ H1MS}EF^F<hTw[".yl$xU$= EH^p:'bv)oG<1QxoX,\DzFq\vFQv1 ~{#u[C\M]Jǚ=T#Z֖QTYԺoTjVQX6\?"A²5 &<ݞBb{Og:6a|`WD'Tφ!eh%D ָ55; xHgN b@?ZcCƱprp$P _eq6kjҦ g3~z9_)pKhtۥe+aB%--!";?IVW,"GS ak7& 4cEJ?a"?I*򈳦 v@BɰoX7ܧjJ3E96$8iDչU:%Qehi@KO57VU m+db՜+`9-+s*{|iV?*z wO Mߴ@s!a?A#f;[V*3*شԺJHIZbullilR :ĺn,m-uR1 _ l u^Ӏa¾Ȍ( _0C@|_gџS3;Es*Y:KP;v:v?wQ;/Tޅ lo=HHn%7:ND=Kyưpߑ+Bvc."TR|.-{ʥ+Txe2=/[vUi!FbWؒ<|⸮\  !=nr='>+Ne_9fDI r`~lj;^鉣GMG+ete@{qpN fHSyn^׋z2-@AX)+)E.s*[y=W}sˋLz.yne,)Fy~r_]BoӠ$~Գ V`X!8^͒ۆGΦnΓͧe )@ e4ޜҦ_3$zI@ ɽ=Q)&vW]DY&i6L]K2.WΒ魱E0+v:p_fiz h&eGaOr Fc!hg\N#|C< l9a' E7 5[R@nx k4lę@ ֕  aDQQXA83J&29wԛeFaaIԑL(UPP|i൑p_VU b1z~t-VЋ풖A E&CUJ.,v0]?neleZmǿh;F?>#7x,:[Cһ=v>>ZA`fⶴUؒ9R$RPub@G/"#Ԫ>oVm3!Y2Ph=4~HAגF3? 7JhⵜsKDvy/@tZLeo娴N>]Q|([>Zs-Nܽ-G}{G?݈C˗=.w_c2|b}ɽ: :>>x|-G-JZ)4z?+ QЀJ̉,S3dQG(GURg фXg]@Tb]W޲8h[t7+¢f܀K>cS4rp%Ak7 xb9MzVK; ֏7|ݔ3wE 7- f6,>B nx,q"n ~= ^S 6]WrQ@u4_2ϝ9)Ίq~]w+A lNrGwfI&6r4l1¶ɝI}{IӝGǜZsX Ux5G7yNQoؿdnKv}wym帇b; =2C>(M:~Yvy,d N.Nq(8gV>FNr:S@ANqnՀ;˖i܎]igy 70nʇ!v_n׎7GHcYn H ng5/O~vyKJ* ngZ<3Q2NqÉ(½~TJqËx,;E3܏~&1:[lgq-U3܄kIgZ*O7q^>t}wI vȜ=yͤg@$fox͘MCN(AdF<}tcZS3^]"`[ ﱞ)X،0c3^Nk_Q* lÙ4ͱSu0R##*9OԵW[=[AHMMڟb_[l^Uݞ= fBzv cQq[YC-2)Jfg;@0iÆέlUDk..4D7K X߄JG`K}䪱BL~cTն{;KH/Zv>d?J;2ǏfՖ7ͷԍWWN汍wgho@%QEYh6eeB+v$_"]3-B'@=sn͡<+L-{e#dS?WeTi?TQ[c/ؓwIFZl[,ֶA.0$v- 6D}v#W>¬N]h!< *߼D-]sVOz@1[̴͠@wԥ ;Xů:XwO0T>oOp iAߝ4rwlM ]co C9m#q>X7?%,91"&L *r vNzIn=z^Xg-/eVKO$\d"lIf ;[ͱvD&ZW y9$vK`O9PI 8H7IKj1.{[b n*QMri)h! $j&҂խ.I2Ƃ5zIIN"Gy$F{_]j`hiXf>0@\o/&' wI [/@j962S1)/)ŚLdUqj-֕]yY,^b/#Ae[O˚"z2\&z28'- .2)t]a1N6X'"B1-~tRK~ ?4+ pQ'%N+pz0v$"}@PU9viI2#12Шj1%"9 >h-ғ` gpG߄/Gb-vz>"|i`9/P GNúղ2yiAWOs-nBgEr Ba3Xzm]9džBUuk^Imsis-6z?֓e,Nxsm^yV fC872{uKөW%WGDn ^`v)'R''3n6/洒KF9pB SK+$- vDţɭQ,:<|3OU_Lz=!yH/5{gne}Ꮌ=F+vGZؑ-"R7^Kչ?Hde_k~iϭ5U!iYo%CEsṆkJ MMS_J)thxZT4YbSli*H~*`Q N-JӌbH4Vb5t ݼ5E&*bdGUYY$ZaPnyL"׈\!/Cߜc#rPp wn%= ӈaiX^KҙZSv'7lɿ|j-3y-pXZe+,qZ^M`Ѯ 4',$"gOܲ,mn9yhےQդ?^xޞQ<JdKU U"* :0F]jH^kqV@#,)lI |mL6uT[ ,3$ڥVTj`sRkQ̢)?}bIJ@-V! rk^!lִyIa0шU(tHf$`<%T0ppmU<#PW^]V;-tزSxYQb]+4Pڸ\9fqd8X(02Y" J`iXg=h^!2ǡC~O .VsiOfbxx Hem'3а,D%T)+"G =~TU4r CD< Ċ$y^vbz-Z֮ Ր*NڭZ /?D%Ʊ3V2ȖT-WC[bŖ  `K,` 諥eY q,O#]@ XK-!nalZ?ղKEjY?=˴, u+ xx# r3lk7 td"fS4,8x9^PxJcS>H|Z~4ha.Q2-,Yls'yuK{cW u.kڐ{Faeҫ$iۆ}*ZM5KX,; -D(j=YrRG֓ȎpZair$"WXkYE< BQ upk'-S C5ϊ 6$ :/C I'N~ޔȯEjӟJ.Dݴ,İ ;E E9QRZ8!M`Hz46>$Ԧ: EiI й7JTδ)8=SCR 9l1Mu[h\JH5C_;,8ldElM` ̏)jZ<zL $9BZ|PZ'mSP)4eeU,SXY"FNUHr5YA2)Piٮ2y+QrVP;&u V<tP%˜"#Xm nE:`rԐ"\X–A9EA;Dwe Wnj`P)dX2#b.4%?%P4EA  hsDhbʷoe{,3ۇe8I<Ց/8 wnmr#J虲A9ʖQj\іTeQ>GqԷ'zϤB6ҴQJcy գ.l8*T~eQY,eQ]IQ|"l8 -:ʖQQ7RH!Z<,Ds,?d"JxCv0|_ϰ },¨灿[SHܘi )$/"C#הhq&X-1.c*칳RLaC:d)蟖,.-{56=̌nQ|<",|j13kfľy8+|R &NޣO${6JG\mV5lPxTvZ’O.sBF"k(+M(9HAЮҌm9XPbR< J}C#3CId*"i^TσDxz7@¹H\TեX<i٪ZݔSbZ)9r`7}_~-"_OkF<1Nbw=eԦ4p` gX@nֺ2JFE1A V$7kLb&%"[\TQ5omu#bFnkn{ 9C@kM "x!jCF;! %Bڹ9f,K# #MI0Et tٌ_a-z$ >V R!oPXgsc;@ĮT-f6x=$ szEF"+CDZd:` 8dfy;TѾ?y]oگ%|-c#^_ ꗣgd3Ab˳\>d ^wRJ%E$s2HGhy+S<(zNF[νS)^|Os!7mLVE厌P½r1_ 62qҪ{'P]23|h ~ڕ>0eAOȕЍa5Ba<ա:G4llZlVe⮮ZP;~Lmٙ?.7%*4چ"k]@DqAf:i@xG7"ܧ$^Q2;^ӌhfO1xnTi~CgyhV]SLUV6PBU1v+5z`C::;wLF_\/Hc/ǕN &C ٦[茴EEbQ>UdDx{ b%~'lSOHL|H.إU Dl@b$$kщ`)A`!3V(E$3vqáJ}(U(%OJ>V~yf!$K..8t34њAu+}B*#Ak͸鄸*^m~RI7>0 ѯ?+9 $~#[ y3O^9b0U15y x*898YR=g5VLy;JzbM]HBKLYdaY.d!XN>`Gs8Os6kL3FD}j]|BR$Mp%9@f 䫦#H-KI@"&VLD Ȃ1EܦM ' Qҹ/f fFOӋEe{Tv1:aͭl!qw~B ̽W' WXN6qγ&wT 1{hޏx4b~kR(EYB)>]ݘK+"_@]#4(/90,+A fx7]_o'9 E%wRu ƥr~KP&pUW QqkzraJCX fϸ~\9,ݯF CO#_ؼ{L ɓtqG.OPnMuM,FMk4 xpUsuye'9 Ң:fPċq2`L&\U!N ;SE4KU_2[b \e1Ցz !Fjd4ukfY{\44;0(sG ҆45kR*c䘨> BU(}١nLķWDFeDIK 9Ui$_ ⾯lX4tC-;;-h4thwܾx1˶dG9 {$)jU%TQ.'E,ӚVOf ?fp=GE:]%TjPrm"CTmeiY@e|*`04] ws꒴+I(#b=;:;xW h*gzmY pSVEFn X(FÊkd#{NR0WS 5rfV镒BsnFAXNQ}u0],PKrO)_B>=m$?jE;nG N'oʴYfp+oXE (ZVD?_2^PG/Jap~ꪳb%zJ}pOxoJ+D=!X'6R+!'|V'2ގaNy^')":5RKIX뼌S?vv"?M2r~?hW b_qWO'3O6 8R9P<]<)7^8Q}ɃQs$æ2|$gt-tsn^\ENs* ~_`efiA&1\ba 6K&\2 C5ɺ8mvIly9c?m?l͛%!UE 䞕zE5c HY+1鹙֦| Ty7Ϊ˪SLx}1-Oߓ"xJ]@.Y$S|*Q\! P fm(ZhEaC/#Jܓe"6It@NDTL8Q 6%LQeJςT9 UGG&H04<1R֚N2_-ryX=@mOU)Mًk$$Y0 SWewf*wo;1WO_+4ݯ,Ew4f-_q-φ^]O/tn^S,%TkRE.׋ }a$`iHLH>&2y7F'HGu՞ $y(J< 0~ch:_8DOBLQ:I; 竽<~<*-o~a7HZ>"ћ7'-G5۽oɛC^+~|{]Ű?KacaQbBI7콎–qLC3>DA|([>:'8dkHf:ޯY_,509*BD=OCxG(Q};L.$`y Zׯw(~]rփ[?~׽ͯ?o!q5pOW?j_ y;_=~9ﭶ ͷSݾo˔w{_;{3{?$(ĭ~ѹ'obۭa:l xXsǿ)X`}WhMV@p:'<78}lw> S|"JT~rcƆ>v1EË 4L=F~G]W)+f9dݱ}?uƷ#wzϼyMFn<+~o[?߷31V|6@W65ܻ.|~ y}q{$`NG}{?3"|SO ~hsݑ=8_> stream xnG#fvޏ@4MU`ldž-9D)OӖ-5 t!0JU=KML:,hUm!1{d>nc[҉NANpHyo2UAjS|,\d𬊀dxTu&FOã b0}#1km0|P N[n!)0$lu&b|O g0$o2xeq|,86Gp%'Ui*u4JJwAMje*9f(?J>xrM, ,6v'U"ANxU}aN{lUp8cS(\C[k — :TFU@ =$=/]5quȂtTZ-/ dq~Y0- T}Z]Y/y֩ ҪEn/\;Dq&P=ʠg)`b)GOe 6z;< iԛ!+\=bp@=|_8SU!TVZˠbcP˝(ElwK8$_ ~HLE.אNyW/=˷դ'JCy,L/ԾԽZH52df썕,dL p뺪*_vߗ?z%zfQKeW nCov\.K/wG (V}0x-VC(PG(9᜵+qfB)RoZGN=wC ՝]{*,vz\ꇶ>k)㊳pV"^`ִ*qZ1ZZ)˵3wlu^:)#cmLct2)ػ̎{~ϙP;^ 72n§bg'βb63mc -SlNWabMEpSxAaukIqb?> stream xZ[o&9}ϯS0i| i ݠ}݇L&n2 9ew۝dZƩTSv~ةYW=:W).#-ήv>V9w'ʷzC㜭ߝ\=9d7bh3YOc5ǜPJfhcZEYifaz f:=ا`ne\ Nnzƙ  t M&`+M)d?M%cc4)wGots%5VmH6v|E \)M䌁ɛCqQwCٜd0d}}GGO^MOv0u6sлt@z8Qu~I{7)2(d| x%zvw I–-$sIֳ0DOFJ<*f(mQ4~2b^$6 .9qx,j(qs&eB$4bM8 H""($fC'f0X; %{&$%nYNx1-%˨ӭkX*u(‹aGh1)Sz - _ -@X)=Ó^x ֓Y$jK98%!@'R5!PI|#4)BL\%!uG(dږr"C 0i1X6?I őA@ZGa3BZZ Ͳ!+Y܇^XXqKE8؋hF@b@$- ZQ-lEȋ=jDa'N8$/X J4y1p^<(.f/+;90 7 }ditŠy|B;lSvB}C")iI.ɲ!)FEJ bˋT$)c'BR̤EOR˦JHǦ˯QɉN9Y{IXHɉ=+Ӏ 4RVHNL1w"J8< 1qd$ŎMAҝVY!>v$deQXJTщQ<&XŠ-)a89!ŖȎ M%tێز񐟁sd<  7Q:R]?gtdRNe -6lȌrK,·NKrlEtϮ cIlthu$Ɔwe,l)sN]!xB5Ώ c/Bb*Q|DBuDJpڼ-}Z',Ha&SJʖ 1E$3&I27Rn&<Ι5U 5G(ŌЎ6 ,obը۪QzBWKi,jTAv-?Cx;,R:~E`oVNkEN H5^6:ՆNxŬX ?a]llM'se{(o**>N4ӷ8vis͋Pxf}kHac8˫w,蘌:~>jsL/p<8oe/xY"L]^Ym7ÅϾlY9M o }Wz'<:gOʯ{|lC|2T M~'>i1bMpn4ZraŇ5Mߌ;l~z,/a*ƄNJAd/'_eݣ]ڊ+ŋ~ZjY%CF>x-ot϶7UoiPE{xQ9+٦ MqI?[0 oL6m]_fc?~6XC\#:%^e!P MF[򄬮T: :12lŒ2PF:" >Vw ~1'd(XOOe7P턕K[)ħA[g?ݸ+8h2YΣ` v8upgaN' A <+zʯ[<~_s ͫxԶa=%  C؝v:޷<Aߴ,PzA׆c i'L "7ݟ~vTͽN.n qgC#y EZ/_$)T(+")PG yq֩#m<"g/?L!w)k):z0=X-V=C`&A\mVm{ 0gI zh؅,b]q#Zo]j%7:KxYZ 3Lz6~t ^j _Քr ]޴6<y:[YrWf}lip1Fwҭq1=؎!6MC"tx;tpwUԻg?=Օdoz#JI?SVy8~Ӝnؽ}(F_#O lhޏynWMnp.׺op8i޶U3,ӟ '6ھpl_Mg{F 1O}ŬaoA?-|jÿo6'3W^RzdڃyַmXAiyxK7X?0;ץY0ʺܟ~t@qцcդF&> stream x[[o\Z7Em_@ @h}dEk[wfCuir873PP @>? )"LQDyx }+ [?Fm.[E3lPE.Vk1qVz԰^0ZkYlvJ1u5))mpژ " B +>Ý#\ cp෰BKV1UZR(x8 v!FgVawQ}+jFj W<Uаl%,"cj>P Y7vڌ/!Q>j tr0(:Cyhm<\k;p),3&Yң~3:'Zf[(;`々AHOR%=4`:0IﮐF p*C&H\Q RB9 Y:NH=lHJ>Ftߤ1B͛6v/ÒR eRN`Leنxy mwf+>"6Œ&_Wp^ eUi7ή:Û:I>o#͆0F&"Bv4lEcB|ϣQɮ|OzYٵWګ5K0Hqnu{.}( .tamyz6;>viݡkh4k}r 8-QX⽇}~6LκLG+вK碠Ct][6v~JQ 4DZvl/349006KXгaQ^R$d;VLH/a2& :^^hc7W)1;d pĚDeG"匭nhzy+cJNxO B+|x;`$F(%$4țA\#g7BgC˄r:g9\#L!\bg6\ KG/eAccά,:bf1ر~h`!OqOC 6T>g$!J,:PUݛm2*N7%HF RdM[[s9oX]a>gm5 yro`1M^tUݛ&>ƌTktbD3Ej2mbg4F2M`LzP4!)˒.@~${m /9svzXҕA^:<:dH!N [ 1:n6vg_UJr4XdLGϵtȖhy^ϼYy${˜ދ<9bMZÕ˾r=uwxc")"@%3%=׳t\7šߦ z٭I;)yԁi,vd1Ua3c~kVݙ{oRLu Y>6tf囶^>+ wށ+-^No 1Dt]'wOx'O̝ţ{T U1I޾Ofِ'?zW;:\z29{c=e+DlS(nu7͇oц',, U_xn) 5{|Mn,n`dbȡS\^xZ @ l|V(X#Yej Hg->!V%J-%%!yٺ<Y0^>4e^Q1`f%iNpq_M>Mʆ"w@Q4aE`8kᢛW_G x}s\%ó 8xCgԭЂ߉l~GD|"?yv=D ]u01Iކ. /Fۤa@m,Xw =Xeجp ,09(I"6C#I$s:S L8Q?e (Wr6pݾ[uXHL6{߃_mS`&*[T4:' (%TK859j6iE-A(o#ǽϚ3;S^0-V-Kq( =%@N%nl9C\4;uX"w@\cvREڂ ,zQq椦:K@M2v,C`rfmWS,|k)܍w ,QHvŵp٩$<7̡sfj1)cQNt"d{dM}!^K$G=CTjhꐭ6tײbx53^o+{ʺ9XM4~; Cw˻?Hހ-xl=Ã.ŪPQR9^XdI{Rۇ ttl1@Nu'SwC.e{}汸Iot9ﰤu0[`|I~V~Ύ:I+$v@^~Ju6StpSI(v Rιțq*`s޶xm ,Q׸ J8neyQ~dՖ۴ˠ6UyK#>=|b@a3,Hχь,~q=21N em^w)h7EFf(ೳ;䰽~ J -$"jg\'uͪ 8 WI>RTM~/96ݏpnr )QLûeD`X;I[૚4p ?yU_j߆u&ܯ8,8ozjN Y,uGJ={gFk$HS#xv}ys&%P3%YNfl^yͲ{2J,#ߥ45H1-7A?& 0!FZqf祴&k,~.K(/P-IX:I,y]WTmxf){JETH͌k`+nuS%R67'זGy6]\yլDZk9eLKް~4Svӱл}^ݞŵz5sS!)3,Vp0=9:'/~aendstream endobj 425 0 obj << /Filter /FlateDecode /Length 32861 >> stream xK&Ir_l`_o[,FdZZdC)Os,"ެTާW~+_[߿{~K/5o~\S?~A5:}|_U% [gXo|yvO6}Wq5v?~xi}2VG_6zVO^pW7z:fe.o$Ée'9Y̾$J]~>U${Yj7_uJ]:'9履u꓌ ?E>ɜB"zr$<`Oڳ&r2$n dz$xRMJzO2^㫷0p5n?dwAIFU5~[WdWn} m9O2xn &'='1ĎY ;T'9RuK<χϺv{~v WEk.I40QzŽ$>REֳ}?=d^'Ch^O _ﳟ=3Mt FмV2>Izݾ͗aAfD͙laӯ9H#&OZl=9E쫰z ~Me`D&[f|&;Ÿd.0__dxO{ QMv~(>Ϝ r-}5_Uq͚doby ["ɵW Ǽ zװ];%wǽ +9.#1ֽ%x/yI uޤ}[IY\$[K=nw$9]DDz-N Ǣd>~~jp^1?q@xIv;Vݤl(jkV^"ZnBl7_'⵿JPIcKP*f4>t ]bMĭF`mpA&͛,k">xEe`#ё<$ƻd,7iӷt'trx.Ouzgs|t Y`I5UdqT;瓨Q. ғث9Yd[:ȶXZs8Q D*SDRĤ).2? =DsrspXKdU'*$>?;Ov[NKv ﳸjrb/ ctK@]E'{=uioSȘP`U̗$KB6H?""y/}Cѓ"O\l/Dz)#?ZG/JٔC[ M9Ӽ9!ca#D'%XVj޻IX2)ӗTITeVE0ĺ_KR7b]Usbt{NLCR72 3 lxI"Xo)v7=pDuV5]K/I.z-v'5 ƻ".ϛbm^`OrU,ٖ㓨ĨKoTmQn{bj=:Keh IrP]n} {h^d2䈿׬p_3ǘr2tt.%va9r@萁&ڋ拜RzgqraygކnNS\\DK^n"*4fOy+r{ _]7)RJ4i=HۄPZ#;$9_0-NR̝+! oA KP)zBzZu|R#Q)JPz?Ib*ny 3WH",;eNqopDI "z,oDb]5dyqf+;WL 3'[d.E:K-^Sd Poؐ˽ 6rE Im=SE@H"+Fz_7KtYE,@Qm"1VA:K~ׯx{s1axy",oA" bx=`L/rnS WH?RnIx 19}hW}^আIl>auW֡E{M?ZnEƻU/r/frq^}Z{w3fb=߲oW|q9_"(#М{TG=4"*uh& <}Rg6sqRv7g4'VwiœM~ηNЇ5IҳP]"k1=+.llZ{{,X+S299Z 4n7Ndc~-0_z.μpv8Y `ZRu}l,ՉޱEBU6_Na>틺"m ^S40#Qp2Ht>2W`(_4ᤲF%# Q,4Lj5% B-Ih4^D8ٴavi/RR.\CG8չ/R~> ygtVihU_>$G=,RUWpYi"k7x?6ۛg% -N·1⍭r@eȰW7\b6Z}, F\?ǶѾN,fKѾO,6 ߓѾG/hۿg=u$4&Ad{5/@.,(uF~B/pAdݯZ.dUlȸh r2h(~׶GzDE89\#~ /;ߧg5wH4dݗ4hO1+b) eqk=)YyRRHR]?UIvb,e`XSb.9"\dҺ}~"WAr_{54D/@w9y #tt]Nq.S]˨^î1l{' ( ,իH {]5GJN_1p- J`@ݳæcO`ҡ~x!09uq^:}\2$x{*"=!:?vRǍ P406b ޫ[hZ0D`vƏU"qMKn$0iS{JI$> 2t8Y"p;̥tdFxz>$,;9x `SHT% h66'(TYNTSK%. |Ԥ$tY4< ?Od'mi3NB"|adZ(Ie2k 5|/hQqMYaRiEFŗ;q= KC]U/\Iéw#kUWwϭ/f8pꪚ'Bs놼)8N8(@ ).YZzd ]`LY"IRlƵ'G|qBrV0'R3P{E;qx%o-)9u㽄ʂ#@s,CrBG?f]pԱ&Ղ#b"{@~ckExVpqM ^"8qM# r#_BKzËB#R.!6UNLv=H96klC*WX7:$l챶lxq|EⒹũׄsrmF7{hY4KnF7﻾lv{guIr@9ݦ+gMLWeeWrFD yá/#IT+pܾ7!*^2aps/X]9ТHucIxjU!NBÇAiR<Ѥx\$C_?;B{/~R60= C'; լPz4\H>i#{p8>ZJ ON?/R%FF)6[/]DOODH8AOtol `](K$ )2Ry{D)8 1r6%/=d)bA' @?Hu ѢApP>Rdx \nj $pcEDNtpM-(Q#k/'Z R |U;6X`6!&Bl77E!SUXmCQ(<= dzz!L>kayU$]]ѩ ޞv"1MY*[/=5g'h7D'<;Gol;LE 2k zXjjX8b LeclzDJQv l(1{eo;1A 5?'!}Oj1Ou1ٜΞؘ3 dQ(v̘MD,4B%!+v( Nzx{<Ɨ]/^T Gc*Ik)*<|KXFɩSfNwO٬}];=L2$J53۫6ɠɐ- F:,wu(gcMnnYFiu{#޹`2ק-_EKGXathD: ?eBTFS+Rp( Q`ԖS]hAB!o=Q^AZ$3+N±ԢcTm8ja9 $t=0 V˧Ac A\%jilj4|r|Zv&<ۧ lj.GAx\vPfe}nxvp}W˛buU@(vw8Rp @ʐ>:ɀӧĮB^,8]h@+MsKfǶ$/8 qZgp ]ς tUP!]@N%@,HׇlU rRki ; V7p ꣳԥpYQָkR =}shxq U\A(`q yE.Uъ$,]Nj~\CNLPp }9Qݣnu =pԮj19o ǐU-v-Tf8TL QhmIq!YnRk֚ GH%)h7dD5\CUYp YYt#cs ^g5}#Li Sdb~+|JE"״'Ȉ4.*Z\CmL f,-F=-a8ޚe50#Bŭ{DVuCjEږǺ Y \*`/E>ht LORQD1&A|-rZQ7ڌV fNXXWC ڹN;Ő;Ԡ6):6ALqՃ+4#=Ը0 u-v̠JU̲tr424y Ta`I\06DY;}DdmHylSj PJSX*ِ OEpFjWk:wd#kG2ktM{DPNXs'pUȣ9NA8BMR P(u5Ee_B^i ~WG gPv@YhKS\}K;9,8I'bBs ǘ61'%[X}h"(5j xe'DOgsP?a$U]>J58\5dwpռy=|g~B~꓅X3._ZY y&*3^Y:55NQ;:: rUA*4:a >gw8=Yz **tPb$6&nh,?,N9 dYT^/KÉs~AO-Gkfi'ݗ.pst/LBXC!j&ҟӭ50#Cw7_!df MEPJ]AjT"NfB&vT=GEX("6䒵I ōͽ(%I /T%A# .vʣKbxykceη.^mŷp{v`OpҸ(~~zƅ.>7ZT]ƭ!g! )yLxv .NGSfdHz^Y(R jNASy,N+CLH}s CtYfqa 1>MM \-]f9cPP t 6|ֹ?㖭-b&BM3# aH?@dCong֡7[P HnB4Aҕ6SUN 4nƩ]"J*rs ۦN>0$4si#3Ȃ8ڻ"J#- 98v3"@᠃nIv]T̗*SlFgZy\$|[$+=Ba+V@v]JRpDz6n,r9 ʒŭ$9M0AZZuW &qq/9t*NW{cEH77tcrWșf"IN_EDvߦw؊ϡgUz0UXy(M$1 ߌ! gK~T'QM| /hG73Vי͌14&|3qnR[Zby͌R~ ߌqgMXmO1Z(W^s}'Wg&.@cC{D⾻uD*PXpD|$qSB.Q'>6cfB{łc&ݷ&_/eNiWebpBe ~$QJ0;#[nMRz`*l1s;f"`\`.Dj55GHO]Z[2^]D|h#y/ FbCCc>4$\aڞg&J[mrQ(xf֭s&sM6\3FW]3~Tl7MSY' ;=w6nb'Ye'NPi\jfWU }#fM|ZyI_-&GyI`^i}K :ob2fwZ~,uws XeȾrֲaֳ-' ykkrѵqBC`#pFɞT6M6[u,n5PdY[4n pb{VRD0v}(8`, j5k4 NP[/B;o=NT z : K|%Wޱ},(jkPH ' ]+pBNC3o/sӝrhnf^'N@Z(SVhuOa\0ɱ*K1Gcn+^3% &N}lO9bE I8TvMKơk$ݵү0b 8a84g;7ښg[Q~N)kbpE3C Y*.bB" -?b5oAIɥ|((l]MS$YDvŴ]$ )Dd/ލfMQ Q1E:)yޔ.SDXsCM [d6cM&#''MA 3dk{£2Lf86ޠG>4J!yn/8bw^+ z~ZS$1i> ;e2nI8UfF/E an2kQ ZN>v i]깊$`~̉t:A~+A?΋6Yfc/;{KsHapo.4wx ^`m{uu9RK.oC$Jix7$ 0Q. '(sӝDA<Akyg1ʊbzA 59Fv'Z%y,|mv 'n5L"Aq0G:q9|?H}8sLA;6\aM gxxtM8p)-%,h nɲDNv1zdƖ7W'~QrlakPgvb >WŃ!}klxa Mw >-rHrjKr qƏ5$@g 'SSTG~2Rr$s(ExRuɥ 1I$ԥŢ3zi:̽qQ ^2װ NIA O̽>V`UW!JY =/ Sխ@:ES1sk&3wNV3 1È8.֠ͭ!b9ZC1s|e3b L' |ciiq{DZYh«*']V*^4;'6&A'UӉJ>]}KaxA4%;=Ji*÷ LyfVvgIBM`p^>,%7$ӗ^. aYj1x@7%@ Ě#W.YdW3x֞Iәl3![ޛ@tȺ}otd|h ˶Ⱥca˺$6ݦu T(>QW~^Ye}A2DQ;,Yateޕ ^LtNeS"vڗitH]$:Kگ)(t`UwKsm7}N6} zcvI83KiMD?+K}V*TyKq6.Bz΍%1\-KʞcЋ" ws{ HmY훀.cQvަs1dM" lnk$4CI0'Q*RS $Z,Ui6PH[&qFU'^rEa d4Qӷz x+Bb`@ͱZDY4;$,n|gщ9A;1nyM CA+"1VR0ơ|@s `dѐfu@Y6$UYn&eSrwL>@ ]hQhaxLxs,([aNb{V s+?b& FGC&hȴy>Ė%U8_`mә; G\!ȾN"^TocWQR7E|Ql5Fqia$1360'f_zcW=$ %N$6{M8Rl&KomKB΍vHVfeŠ¨'qZhአ)SrdcCj/;Z#S'wj3 'Rțc^zY;PJm ';R lw^NBɗq')ɤW5pvy8Qzs~s/쵝'u^δ/NTZ# ñfOViz.ێR/GnGŶ%U.$_v35?&$=gkLJ6R}{CkAs^DftS>ZOѕ?v7e$p3e#̑|dwɗ;vV8˙2I[{j=0zh 捈OQIV ~l"B/]y%0X~"Хa7*967w8۴oPNΛ[92B z aq?5mw2^xD=4MV K _2h7oɠ=W@5p\!Ϟ&C*rȶNd7>'9re܏5Ϳ@X"kIE'fϡDxIKIaޓkzb&d24>πusr0^NiMgDh1tX$C༶Nnnp2lDnκNUVCh1RχOr H21f\(˗dU Y7NTJY7A ,|PhMo^ E؉J#rFНiNN˱,>k~?qL`~{8#.FBî99JVEI}iMoĀ.FxdIcttC%KѮވ]>< ,5hMN ͠iĄpE LyttWs[DŁqw,3(" &x" MFANp wL A$3p0+ԀI$DU5>w.%55WnrthkQeс2ܘZ{pcnns= FaXcrcvɍG if+o`CMH֜&7*EMj„ܘ L11Ƨ@\crcɟ!dpҘܕ{k6 /MsdVQ~B0}YlK_^IһߴQ@ ʀ;Y,r5MuGL#xi>*VV-'8@B= ߄L H88P ʘ~c1oji2\pEp]̛C mu3olL]c!R=D :bxEr.98[\gI!z$oj`3Fd*Hĩ8 UMQ|,q @)S9C8mXt#cvNs &ă$68a$n;s#|!g'c캊ӵ9k"}?y抜M'ꍥU"Y6 N#i' n=J1Ę=gäY0D֦$JWY,?#=6Uvn["Qfk׀GQ7@p98nu#4 9xXFΦk"4r6P9p ̵7xG&i'G&OG&V n<ě5q>F&7莾?59qb&]gk}ٚ,݁EwfΥ}`N65Q@{ 80V&cN4‰uWQD-v';1m7F]Ls'D)QWUls9; +[n Ŏ^ذ2ωӻ + y"ŗpz'Dlp ޝ rIĺUfVU [t'1rO8P=H$E?rnn"ңeac]L:1yUqfƦG)W)[ ABШٸ?:2d\g@N6д Ʉ/ @+g&'M̥̯7摱\Os{tO ~yFAE>h)ǟ>+wLR2eݛEٱ?+S&M'@mBp Îdb'|ؕ]6h|MNTj(%fg!> " dVR7x"|\7y>6d|#Ubf  U0 9r`AVfW!T >zݗ{E79y ; v<‰Ν*btED8Xt'O7a7]0b*HpQE- fI88ɠ%9ΤRyî߇'KP>)Nq̍8yD0F0"HS3Q8+uoqμb+p:tv& J% Թ*܀zx8#)F<1Dl4*܁%:mwvIQH ?" Q ܄u*( ܄QoNPJnW&=v& b'8JBaN37Jk (MG1p4:A)Jb=q1Np,DV?<B[VeV$3ŪoX3'( *HKGG,X#U 7;r?'u0yj6j<[61':уvkNr,.q^yɃ$N~k vxp'qUW]5?۷/uGֿZo56]~oY71[~O^-T#$#[|;WYϋ̏䅼HuQd|^y\E%)o~l?z;Ԙ6\۠N=v׵W}qw9q=~/bX ]O-Rc@\%)=GA\;.઒ן~/?F<%\?Q4/9f@ZHuȺ{đ8~{6OIM z)97OO^dCHHg='ߤp8M>A6凪}~H|‹`JU g~yz] w *#]uDm#YG%_H|;f?/{^&7QwĒ7MT mvM$dp1F`gD-2nRONݿ<hɿK~W՟5HL.3ߛԟ/vF_/ofMxM'D'9/h/wR'iITIl;0_ndDN)hρ?WtZHǂժ'J8V_ Z91޹WOy'?نtٿ@ /{0&'AmXI;ۭ:m|B6˓{Αz?"g.kЋTޤr\H?"ޥbW'y=:ߠ'Hzgu:XW9)8>^x->I}ǟNIX58~~NVi93 lFF? 1\=!eC[IɿK nwo&k!Dz/Eux N"w5]x ߀'C]Ԭw֬_s뫎@@_prǤ1Z 3H^d&r`{R}uA~od뚣9V(-Oi>$'֡g]^G^eLC~ܧr1|'8ȋD8]>~f=!/O5t0Xfڰ."u'I #2Ş)]OSDOo'y*'fdADe#ߏ[jc 5IX bd$xc_ {ާ.ݧ>z!V*7*7s_CQ!Ӿ,UgJm)nӑqC#cC%S|/5PqH[\y-:ד K&]qlޤbZY$U~*֫mڞdG ;蟠g/D=ag]ՉמN4:A3Gh>AQHl2e;9Fȗ3=48霢r>Lq<0BڃĄ3FwbLzOAN@)3R;?}9A=ܕ܏ -;oxKGEb{Y.:~,L7 c9Y 2g DQȷ( g/8kʰ^$|6 bzU_ 8/艋Uu B~WN=pݵW`ߔ,[мլk.n8SFNxv5OZγ;: %J}xA5#@c·{ liqwK:`E{qOTV^MČ}m";&{r1< 8WާA /-2N Qz6iUG'Ofn|RiIiLƥ3"CKmSPۭ;jM%Y/x+}dJQ9u.N)]RKPk]q-[^S)$Pt. WUGV';r, t}gCyr(S* N9pWK XGqNs%+t5O1E! WSYLd;oL͐gyopKC^]VDŐ:0{iVƼrY^Y- ;`mAht0mzo/iơ9&vnMci'M')ږb%~?mرk6 bQNy&C ']noB퇖k^[&S~QRM*Y` p<ݶe/XXwL9mGW)~w~Ö~sBu'ԦGy ^dB7^h\Ӱ"xv,½}I0>-ګ.iY8cs7iɃ.;&'BTR1enR(GK O꠮i 것*}!7 QR'}J+5>% Gr}I 4|<[kD2Hj)@@+2H2ݮ5P$4kiK;d=//mF6Yde& f#+_4ls/{HcSmI+g:RVWk+%OcGmi42X- Vy瑽FU`P@TҬKIVm?5ku1V\m`ZOɢbgf<}6NF:o!T)P%}ԤY }x=;b nN L87U#oDgcbͶW7[U4[TާQ&t\)xAV); CBB*jC#-yވ(y7H&9+~\ *o$Jy`Dr'_h ]QDZgWbq0 q_ z#J_8+V j8I]YsvOog$,59] /"գN]}4]X kVւ*f feSaBAsUǸ#tt0 AqrznT쵈 z~Qnj!hHA¦P (1Ǹǰ8h)H22O̥H)Gg~jL%mxO pOg{I"=]ZHEHYɊɗ ƒSx7 ' OyW' /9CߨLt2i2)U clH<8a0nz6<'EN=DG}m="2~iZݘķOY[\bL[gw4YPd8a| fw}{45oa%' rwb]i$kԋ`_V6!㈻GP&Ld3L'ӷx!o' G_0x-3_0F3>>mz6 F)fWG= wd]UguHlousxr[_Ch1y6YXEUKq!w 8M4~k2-SMO ҨOrQGѺ˧2hR"7(ufުS,Qɇ9bR 1Ȩ'*+@Eb <l5 -rA OSsj=Drp.L޴W橷$)UNG^6/OM`34iE)~\D[Y`]]!\wo&S칔8UX(qL{qJ._#=»qԑPUqFfJ_j䙲GNdw eX=s$(ڗvϝ6À#<%}$Bڔ@8C;>Z7xt h_X($+ș0{:#l=jք0A]W9 3!V1jC#i.Xeyvl; ^*HAi>gu(pHq:W#g+JyTFaz.wN$8ڸiȵ׮G[4cZdu"po}!@o~RZn@偕Y~2EkVȩ^=uvmFg*5賟]w5Ck3:_f*TF/ːV>*'Qq*Р]6gE`T|.Bɫљ  |~J6;܁%_]ةnMƯ AnMYP0^sF/P ⚧]c~O1 ,[6búlCn08p{1M4_SPmtp5iᘙָ"^S]E_c)cm8nͅpG(s% ԕqna;ϕ?pĹb=lWI֘*/lxqMiC*.}d\Va$i*fOPv=$I%=7DE_ 5/b?*7?Պ6&+UZ:'ܖ_%覗L[tcLarx/L5q2a}R]?- `Q;7p2 ɌVXAa.q7l(mt3( O6rje EnLj!Ǖ<dSi)}x6xOlx mD|n sɐH}p'7P";,37`AGHI̜PvNhu/ qwx[@~O"}8b"U2hEA"(g;38 Y"a:$cpS[uXՈOFg Bni8=͉qߘd,m;.Ѹu `~ތܯ;p"cOV0RD_fe+It= zSJ̔$l?gQr 2dUNezj5Cʦʘl4EL*vNʎ%.Xܖ534u*wqz9WR]{s{FQ9-tSD&9$53*N8'9O1pj`΅Csatӯ;pv@lMURa}m8ax ל 8-c*9'TTk V`X؁_[{rޞMun_~ؿ16}H/wKS+-F~h0~LsjKS~cS|X,6P4` ߄edWSq? RHQfE,|:x5N; ۸  3v$I3,kVZ0$/CbG$RaX'D( zNT1 {k.Q,^0i(a4Xf:M@B #;b2S-'l[8q<ܞVW,3qRkՕg ^eFDx$T,W^tC- *H0v=8هr,n!!)09ϴ%#]۟9oےOXTᄭ/ssd)1bqOnnuqިo q΅2X['N)T\=팻6 @E78"4׌#YiۍuL+OH_{ײkIrUOA5~0 ѶbsYǢZe9I,ɷ|RVc'6[z`7^,KF^NV|w<@m& fw5AZuFݺ,},.l7@E-jPF\U륞EVUVe6:]Nf-ފ >56\Ækr-tufw+8YX = z? \5U&u+Jg*'1۷&7e/ݼ-=>vyj&pO}Gxq˖r{E˖6u̸6G.K:#0ah"0 x"Lq@L1 9216kul$\Y^*J5>y!ELΤB"L[ 0D4c}FB0@ !:E>BѯDsCP?;UtBPQ8^芢,gAtPHazoIՉU\?d^1;ԐkOpK*0*(s,`_ ]7 ? V86fKtoYRY+E\nwEǡFO$Ixm|랟c&SjmymClcb\t> dzpjCflwaʚ9IliF.)`ܶMNM[(lߕ *VuI4{ ]k',=hllf Yjs6aҜ*p?_7GK|#iޜC Ȇi"eӓe !`J:H%-NeЈMc*(Zp@C"" Z#h$6:UJv$XŽs܄p ]4UI٩mvۊ Z-ۀSƪD-L*h5ytN%?P42w M?mH\BW޵\LL$$;Ɛ/k]ZZ|cE1}8I~6?j󀉂hw]xEH#Sm`.uOQj'1o ^wpѰ}Ue~Tj-#N#fj8S|{)i66Q (tA0$]Q ,p,#[$ Q.ED#$r8\1+"/u/[Xq ^) QωSi?L QHq(? (ND`P|O\1#>|WDh5H.'>X >L/qHq:Og o'Ix PV" Tp+Bᒊx.x Bх5 ;qE(D*L.+uMD`Ź&8 qCs5NihK*'"RBqWR؆R4BڪF4kyCNE*(=1~ W OSa.]앱ʓ(,wQX4?g"#}ǔQn2qYݢH.7CFV1# D9zE’Phy`!ɸ;#& q$>8"ZGȃ&5CrAz!ji2u(4I OR^%[;V[K^26uv%_HywmzU/ @ҧZtBXw hCr +VBv>=Ztes0|Xo3  encL&Id@i5&akcXb6NtmrK fp'7/wPsъ&ߙPm\}겚}Σ Xȝp1ʗ,0(hk%cznL.QL(v0a6vs皖kP$`‡68ifVUF |*AXT(AAiD(MPAъIٵ=TrUzf#C 9 )R!]o. pwj07`)3 BUBЖqmiZm0Z L6 ( Lk6g* @Ѐe lPHQA6_[gkfI7/jESF]ٸnc!cK(Ƨ^q=̋CGL> 8味0((7&OOlaO[ F8j0ɍ41ܵ$k6̦J[;W:ѪM) **ZA[udG5VLT%ҽ(:1|)+6LSb5tS,n y|J0E~ń.BGYxb PnvE7㬎r%x kH}x`-O \ 7eQ~F8nC~y|xEtSF]qiGф31f{tr <=21Ch$@0Q<;/]~ G*~C.3袣\s J .'_kdsCY;wj!M 0l'66,k|u|M[w#b+Vzz[T6sVB$9{A-LqBe12}UxX>?ǖ)aERdz)$S\{oՕLe@*ah,T&[8ΨW_}/<^2E@v@pǗSb0 w! }Kϣx ,~~"p .~ SRZO\8Rs `z5O¿>LeuU"$z/ }Q;np ?sܢ圸EH/nw_`#|leRT4З[OnA[TCk$OӔ.ZA[2g@zg')i(jUt]vAE xC1, pnPY tk,i+1}&/(M^͡?=ҫ`kFߢ9XF%lbPb ПP}缸C)ER }quEEC@U];f &YCaFYC5(Nk(<7k(yݬ 6 g.sNo(܅7c"|`Ewo(UҖI]PhLh5v^u3c RBU1y6V:Ց9rh.<n)v:4AFMJQ괅TPf Zz_[jj'bQ J (qU50bR 8e1Ij9(ɛֶ"(`f1*}51_ɼ&!$Ҧ=mX`Pv|V+P$ Ma -K+] YFVs cn?EDYkBAqBy}7_([|ZB!/>tr" ٲ3< Ԃ[K[wԂHzGVuЂwN/Vi %K 8Xn_ԔI[|+-T/чD5k$I@!"yfѹ,ûFx,kY[h,_(^Cٝ90nr.Bs |UtO$"|pҽ% (ാ3^_0 3K ;PPǼ¤sk3/>%I&*;3,f@ZD#%\x]P `K[*B ֑Miek Ӎ^ueC`;-R!bپX#;P\7})j  `>d4oaDf"=C"v=*݃!.v\kDm Peۧrцv ֺnh -ߌ!;eAHc+Lck6` 5c.Xt. Ehn^>kYAZwAQ\am<#jIp^7(e Fr4N޾`AuL"7`A6Qw { D$(=LeV1-wÿd MFI *<${XL ܫlNI.*/_cd.?IT!T(z4Ղ$/p28*5q7fb eNKУϓ*G,`.,I'ŋڞ?5l: |GMMIi[JLf$ 0Sxm X+$Iehco&*l '+=l D?^9 2v> 1 9sD؊C kP2Zs**4;^.yCi;~bE MNeT?YFSCQWT=Y,?ъ'P/>=|O+^4*>^D/_<=̠#[(Y Z(  D0ܚNICP `x|+Feq4o\CREݵ*v= ~ : @5̻`<lmw;>BUC?%b%)Dg&~-铨) oXRbsJa //~& mpBPT(\g.Bt1]hX2mߊ@JЅKK,X X\ 1lkI[l5\-dX\`@7F@Qer ' j#r-Յhf) h9rĖ [6BWXmC.l /^=*gV@(Py܎BEQQ=iκ:ʣk Olu񱎺^C/#X moGh{{jxS?]?bXi *$XzC|M /6"endstream endobj 426 0 obj << /Filter /FlateDecode /Length 3202 >> stream xrGLԓx:|?RqluUHel&Z8{A0Arc n}$k10hl`w-P=z(c~p+-d;=7J8e趎~`CuuxCTsx")\V /:Væݏy9%}[GIc]1`^k*prywȫ{eijq+^a{39`fƀ74gV x1s,IZkrZ_sW!! /̰uk{X AJVJWð8:F!E^:UUPVUQA"b S(ً98h,'3s0& 'q{RceL1IZ2FKA903 QfCG2 I † |BŔ9e)R1c=:)]u[qS$g1.gd&pTtR"8c@iEV(1 937F=̰$"!^8%PnVbzmA\*K! Ҋ4%.ՠ8:sf$[4M{!G! 2q\Zvdd^ &!  Da(FTg|Ie=$X0D ^UEE'<(Ku_)7L @oEN+sQa4[ l,h2<%XC\rU noo\1`?ղ?V>LM 8}xz$vdh<-Ibe#b +i -ʠC|Qnttcs!q1P@Ap H g`A2 4sP1P˖&+!=ȘC4TPFmP.vWAVU&R:C'=՘B ZUesnijivihT0˿LyZy 1+ :j0")s0Y܌NLFȮ4$).IM3sR$MNCws(]V rfXk}()Cz &3>4Ig'q~24z_mԬQ]OU/@ ^ygVeE~QAmȷQ9pAR vߴӾ9с}XG_QzlǠ`E$8ǧ$l]Ʒ2$8腄}/sf04/ЯM|nu+xWATئ^Rx/U“o7Ѯ3:xy(Bߒg܏sP"7K gѵu%!`ʯ'ڤN$݄JG"Ao$R~Yz&:1 G$5ȖQCNv1^?Ae:Fٗe)JUCѸ5 a[G/!؋jtQ@1$1c[vR'4"zOo)}YOiUDGc(X W>'%"a#렃CcuP+yO.:1Zcw/6MAÇ6fC7vH ] .&[7iqh Hxf[z*{ ~rfzfYZ|6 |ΙCFs'Vezt ]!+_Z&vZ}I?BпِHe){ \-MWt }d`BaȰk{ MZQ_r볼tἻ DT΄ga{:~3Vda4S8-no)]M~>Z1NjXE]6QlJ1O*PchQ a:ֈNĶDLV?W "FZX ]T8}6{b8`᪲  k &QzLЛ ]~]Ixj8Aۓpr|x^yum_>xdCy6`5SQGG KNR:БnTU&qdsŢ p %$('GQ9=.~=NW6K%'qfY"?%v Tg@5nh?v7LU +54z݃yt1::;/ȯɟendstream endobj 427 0 obj << /Filter /FlateDecode /Length 9820 >> stream x}[eq8?O4ys'eW\%,AFYr-J 6P"))j8=qGc?/y_û?~_?H^+wi~mg=_:G~UI߼x\_/fWIҟUG|WwT}zEOsJ#秐˹SoT)UdhT9?=A Ojkgm17TW2z0QpҾ%ODmϿƜM9֜o.}"kQ)K|51+;0B5W3+ u(f|MHNTKeO0mAm[mDM%?QdoI eYWx|c%lfHci)5^)@?r (/L#:_jk,W`?:J}a}dWj7f>ڜ%&YYPg{TkLZybb+Xl:M^{T뫢A 7Py7`Mc*-YI+oʩۻJ6 As頁(–SV16b*\l%ůr^9^ ה㫥SdNk1knQgs=Қ;V GHGcc:Z*6,$\ڥ SUL,YrІĪS,LrX`h.-w0J#m@2hq+FrK[7  ,:;TZ7YTaeN,EϦuúuXYVt$&GA^D+ْCeݑWVɀ˲UpRJaXc \l5u}0 \\ձ '%wB8X7 6d[JB_858ToTZ8ߙۧcX 6oaŠRwƢanWS Ƽ8߹GNrD8͔ʳq[NÖ_ ϩ}ؘ:9a7k8$,ly٭*!_[/Z7*WkTmpJj q*Q Nth(Hj0KiS'<] ya0xJ2a&kVt=|#Ah 9YظA`)MG(kK:'_'v֎?(r#,pnKdݔU&,@DGjɖ~4,J1HCUE-$լ]1Y9gmz@A9u$! 甍WEC s )%gݰqQ#`82lp`>Z$vgnT8"}ڸm5<-LcSpӣt8֝.Ӧ\VuH5 nɨ: Sp)Ŷռ763p|@b>U̯5-3%͇]EHXw. .OA|hmɡɡ%Vģ][rh>UyhmɡQϑ]ф7:`) A3rDs/zIFOuCu.Ys ~G [,InZ8?-ܴDzO-ܴ*4ڡ咛VǗ.ܴSrM}h##g3 0шZ0A|fU,t.,,ynԲw%ƌ_yZl&_$0βw~,g_3cY,q`YM , %Ax/4IӬڝ˪Ͳ*ƼX, 7˪nЬZpЬZx4T|,.cA*:+Y{Ym$i!x`CьU9"3<[A0:DXy81Ș~Fh 6?& 웣wc u QA:v }Ԁ c4 AxvBNP2NF (H['Zdp'<:)P#zdҦ<5 Ae!6 :@ U6 ?z9GQnf;^2J,/u `??Zr/4cmGE>*6{}w1-# G/Gɏ@hhܼǟU}TzZ>:{z AIa=*AU89fz0lǿc6%pCG@eݰ%և9G7Dأ@=Hi8kl(%~{Ԭr` khk5Yg༁JDl1H&%ɆA+gStlcbǍtJtR>̶ v6i#^&!:Wto,urce Q2 `:f8TM hͨÜ"{:KQ]CX1DQma++du܆eln=ׁ>Xj܆\tz.iVXȫF@hޤTD5nPVҀBE5β~G7 6oՖXr,MT耻v~˚zW0_#=x[$X^MY_JYaB9-$8Q90d*Xdii@KI#$⑕Ncn9L͛S%h|Nhj(XS>4db'!pT%]Y:U`ɗ[%4PF9 !w}v0$ "aU+AqDAo8 BNuBA2|/Iw+E%Ŷ'SIJfpb%%nspeV \ӿKh0yXꍕ:`ҩޞcC{1į_s9N7e>0gyk Q?+tsHN"rƍruYy90K6dih - Ae?v#ƧE\gTcf(،cWkZJs3U쫩d; KUٕܫr[ Ӳruqu4dMJ4 kF-y.ڌ_t4 jiVoKpąi[|X$ $ɺCn 4keŐ=zJvG]K eCW@&bN:(K40ΉauvB4$8L)[qjbߕ6jӍJWizO\)dusXVVrˢ3]KrEk<>ҊqK-7֖Z-9|YZ[rh}s$~VDĆHJ=It 3d=Z.iy<C3ߴ\rӢ*S%7)'=\rjE/s$҈4i\\Ȍtg?Ɉ5لE3W B_=XqXZCxM@hja?c7~'Ӵ_0?'tHW]k ;.ųFMHÔX^+'t?eks.p;\.Ε|s{rE_\t(TFιpڜ\.sεys9/3ՊM}Zp.t~MlHc ]7I] 6~A7 h1A8^ͺp欋Nl1F][f/X`]tt螁`]X$κzw/f]αuu39)K>}ӝt1MvR&]ZNͻFr]_r5'VoEnkdnŬulu_T *;r5 J.:]i)7X0Tі}Kc՜u1c Mh5<ҰIנ3ը.b]`]Y@A*d$YSn=xȑ8oKqQ*c]1ktOެk0']4=߃t 5Ap k Oޤk0qp8up.7E-\t5.^fk0.8(˨SnԐ|P.JrE)`,\ Eo1#g\8s5f 䌋C"(qKsmrĶS.̓r5i\*UK%ߝrd{RYs:eK%Ftr(JɺT|X$W\``{Hr W@Zڅ @ $246!Hq5ZD @'4f;D Dvs{d03nD p"< 50X 0Ć VD ǘ#AVw F@bENB{ʉ@+7#y0 oQNXa@ `[/rX'a:Po(q♠_5gz:WXFNwGh)iaHV#߄4YB Q:SE,K$K7bǕ&L.Wgo[-gh2ș+Q0 y&^,MbII&b)&Lc,gޑ3MVYzj;̖&{: |5,#$Yu5, ph& orZ'I pB_Xt7Kf=Hx$9,Nx 3$ui]E2)޸g 3_u&KqDvCE'8K+'m O+\;K+N%W[k#W8Hi\aJ7z$8DZ(<0SU# P y\a|p ˓=0j;Ȯ{ \Y|Ab/2 ,pg8 ,J+`[O?`ey \\uOhMzj{΅ٮz$ 8Hć3 X\G~a q?/:CNȀ+$ Wpev'WRm<Hڍ8H%ly\mg[$;k2 π$R<7=03VgA2^=Ti p'e{$ 9pi!́+J8H<[#r KY\1~As({g$)pD9pT_xAe8r;_sʼ, u7C$B,͒ \Whԛ˼6PNLM:5)?Eĥc ]Bܳ{ɱ>n,W\K?}gGY~J3,ʍ/ tK8n mE:KAhBRg܌t YAj\ D_ ě|i͔M6ab ¤ &v au$R־c|LnDo<Wʾ.$tWyaY.:(KbhW/HY|7U|%^ĕ=8_3.s_Uqb|)|)ӑm8_ʑi|L1Rnל/;:q V9*7aҗn)<a}AGq j[_EƟ-A"~3ْrԴ #:o AYo9Y>>4PY[N$kAD;JgcNs/2$|V)1%J5$|DT CaT  %|2hOy[YR $| /\IBP>n+ meagy[Y&oL8W>3ʒ,fqq%H"J‡~"EF;3$E'J/1$b#\ΔkϻB°\?_gE(,X) ?$h"JŒRcLI~ǙsW)ϖSbk:_*'{*̥mpH98RPJ+TM vJ+b*ojɩҚJI+QFeS%=;qðfKrF497F=rUZmfKL޾= cTʖ#.+ ;ne;hοqȀ<_ P ?Z}^cűu=YiSN o_^sbCôrX^ 1?d(?8؎~0_61~ ?c>04>Q>f|RPuFBşn !ٟm->e9+C⏹m:삵 (O2]EA|g]Am|ev^WV|;+Cq·6oו!xGn|ӝ? p젭~ |*r |CNoT |<9@  "78 Al=L}.֊NR$ | v zB>a 2 3i |A<VJ@o*7BDX |#R Sd 8 v4PB!´qHZ VDs&U/hô4,g&f>]ytV6 +U?&(Odu2Io84EzȈ6}vGi&PBj1 ofXItWD-XR϶:y#`:oNK d G3vƅp1t a7 [7e yt g>DL&6D3i,tR1VIhn+vmP B*&D JSJo08y:Jjo=SY=6zi4t޶N˭Ѧ*,(`f8?<*oGyj^ew5%L]Trd;UkX{`z24. 57mW5-rѩlCH7Lt s쁅xv+BKh8qЋֹ\!FN6Dt9%j&2؏H^I:,$ZT \ۭv0}|fpmȚGWi2BRyeXF(5+ k~$o!XAjAv)[IqbAKs"|5Mi"!j[4侎ْ']y簝T_;3_H|Fa< =wguSGHD6(!1ڟ E ob\][cDCdwKskqNM_ 6 x:b}StS:;MğHY6}c#"s~ IZ{JVoM\Sgevog P9endstream endobj 428 0 obj << /Filter /FlateDecode /Length 162 >> stream x]O10 ZЅUqP(/ СY:ߝ|]FEehvK@Fˢ@[;'nʿ?`5]M$KWBi )(I4E6ƴXI{`06:?M%K17MR{;RB|rTendstream endobj 429 0 obj << /Filter /FlateDecode /Length 3709 >> stream xI /p_rSl)e]q_ݛWuyn["#*RfBRŅ6 N5?]=~ۤizro .N/޼_kJ)[nl#ui.̛^jN:O7$+sӇQ;ek~;CwxYQ lkPJJv𖺳fa]*}sƔo9Z'Tr)Ak/rVecU%;WԜi1){ GK0`sl"0>8isFm;.:>e택^|C ԶV>>>-ΨN-*eWiMk*ĝǴjM0.KJEӠ)d.Ǔoyd,_qmI.52;}+ƹkn4j/]Ilk>˫/dN5fKyc ˿mBIc-8oiBHQ{we")ݺEHlV>͔4Έ"}q/|Zk]VLV5`N*{P<&zPXM X O&T֚PM"BRjFX.TP0 UHr4zfܬcR1BrU|m\ uɃyڜo|@sK<m6=sL14pGsyx%&{WUfn|M,eMxnfȰЭ/v %ΐvH6[ҧ5d`"޶v qsR5"t y S}~1ߩboy 3CT5$OPdtiZ$@Cj"*4Z$@E$F%Hm,-h6Flan ē{4ݛ}H>` x"4 B99,P Th! KbˆuhKa,:.GadQFsEhj鮮kSp ߵ ٌ$+Y9)(CAhgp;1ngĠv %?f#l3dT<ڼ1{bp;[ϐc";{a|d_U};pr1{؎rl˖Qy\_؃'=޲"*: V PV Pc+~9gw"FV􋭿ګ/ƜmbBP4B.Ҟz1DnP*J&T RM"BZ&A*j:SKf Fy$X"\Ko cu4Ń8(9L}@ZӴ [ar|%+jsgv9*c^{hu1fD٣^1(#͘vh뎴5RtIe[ΐ*,0ٳ8NҨ Vy WKI*i7v' ||pDdbP**gEju0JBecxzG]c^="o/Ѩ h򑦴`bqsmDP!4 )ԥPdf $H٬ﷆ"hhfjM%/ղ]ng紶e.A3nEeb8qz9 v$4C3lxtJYwEK_PogȠ Kvm̰[G:t˘AWq>:fؙ3}v]]Yε%N6#w,{Riyqb#f>d.Q]CV h@= $HqP]tj-HuB}T ~*!D^QI%u.5*C֓ParUN>u(S^>mXTƈZP%&TH*6%CJ&oPM"`k&T7Pֳ؄Bk3l2[2x[Ykz9<\J%>_IukR4OR?nM[v$[Ch;Cwc-ٍ!p7Y2Fdgvkm ɲ+룊5X=ny%h:"_XzĨsZ'.o@u R- T r@u R-oAkzJvmSNLp JF.:,L+ a%;.AșI5~"$eɫKjsfwzQ࠴hClj4]fZ)Y%K6.E+Yď$YڀВ6Fz&1)ǝ Yqyx3 85 -{&xud.%\iƃ"ԜEI5"%H *P]T6uslAy&ҝ'fC&I\1J4qvl:E,V5jU t e)$f`\0lP5|!aDPm@Zk9UoGNdUM5UȪ^fKCn1B󕐵μ.,^heqdu$.zPҀa.)PM",KIU2]"4`ڬ=ܵri 8V3MLS0մjJk](%B:VevvypYvG=ԋ4cm w!"C,zKC}ǁ \4п##?du=jpȕhJ:BwY:b5L7FV BΪ1Vi`Zte].@fw̩ir0&@F(2wz_]C9JkzF;8(8Kt/ ]"DG,Ls1~DRX5KUy\,{t RNT3XhA5k F:ykpnVXlڒMws襠Kv"_œ -\vJA1^@vႷ(l@+do&x}Hc<~X?~᠔t 땑?gD{Ç7y Q3 [%RCvCDYl?0w04~-PQ')DkàeBG4endstream endobj 430 0 obj << /Filter /FlateDecode /Length 2807 >> stream x[o7G*6^2h.pZϸCA,;=!wEW^ɉáУ!GraJ>d#k> xr88s0T:lPzXtR/'G  HpXƬuQ^1+%Wh,a튫XT%{VJg6 p0ghmTXIS6ppUs/YUqs&iI.pZSL5e$ aJd`]JKU\-3a+. ^Ǒ`Ϊ(Qk\cZ%0"բXP0Mm7ڃ0lhJ= |$v#dzA!cp,ui'UmŌ҅biOn</Mp0i F5ǮRcl>֗yfaH2}˫īf1r/G>DFbqe`/GOdUlb`$y$GsB%DEs؊Z? bq ]L/YK~/&upQHVGD)'0 lk]0RCN9Mq"W$rDŦ%װfߋA ~z\ץa¸vE:&yyŸTDd͒ތPF!J97l .ћA-\Zw|?@Z3QZna~\*c%` ºY k!4NI<7ŻVpJ,GbuK@4 .9  ; -# %\(<#!`kM2@`B9oU6͆ٞKΞ3U'k$.\Mg; 0_/? g^$>A{ЃO)&}KeCkSzx+v;}.J]3뺛 icin8o^$Ƅ P+ƘTx+stbc0,zf̺N6A ƎG/ܥl^CX^eFԫ xm ޶`}dK'mj6lL u;vώ"2|$E:t U19e(͆oMlyͣS X>ql܌LslFtb S{T>;6@6'6^O;ZД]mf: 1/yH>'Az#E]wV`7LCf"y"%UǿKdW˶'.Љ W~Bsq4t%Hİ4.jr\Pzq"$.!be| ޚְJi8Ký !ӎK$ِI~p6''*㌌i;~E|սVG6oE J==f츎䝦M:1D41O!+@+3} @H.[C@2uU$tUbYO"3.4|/^l4|V}ΉڡeaPX(\|I\;ʶ;tJ(vk\ $4/ݬTٍ<n,MY:3>ѽc޽%Fe4=m^<[V=m;שRN# 2?MC}e*))J׸)r'yӶVm1~*n6Ͽy+4<*,o|ˈ=^VUA,dy$yU>ayWX/,W{c ~߼kz*ֵ0imMCZ }1e+ѬWyicdʨ.Z[ ,6oXSf3G<ҧ惚^,y0"ˤcɪdu:{&=]n%xe7gyeso푤m|S$ 5볗lq4:&y(~dUendstream endobj 431 0 obj << /Filter /FlateDecode /Length 2935 >> stream xZK O#Tɥ:|?R%el:S 1<왱7٭&$J]s$\793].n;'i"۳AT.\xayb"rn/{E9<{T7Rn}TAKk{%,W1o_#铒3w].E/b]Bx8I:1!l4祖a4gw`f¿,W>@b6FUwwM)I;XX][nZӚBw)]1$9| {\N[bIꃔݿA1hGImq)}0ii>гd ]Ss<-> {!LȣNeNk{atƪndIZ=:&xJJ>S^rw-VA*-/FgLSM&41[f$iR +i;b@b kWhQ'E 7t !v_Bo ?񩐏a[]*{Sˢa 2P ySȉrB>rމ_& qru! VԽ5Q Ͻ0m!1GH=佂oE:øO\=LN* KQtй_('/ yE*ӀaN|]>ÉY4P )GnKD>IQ|0:6f]v,wC!*B>//PeϠ2$ p2/?e#ԏp1eZ%v.[W M lo2ivHMs9St|c)AVuܗd[b:c6z]5rxqXZc{\jo#5xY6GSׅJ^L`= ϩ0Tlm)EM`cVM5?EvthT8㦌f+ӗT<i)be eKXJm:H[Z!gv@L,WR^B6 NC&(i^De036UPT،3T*0ox( 9hCU x٬͙lȇS T^g._ csm!CeCDuĪ*R}jgiEhJ4*R4Nk}❷_&9ҞUEXrBq́S!_J H5`:p?L/ P}=,[&g+o $뀠u I,p )N%FS7v483{d5ߴzIfdOl 3i?;bfr[I`6%>8w,;[+d9᮲PYWz'AxU.&̫oydzHm6y^x7{; jZ-U-T_B?)rT,A`i^%8M`Y!NGUfk5PG>[CohMa.C]5,bZueo )  x՛{F2L5X`ztVB 5#-',TƢ qwX8b^ ay#G4'lD49XhI :FI<6+[#!;cB%VwXgۛC"B#A*> :NLѫ^ܥd7,Z }ʎ9"g@ ;F!;Lr^]InXy7r,>CQE!xjuxba﻾k=4Ī u= <#Ѫ٘?H0|9l:glyF돘dpjDKo N_cO-*2 8W{pUi7]Z{VS&*j~.<Ӡ~``^lV'M̼=i>H IO|˯^N1v،~[WrdW&sG 7ЫB ;"JA^87= t%{9AnVl`7~f 8f,+#\!+vm/p>z Ǭ'N 55dpKJm=endstream endobj 432 0 obj << /Filter /FlateDecode /Length 486 >> stream xSMo1/G3_Q'ZV\*Q + !~ƛ/(ｙy3sAVpӰp~uj^lX {*:EWR77#]0 CÝDA*~ cR= 89, rRҧ]CcΖw Bmx3 `qcjU 0  !/; -R߮-u& s/IsG‚&o /Z :IPTD1(ŪsVdhA,*jniM˽h> stream x \T/ XI4Pђ鴦Ā,a5E%)1$V1:A76ۻ5M`2}rHb2k,k6fɛ w9ۙ`9w`̙33b2z"{79=#e.ړ+#9U4.??ǁSY42A$e?bOMN|-~N2VŒ+<=jVzVE3ڞjRYEy%b(&eUUIII>ONҞGjRܲ0313$4??s83Q~:ٞuM$%%uuu~neU;'դ0C)Cx ffV=j&$gIrX t茵-ЗgTg> #GQ2dSxdb7Q N;'0ch %KJC K3?1A AFvO~o+hO9Ξhr! {¨в gDաL=Q8@:[ެ"PW8ߞ?an+VAYR(:`ikCmmϯ̏Ǒl|~:Ş~Q(ÜjoпCz~ #8.9&i-?-AL%UɐLNYY‚<r='03y%%@+?@Bz~>? G{ڜ85!t=PII"EJ?a.dBH4 ?6|9x>{B L+~N7{nC%@*K {]>;KJچjb~m$쫹񛗣/A_r='d0S|ӗԕ$&~M[R-|XM+9i9rKfFkjj^s??IL8ȞhRI"g]rb򶺑]%u`ų` MDJ4T3slA͂oa]Zl1f ?h=*6V\z[y$ h f%55OhѺ:xF ޛ mP?'?G!?G1)n@~BacO8Fsca.aLٖjX4WX3*9ٴ//מq?g=oڕSu}۠~DYs/&vsM^L/{޿dCYY׶s> 55k6`.X >Y{<~^o=y3n>x] ̬ۖ62r~+@~ !~BVBzb~n@YV;ؚ߉x=CkJe_<{l<.t%l<626 C0?ζ>L2ϱ;cNgM%f=]@D< m_ 򢶑c HV A{{rFa|s{ v=ÿm*1iؒw$mm#}0NXMMȬ1XD |X(#, |sƚmSjOn"NÀ##m~AKI5!~, ٛ~ {Vb~3̻d_< eG7 ]ƂY ?k~!,+=~/mSc@*( 9뀟,5C; @oۀڛӋ  Vg$z9$H/ok{=0l޶F7~޷fCz;ӻ poH69qdsz[76_oFڹ`#@X6V9tTp߹xG̪7_y>Ͼa0;i4}@ˇ6o>Tcc5CSxecEgIՍCx[߈??f/msPMxfhha nj{gs3gCrdL{#o+"3͞>W\0{fl`ҁJP= M/|f5NxDrNvVVxc09 ~0s׌湚K~-n2(3 >| Y}H@< u0QX_켱Fnٰ` 5c0i_0"" AKs?a38xp~&GP?a7v{͂ٳ~^`R$YQCC%=? 8B?kz6;a9!gO߇`) Ĝ1Osz1r6ZY4 =zr?9zGg(vEܼ<0 Okj3`@^`@oY l@lgiKi36/^_a#qn hlnٳeϡ1K !߹xv[1?T¸O@KㄽӝݙbL]M|EdX?q ȳC999EͤҖ%O{np>mg/$t?gϗ7 ko@8A rrzs@;pkQr>ooZ bNS v8tpqz7?eO7mP'] `s g,* (ds?96%DQxTDij`k麏I'lיgOC50q9V[tlvρ[?@wAAG9x?Er WotKƥO:tIgs9ɞD?5 o9KEx:B )@?MiQeۅ=!/"kzT`&x^ο[**ГKş̜9eJ/an;,׎L{Oz,ZL/{B>3$mP>KQZB{FgzbЛSZֻ ')*7U-rؚ4'p 2sHшf)gKK%ǟksd;ew:Þ@xz¤Tƹ?XPA''R$KA~ ܚC;Bmdyyyg6K=oVɓDfM$͢fƸO$aBifO*R8l4p6݊[B*+|"Lσht?#awXET'ݢ$BO#AlOٜ˖'d)+^v#8K'l̝,?'e'491oO3`JO9I@kRR}=5p ?pE-;#P½7`Oz fΫ%UxɝްϜ`O˿3[J6J<%^N (7 ! mSJ#CLOsQSnRb,JzY7͕I<| }Co{Z =Wi"$EQhexz|mk{!8\ /5=)A؞ Խco_vY´Yp x?&zaU>iۦɒΘcG$=זwLH= hL=fF5EhyqϞPAJԌ[2dT1mԈxb.CP^l .oOR{2OAQuPt+;͞:<o'> P12|/l$D=o'\=6:o:e\0Ϸ4UOnk)\dq1)U&s4!Iw_Ol&9ޔk鍹@@kݨ,0==z $Y5x̺N^%1lɒ5zhafp\R)I?a3+z~Ѡ& 8!=9., \uI/4:ž?V:<q s A]( u~n'9[ v\RbOĹj|)?k'|6g))7s*zC30j 擂1d(, ndHgR8fԂfD K==85B;EtPL P x"`)fJk$i 7\-&RQQS5),bNIʞz7HJ^f,Uy$UPÜa|fesޞ&?XIp--"99AL͞ @?|-s0?F  O/NRhr 2$o#hX{UxO? kOc毛Zʊ1 AgOI72sP K6>=нczdq+(ʢ 5%>|q'F`>a3t;%! t:О+" ׶[9)7a~禧czg8sO.wR{M{fI{_,=㤞y4?52uĝgm:Lx֖!?=fjdvsO h"?wszKӌ?1+(TTOc ;Ԟ<>;3R ?sq^  "~fg4Sa}ni\HGOф ),[W+2 Hk{1zg \)SRNQc.qYރR##s2~d?b'?JAcǍ04{hä&XaiSMǛRR?~)ǟ }3Y֕Ω0 3%]ۈtcJAw HsTתԘ"G)Ȝ))Ǎ0|aGv76cǛ>­%|X{J xk4pp2n 0=,'"dS7#OJ؞GzGaiۊK?cu?Tz=U߽n|ޞ D\h_`|ga@U%x&2"Ig{JPg'L"KSExp˻ { LOޔ4'fw¡q\>Ϳ%Z;3dO+2:BlCзC$E;=.뢋$Çw'hO4Ci }?]u4@l$.Ӣ,6 XAy1aR !{~S3=7=%=3/. OϧEy&"B)X~>\py)p CO'+!p'=I?9 ( KޞO~]bO?sB~C'go&"Qz¦纁zע,ȝ 9My!=ģ:.R${#OOo3FƧ7IQn]z)~~p” L# ѧjfWg{=JNQf\i^1 2jG}&F !6VjxZOq7hH:Mp .x쉯{טBgݹW?wWǎ1 iihOH_O]O7'LcͷĊe)6\*)sÞ`)G Ӽ <$zu5χr)g?{r|}^m\Wwë'@>]YѣIH:Qx,L~~ hZ{kX,|h*Iw=gOxW^mL_o'90&[^ Xg?Gt);xP3w߽lQύ0B4S +7gnztXW2f#(dg<S>"{֢qxrr$^˿[zm: ͹L8'jzsSnrRHdONTU73Ӽz7৞OHϩɍ]x='-G*w<1{^V@tBq'jԮEȺ{"tcCn)Lݹ}p5 '3 @K߁sJns0IW>uJ,ĞC[0T=SwpԝۇWp= '>8%{̠A?2dt2xVR9vyr߁~V<-MzYnZﵞ '\?t,&,NHA9jeq;ƞ#ꉆܧIat=Z{+K`9bΠť /'JbGdO|JySpL3F:)SnZ8xO7Oz{Qf!'3BgGb;ݔ?{=еdgW?9 ~:Ξo(wS,y dSwK<88IwpvԬFuvҞ)FiBywry Ks}d)4sNxN8Ş ϕ~-!(uzozso'`|-:n ]77 (RD'>$t?2ΐ 4~9u){72OR;zNγ'^lDlOm_i vL6g x? Znʦ WzPφ'Ğ~X!8#(Gng)Sє맵tKd{7 * ]l$:wk?B<tWvؙ53DksIS)[k "$x?. gx\Ņ-3~:Ϟ nIP=Z@^=h%㝠u0h\™6liZt%oLSS `UnniՓ;~Dv=!s4 wB>= \ ؓ:&ҲP>A *g5k7:;cc!J9x됅1'gO<oAxoB>\2U<;Ɩ:1~zZwF~{fTS?{ َU9xxs  Һqfg;W؞^_݃E|NĞq{,cOp^M_{.]t2 }1݊]=]FϚE߃MY"ޭdOkvFZglvB R==]q!kϓ>J4M(DϪe,b{ :Ȟg}IOW|;´';OidQ1>{0~{C)Ax3n6?FTfC$Kpxw$L3?ܷ0?I$'@4n%s kY ϞޅEJF ^͸!7os=g=!?#v"$pa('iğfR|wl; C8\$ ğ$s~M{{ O]=5Tu#|,8jrܩXC@݇\rp9˞A͹a0) )v9C=Gg=!?:ef^j T Ts 23iz"x|dݿlCMoO 㰧O?9;4霣et\>98u=1#Nݞ3UAӜdeNinϓ;S`)Itо`Lo{tо`Þݜ=X!"YH3Hp""w?:5eppߝgτn=a1Hskcδ߯9Mg{.c_~X96I({F܀l, _n:Oʞ e~xǿAsߧݙs'Mgʞ>e~_PsfB3P.=3 BBn@}V!>I4=Vv3/`K*bh!'~s\_ޞgh3.;S."Hx=e"{&gO"RB3tg eL=="RB3ʈn˄6`+%a@SAAa7V)+طD ɶ u7=5G)1YU7.n{0=~b~?u,R)nюK)U揌I=5SM~&a&ф(#3?|g'ϹnN⧇wݤE AV,UAc./hI%EZe(EP}0h)IKt_߸o[^I\{?m?h˱d$j>?h,{ja%!6i "S-QA%dZ#{cL~(s^x֋:u/ҫčLk%ѭIdž¶`d{u~*sHܡS)Abz}?LC>l*nw=XN'낽FzDAs[' uJ9~r(z+,`c7 #_5,b~,㉒*3y;k{<?9N?tMHTK22Y oR 㤟Ԡނo>?IY6S^ kF[5W~w[fY]:z~K {L~J\7끃VfLJ ΜxJGKòs6a~mŽ|?^~2 u=ѧɧ-X'pD FE׹ vfb &G?n%s~rպO|%fuj+ -{ʩ'O/%uIԠޜ?u,w>7S\SZB~ȄgÞ~ỳmK* %ZYh&+JOY:O. C)aPhJxCn|{8KcϷΪ%_=\T5 bwTJId:MdA(\Ǩ>okO?Kk@*J1B"nj.$'.kM^*{!O/,KIO<&0`?7n) fed|#>/vx_݋{(9򅵖{B~w~72(Sl\>j#ؘ!BD{oJf  4jZ/\]݋ZG ZD맗*ϋ ,47 򔕰X&qj쿝Q+SåNYA)sbˮuFminU+oQz#ɖ1ټ$.0ؒM#6˚GӞ~d"i9s^> 'ݵT?˃:~R3Fd2K,#$e'JoZ,c,߶H/@/f%Դ#"s=;Λc#;rOʻ #E|b0ˮc>B럴>2B˚ۄH8?*s N譭&-)D!=mw633wm_QEOX ɏa#̬J>QnwڻZ)%˩t^0bv\Ϗ(6i (7 +{CQ~qD%+F3i|W_H}9x_% y7Ό=h ɲk]I3WM( D m9.tYtQǻuݱ̷6%w0<w*d Ee@W)eD45`,ZM4◿KiG\ʵP&+M`SBWe?`?ٝ`?5߉F3w.ɥ EbJNM/q֬ڎcaH@5bVVٷ#^mw&{ٸ5Ez{u4ۅhA8?5颽RF[.%LOL/G|]Y̎řWfm:ۤ,"G(Y%IKi1h}kN*rAl(f';e-EqPu\\ʃHZw2xs9ZG]?e ġ`NhC {p)ӎpo/2U/Dwݪ.YeJiSH6bX6Lâ9݄RTHP5a]P9"dD}p!O.n4[o^iubպdy.YѫrdK6ugS5 O++2V{y>׸M=&`tGş`ώͱ+#, ҵyJ(MRd|{gDAz*acqrh"vߚ!wYnH4@KqE!ױF>(?X-J]ax'B&g碍XZ4v&|:=Q$Jњυ("/NX yI~;4W+w,ݧ׻fkY 4ϷKW :}M~$'T(( _ֲ1_6vF[?CGΒcYF|ow]@+(f[2b/3lXd<-.w(l}Al;7TwGԟu?gUն?'K)[QS}6(-ӛ[aT ?Y+~ 'mį|͹5M.''F{#8qy$& RzJN^45U`M8I4^ɳ7q(/2yfC沈gn~aQUMb>yW;EF^cn׼&#$fZsSj^y;B\1!8h7jPAl> ~#^wQYm=z9kQ\,XbR d/7bC vBƴhƟcG#ՙ s8, ޗ,7G۹p7N4Uy$ C%$b1F߅6~e7C;SS'wKOu]̱Wo+|ø [d|N:?֍(nl̮bV&< ޥ4@M r;N&U|Q^u$ŒQ/^3}6OȦӢ/J)E%#OH55^K1EP7R&y(=ɇȏwPW:~͢N_q ? o*\ɦ;?=|Ѓ,M'hmY3OdYHw\ִb *lGq&Ƽl!ܻ27Ah-zݖb;xz;W|[y^ fYQBMfESw eU佱'F{(17-6o tžc];_zk37t期ػ|>dn 29= |bIx-u6>kV3S48iib~piu=8]g /$~Nd*gR1)Mc. ;F*R̹Ll6ѡ>%!&~I_$ {Ǘpý`Wz>Ro湽tk'hwIkӚHD8D"?XS菋~ڥ%!x$qF!Z/[OSӠ'hg2'ꭷP?9{2ߝo nvOj:;2.y7D?. l$ 2VnglϓRc$ukT_x7vd8{7')))fՙGï,d3<oi)mPEIH6ekwgU{y7杶 \']ĔI~-6]0&&]_>|ZqNZM޽[^\(CUzc!S&UaĘֿv!..Ҩ=l\|jgkRž+ TW< ԋrʽs%ZhRm7gv]bNwQoLXc>|vN5O ]_ b6{\]es;/Ȧҗo㼮ά*$BAz5%u,i})NLdnzDV;O}|)L?յ};sskߏ?c]ƁB'nB|I'h~ˠ#\BΖ䬥LTc+u!ݻl_$Q65NElB N r럒Wu+b̼q<]WK).?, `S]#h +8xjVhR Dd&$ߊ=L}ix`"ݫ;<';rޚSಅYd gu:&ԥr^XXY %vyWޚiט܂EVt]ȹpa|/bFr՟oVXw݋n5:Tid#n&eLJ|Ũ u㬟9K;m6QMy]ttln)=_jqY෾ޯ[ pԔt9.'gk׭^ N.ّΉEv5%Җ\OV*`=^ͱ/>ų:KIMZ@,[yz'ަKoc4OӺ芛nnS'uN$Kx|&Nֽ3ܠ'I/>&""h FClH;jS2u|ixIZ=||ҡ o_ԒQq꟔AY_%} ZSgAzNZ ):Œg/ȫ!|DU*WY) <=|H٨I'px/UTdĊBz7Q|ݚ}/ZW{7椥g b?VSyA83H:]oG\C#Cf/kG 'tIA܉YtXǟb.|/9[||mZI/+4 2z"uf-FbI|`nMxa3ߚF5v֘/CحډS.4 ⣟a}]?Xu۰1~ܾKLM9O+9>y%pSh`Qtj3|V25㊹𱬘r9)}J&zZ;g[O[g[̟uao'N//W܄W{?br3k(k"%|l8hK1MuNQϩ?%滐Ӈ5mr*̢u~EF 2{?`ӇG3]ng/ |yZu^ZZҵ8;~$ѕկ4W)gO2KɋLH Ne|ξFQR5'"MlyBL5M L٩`۽'/kݵ<9;o}[SSR ~%{Ma x%s˽kimh9,bH'# J{w$fޘY*?=YvD,޿۹wy91B;!9֯?yl{:(:p3Q2=Bf%j++nJ߬9?8,la4rֈF{*g ̃ܞ&8ioqzVW]#m" X;z?*,,,27}z/Ɏm۾Fj ӊm\0[H┒<0 5-8?Cz3d@s%5N љZ?{2f-GTgjpoĿLD}Ẉ［da-5wKͺ*%ֈ<޹7Eb:שU1 WKqbM3R Iu˓`r]wgyN~ZaсYEbEX;G7~&ҥZb"~ cĤRZIk*yNLi̚d#ҸBˡja(+Ɣ4e<_Ӂ`~躨4 Ms|pBO_ +*+:ƟRi?on2:grr~J"'I$4;_ZĶJ^qT[?cKn%?c̈́5h~VM!MORR2R{+R*RRSSݻgmڴ{wb_iI?pّYr?E{0toEFƒwoڴlÆݯ2 ]QrQћ R= I%#O;Kׂ^V?$˯2q?Ȑ52_a T ~szlV*:"&gZZߟQ=%5b:;7rn(+-~N)ބe|gS&pmZƇO+A7zyVJ2&oT!zRbjD9QR"TJ]5D;mӰWih1½`'HJEoj‹ײ:7mYV{wg{z&3 ~>0 ]رqk͠;<&vuVH%QC+.?(3ldm1a l5.ҧqHv}ZjAZZzۈ}tЅ !;7dt{,)a޷+3UOϳ:?u/;'Ia@H7T@"2N{%$CYx\C-Y]B.=4;:`|k󗴴^}J时վ6=5G?)\]@_Czӊu#dRSfFOr(DQvIoEY~,)-[rdylmew2Qf􁸺VjnW7ʑ?p_Xv#>~܅/y0+uVۙu>SyYYzۙ>3?DL;1W`& yBg˶0iZurx=>Nd)GjXETVlک^:)?PAxji.iOӥCń:6Ƿ.:c ,qY@<_~u7^;f̈́W(^#0IyliR+꒨gH%trDS.I9ss$1gW#~;~eC$?)ǟzнs2xB^>bէtsipz[/%c|gS~;4OuvUu_f].yJli*T,)qz>閷/?.]zKdΡY׬zyM.9'y~;|=}EzGܬKW8&gb#6"%gBL'L9o$G< B ; `Sow֭޻uupB=kf~W{;YXn_~Z>M"rs+_f WaicywSP-1J[VZ͕V4 ϕ⠟|)/Y]H sVtϸ܍Ξݼ܍nϞ}S/47747ZUWe]X=CzfƍC`?y\b +yh032Gˏm6C &H鐔,9;}!zcujsr1ŧMJrB;u>;k7g!}t7yhr~ȑu hʚUR77=Q tquLMGWϷ'Lڞr]g:?=i'7> @)kT4qTNZOosisyօzfs nS"Z yn`Y#/4ܼ'\g0 POx9`/1\}ӳW S#J?ukD*/y dw{lkPNH (.i3謱v|F;k G^X^um9bg YbÊ{μ |uO(7A Sk#?,ʎ.J^#-OZLI Ҕa5 Ԓ>:^\&D@q?ɯ9S\uO7l.ԏx674ŰQ ^ڗr;>xV+FY۶7T4I/?ڛge֭{'!k{WL뜥M, +8q:?zߏ osHjIRZF'5Pbvكn' IKkݓcSOؑw'il;矾k$7\b̩ IC_ѓQֲCif?k;Gޞ1/;KKM |4LLXL!'~lf'`pٗ\)gw/dg&[>׋_߆HiaۢbN[bԿ=~ k.m`G,!wAS@Yǭe"/2b0==5֞,G5"{yazAzpi I{)N$xٗkg\:/#}v"U1?YEm,r!AqV0KtN--"'T_mэq0TH)>aYxxǚ z>Mw|:996unmSҲݧgs׋_?j'S(e>AΝ.Qrِ}oSE6dɞqΞvʾ& B}i(kOӥϷzҜ9s9=viΥ9v\ux),۽K0vsHqKNm4 5o? eֽvX5-'}ަKӠЭufRndbT)'[X Wd)Qd1_cґmT:P=ޅP/_e]˺^޺u--^XwµVSƍuc5 jjjnO+W,WeVp~z õn{ \0?er+~L"ʜ&c9yy--eխqzMD1I .C.N|-ҦtnԺ悂U˳ ,_Uyg͍^| ih}Iq1dgb""&a_X?1|]kqkݢ/ɥ;?MG^.%˕Srnj% >.\ۺGµ[oc0 n\OK#k'RD1Ox?d~fff|`GWge#+z8/3H3Q hq K5u?JF$iQJ7UmJ5y6q'N 2sy?r;^9 D%d^{ =3fOfP?L,uGИ2"CՌXQUd2LvCb9թcUS@Ne cI}V/n#-} >8yd_OZZYC֝?'=`=h9:\pY; # 78x?k3?z$# q{{+"xir1cRL"Wbݾj˜SCDC5L۟FIkw| v)V){z@ݺpg\Yrz"{=C>6>BT4M)YCf5^*'37{BX4I ^ڟFMNj#rJ}O?qrmڵ`~ͺ!%!+7s Qя1%b%?%}dQTUU4y[xQ%?iet7c)2BL`Ld4wFקCNԃ; }p7g߭k:x;)4 fBz,~3V~Z}z_Ek=;u1ETze0!2M[N!SV1?yFy2oyxzjiFrԄOԏ|^lsNﾵk;zE|v1= '%ɸ:>~)3X"ub)J%t1WϞ[KKm]w!ںvd,HgMgn]_܅?Jޜ{Q#S<4ρu:RݿN1fO 4b'dJ(k~ұ3zɸÔ0 A\Ea_W?ck珼Xھڅ[1=K'oC[yzlf'3%4 uGzV{VbMp5~C\n? ̿{9AjK'' 2Tf_[fV:UO|cv2l`*5].@wljw\| r֭Y׮#v[9ڊ} 6ߎfp6K<I'O(v t{>;x&Ƿ>Hw~srD*A|ډ"5vD|'GI^7%T}Zz%wA? HZ@?S \YyM/d+E~<Ҿ"Ǜ VC4et׮b#32=>Vis?3V|GmeO0D)pNDK m 1)rIӬe"_J2J>uju?)7ΖXRx͸vʯu0ϧt qIWϟ7;O/d9 `ݵ/Fzwz0ap1 x1uv ˷%>aֿêک;iſ*_eO0;s2ԓ9ٯ Z J3u3b+ԣnjM"6mJhBҥ']Vccz#ƷN<腬Z /뺢K' bp0ᄉF#я\hXOqӸ+A P<=YW2V%oz⼠.'b](b TNO \M~$ ݒP0 oT%ܓvcLX2 >']㕤w݃YI]m >188x'_}uV+1IO]]ݮx{t_,G$BcXa,Z#X(EwAA٬N7N4כf\qmȐa@6 u 'u qi+\.8}~?w%+&}w}~+Mh]!g~j?MCY2gwv^FO1mx^߷?؍xwbɡ+-^$f?I;'+^}˷}`h72`|'.5󩞪dt! G1<T-`ha,ܹc Vv t.gmm_=_6͙!|:C>?'PBŋQl/G bf_wnS"_|M4v>"cL?u߭Oŭa5e2c-9a 4U0vjcn}Jޓ'+5^Y~Ak:='@;V?y61a'"~VΧ~w:L9ebn:R4Sqc3چG6kZJtt1"qE.Zxx`d3ߐAFP 70;&V?~\dirNO+DM>?It2]QI+&N+@(pB<|6b'SG&*mm$ / 7;'5夰뭾 ڒAJNqHDH\*Q HmK?OwڇG5G/\!3@MuIPBy82]"R tK;&]?nO+@tjWI%jK'≧|f LJēlHMtXc^P>G s1Nv qմ3n6<^Rr1dgO'9{ِn˜u*&j) 3 u@q@ڟҩ3篣#9IOG4/Q4v"-dT\G(IYIyT].V *9Fb+wLM,\;~R]NPўgɹ'3O,vi]7\ ~z,}Ovth<)wF۳&&*zb~ 1Xtѱ `AZV̮FZs3t+F:A'"%xFCT~Rڢ̾{/W?_-Ⱥ5Qꜥ&rұOQHh2@JL]DB=]xgT]ٴcKG<:tcKg0tk$X3c$Hn0treIt  sk-#)i?ё[YiƌbGBsBm+'?p#nS+M" -CF+`ԓ'1y{h[nڽ{7˪9#{CϤ ޷_'O*rϯ#_0ƍ~0}dIb?RԋE̥<ٍEXؘIP@ahǐ~xi'X?ndmËW+zHd=dR N+ o?IUGlٲwk>|0TΗG]p ?3g}Ap%OBϿEsKeޅ=d3|~jVK!Q&M_ $#3~1 -{>䁣55X:[[]FvK)S;995R>AKʟKV'(?YclT灰tJxg}`gI"\vĵBZ 秜"hqfkE[WEgwA흖)iex [h]VjۉI[jYpbߦ̷N|: V')]DR'm,[[Χ {#֝w`EԛT>ODA/տty7X[| w3dĢ}#?nMZ< rK# ,gg(p7;w9/l\j2ϙ[[^Z\*ZƮZH]yO^13q;HHM;;iJ>qa<74%EwRo/Ȣtbwz~ḭr'M+~WCd/Nȶt(쬭 zvpz'H=T': #-ƭ qvW[p!M?g1ZSRp{g杌Zh'VM|OnnEDOt]POK:t*s#-&g؈ޮ}z!GiiPZGKhyA}--#-7S IRt鋥d$ f4|.Tc#+URxn(SY6C'K;7btj'bgG'zU\.JHWZ)=:BD;GHqL@q'W@|/Oߗ&vYG~>A OˮySdE().(R27OwrƐ'q[D\BWmػ=ܱž;| 5z;OEU*cLR!4伍H'*w)VT P;@;8¸G$(.u0Ԋ2Ţ%;F =1C{mtxܼ9bV&k+İdRXOb9u+tU\ʧSb$Yd1;lZ'-ÇI š|T5IkgE;*GG+塢|#=RGu2OV#HB:*Oni$8VG5oؖZm=3γ4:ݭT1v~~8KL~4=/!Q;3y]$>l@;+UNUWظW|r Dl?NzpI䳌'>O@:s IuP?mS]mTox4Cu?i^A;Xz_p?U~p!܊ɞ6"XE]N ) 键CS' qI@s>y(="g61-{8?+^&Yin=ka>&_ ~^{y/nhѲ7yd 2L r}~=GAQ+r?MnR_ngg'NzB"{ \=E**Jk5wӊG'ye8'ɢ>.~Bjr^K̥٠nwgZ6xXsh]G{)(T4S.Fp܉S-$ej&l鑊v:U`nGZ -r۳Ur4zi =؁[\"q'}$ AC@LsQSzn szҹuL?nмhaaCBDxX'I7Nd"JI(4i4ނ;wډ 2=_!VxPsy>'fH? $T?L8#6##zE#h/tU,Z ڱ3&@?yaߙuw%{|;ꔞr; v:bQ\\gGA$%W>|@'=NrL<~|R *ڌPϋj1HX\2<P`U?{o@0K ?~~9\)53Lg3).51Tk.y=n{~ض|>ߝNen'}PMۙiG==XN{IE[&.oņ5O}׮[\⣔v/vaG.'җޑudVVG{Znd4_I$gNɾajQoOLT>cǮz!tK3}k^.BC|-?3IE{B/2GR>{$!~'1ig[(R7W8bdxA(=NV{$o\狾q{&+_?~&3_7>2c[[|.{1~ޣ= ?Kgs@襳u9F {ٺ#㧁3]6$~y kWKz$:{Y:\2_r"fr . %xu 8?Kftrvln~Rz̈)3ØLDo29ϔ_>s~&$s LoϙY?*?]8 f& ɉ48U.37v"'x4`%{˾9ϙ6}F3> stream xZKs$ #KIW|Hv7ďؖ+Rb׬Fݔ4#\n|=h$;tDI Tg*>&Ձ;忳쏇ġU6gzClwm~vx~peN\$$gn v)&߼ͣS4k"lZK2Of0]љA6ECsM*cMρͅM릷b T(}Ѓ$ڳ6# ]lmo.Yc9/ozq7tʯH@Vg}j;H;fKnJLDbCL0y9!adcD$ U{G}Rs7_xJ2q9th8QWZeyTLGlVo9Pȟ<)ə?:[v6k3*$\OU[V\ )w̰#2 g<+Qظ+6-Ϙ Xf'S ́.z{Bgot:s`W0|(~RUs.Msiw٫.U;_D6).BX(c'2AMx)!*o'(݂ S@Lʴ)L[ }_kY!xcqZ msPlc۸NċBS!LmA L-klmhK`UjYR!aE 6M7ar)U_$֓o(s''#"8\߁)~㤘|؁=F¼zr +/|B' y[*@[+ 4p% l)0Ddx`vߒBd0ÒK΁L,!Zaۡx|YMGP@A\@țсI1=Kqy߈aeSA ;$̰ %ݺSq\X`h5vB31l'HeOY{cEsxMZe Bic'X"DYqd+/A^Y/blzu[ /S8U7ZF *y֤huKVpG  +xl|%,cR$F"|#d˕|*`/XLB[1G|K00E Hvb\l85 p͐k`'*aEP;(6?ar榢J90'(a(DGﳹI/'Gq- v6Jq]~B4W ;xR|I=\vbrH><3YF9 !FD{ sF"gRsP=@yc6k_D5b!7,Eީ_~ɤm44:7Zx/_|bRL^kq+PTE@}u~1.=R /W몘tˣhkZ[}`#+:.7^"d+6&Z blmM2t肎&w#&w2KP&r1,adbS}Sox"!\l"P',??J* VQG^;w}:-٠S ֪Wnl~B't(*J)ughxmQoL4\4 KM՝s}lÖָU ^ lǍ#l\eet"o|ZzJ`v]K܉9WyoG{5x'o` RAK>`_ePendstream endobj 435 0 obj << /Filter /FlateDecode /Length 3380 >> stream x[Yo~'AcN>k/v7dj;=\Mv?΀yttk U4*b6!WAu@lMZun=+ $nA[Ҫ[mt!LH;2)rVpqQgC.Cpb렻r W6oi[mŨwaU51e5_TmBRɴ(@>f*a Mhd=1[ ] ʨ_^[Q3zvo ?)3\>8[vh"l71މwB,BFUB}wAO6ؤV`1GU2d糑< 죵YiboUBу.ğԊcQE+d T`tz^Y,: &Fْu~BƒGJ ߘ~!d)pR2YF.oR.3}W'os)!d@>U|DXć(IV (" Hs8{  ('z\1Zwߒ;0JH;/M2qw lH%{dr} `Ի 6j;<{mxF4E-Έn B;(8 GyA-.\jU#w ^X8  lv42q1γ))LMA @Eպr[=sv0ts ?mvQ ku" "X%dʵ@q*LqA\XI,_HdnQ8e &,^wwlv6dĀeT9P'&g܀Ҁ\[9 S}\"Eqh02` :9_K2AHOC[Vvpo78 cсDJ.u=Ҍ^PIFLXцpv e(Y;Q|,VFӶ.-xH{!%K敖l0y-qz-NBO@f}[q4l6dܶpJW:LkI(;만3E;ui'nSR%e"ԫ|M'9w^a8͖pu>cFgf-żf?s0CUby}0^h:S:43 YA %%Hi@̄ 2@PhܮTbTs}hCPpU"sZHN0ZWuVG9{y엎}i=SZ!\ꢒו\UrS_fM7Fpo8g Jn*WeaϠ+Jf nb3͢6[SQI^s%EI%p3,$B֕\VG< hSƒ GZ䧊^1A_}AqԖQf^Fx b6ؤڥ&KF,ymE;-4P dScSYuC7O.+۶6ظ&C} *&k+S q4B;AQEK-P7iSֹgocBdRGPnJsߙIÚȑɆ*y,4mz,(qp*?֗Cϓ|i_tv{Sk;gU/N 9a76FA^.&ODw^?Ծoxh{hksUE%>A`uTw<1Y%E׾_q A|~2"ihj{v&tN@"ն;%:"y>W|N:%y[:8+^ki*4K3K+x!iOЦ#Df'x8z+t|:{[']`H5m` *P5ˡ":YǹJc%t6`hH{kKu%\ j ûBߧwJnٲ(HL<,݅p.v^Im7e߰Q]ٱu*Ա{֌TϬ7?wW{y%9cÆ8C}; 0dH!Ȯ{.n9SUc_6um1Y#U%T*J>oBrBJg|]Ifa=X#- #0W^gƽv~VוT${1jJ#O`ڊ{KCrL,3rW۫۱;\\Ts5Qcq#uJ]M#`f*JP仃SÕ5.::qGG쪓I8e#h$] ]F U[Iǒ$_NL%{0Y%(WR؆! UHLjٶM}(sSA%_ux"d&|[ t4F:J-%w5$A8vO;dN>z/Y,'Y~C6n#$˗o ,m11WԼ vu/⑾ai_aWLnl ~޽)6G-?]vݦMV ~l3ۈ65n6/Z4_Avm@FW}!Xro52ܹ*4_4ڙt!%/YuI4g(㢛tlj~7 RLWn(w~\+4?;+(;AQ.NC+ ~Km2~IBB[o!2Û {VCˆW_<5pI]=7IC>rl嬕^6ʫ(.}"xB"}Tx+_!!ܑs?i IS: U> cwכ%Xl A4\5Q?r fYm" *;*)l$_ 49^6+UPQCH0_endstream endobj 436 0 obj << /Filter /FlateDecode /Length 6973 >> stream x][s7v~W\ ,d&%NwI*u:8]UÈ(G"%/ι4@RS~P\srPg xݓɻ'zxsg"xsHKRg^>OYTgC2ٛ';k%AYgO^U:{.j~A/WϗIYu]ÒѧjYweLqwګmeq~-X\^bn9K);]pZ "tZݽooD1w_C6MNŐbܽߗ%ގ؅>Dv1[`qZ[B@(VLNE%N'C2[|Fz- vEy t\p8~> '"Gzc-wawz/3z?yW"DN ey:hx|\l]jHP6b`h|J,,WSaqf^6YH8:XH ]tu{D\;_"rN\6iH%>%`u Tdst- )Xp[.8T~)9"u~䚄ƧvH)RcbA$~1+2x)@a, ^V߫##h,%1S Ƴgߣ&î$P E66↵ߒ7j S@E7/f~Gsk"Ѣqd\aÎ7w3nr[o{`.U.< ʥ R|_e L\g& /JJT~kⓡ/$PxgFr>/b} [>k vGލu`Ů Q {u^؋ gؙ,q@ljGw2q9Z;{$޴@+XQ3M plj~X{ )w!'gMz@Klĺd#*N~((KLD2#=STh"1n_`z۩҄i"0n9/.w0)8n_"Yr9:vI}_۞Bb\ˊkļ~/Q ,k"G AtZU2Vb̂aRNthUTnП>u:ǙNjm|'m%V Zbbg>!6,2rL)pU:#}e sӎMn6; WZ .It qӻ,wth|Ep[xNc>.>z.zT$F~O!V)j|l/qOD[ɥ&ws质_!wEа4V! Y$*3ѯőBlߒ\+)Lod(r ѥiOA:EPW|/j&X+!ɧXL-wޑkH[gPEr,œM1$iVŃ Kte7Sߘf[عY(; 'M~y1Ù?6&,ʒĭRx- -)Pxmߢ-iNcz÷~ՠ\ ɖ *04RίiB r}פ!FjF~|Q15Ct0J+'%B8Lc%Oڞ׷>~W C$SmpWm߀23Ox>ǻuN'~bbxS/6r88-HY htVmmvF87Gz8R<ϛ5fFQh+yU0l>l0Z/꣩/(>MnH#Y(OC !~1T> \χ8\`[H )$+p*SMSxm@Hs_3Ȧ Ic<@%6N!0kQG]JLD-I.K~'yt'˝E^T$L;$֝Q&AScGb]MIWuT! *r0L[kRV)t'/o4I8 RO]rP26ŧPbW?f.Yz71͵SNhS zIy Lh}SzXAVXMIhc)*+?KJϢuI%6sДkHzʪZ7IQ/x\`\QU2uԢ +M}{q^ڥXW=<̋@XNIlGaߺ稀:Z YIASAWv<ω$)HHE'W tYukTj%'sg˳@q&/ DYΩMl&>\bG3 f;E/NT2so&\/wd׍}9+hKI,:﫷ׄn mYS4 rE`쳬KO b_Tj5T:Y(@_άټ[d)%>1S(3,tNc?˨!+5iDD@ꐜ~Uky,I6y*R0U(e`DM`RKR} &Tኲ1X*ѡ{q\ oY.0j-ȉN>M%4Z}vqdy-fg~6V x&SK̒m⠺׫IUIA2L̗%֨>mJs>^] &#] e$ld9c6AΚW(5VR9JYN^umPuzWBfs-iʶ$:a4I.ast˂胶4 ڲQtW 'VaHdYfYa,>Ke6 e2pȀi~a$*|"Q.O"*5 P\Jf[dߢd*^&ePRXԱ| z~د>P-3o6n.WjrM&8yZ^~by@.H=":xɣ0|q:2G11f*|S>/c ||YG-U;$7jo?L=ۺ>S %$M㱞Hz)ZLWne Ebz~׵d:9y2"뭘Fyu8ˠhҶx*^F1г]W _wmeȨzn fm{<-qe$cbܜa8-6*xX-vuXmp}aeu%T妰\^&E뉾 ,DW#Yh|ۼv]Fq[̓`6EZG[YOJ5qx_t@&1>vτH  <{q,-D,<}۲4O4'c {ɫu!st9XԝN̕z\Z?B}bihٗxeUEJU/[r} Ȅ0Ħuiujnc?<}$j#Y} 9h03XzP׻9$KmM\)]U̜yc-yB_ l%рY]DR d++ݹO=S,t~鞴$C8Zd(~_A&Jn)PJOv^,ޭ\EqFLg|v`TDTkґXD6G^3?:}dz2=z>Syc=0Q|y> 0a0H#Xd .+m}{M}poQ.6)bYFx\L6GbD 9kD*ƹ`"BDŽ؟yEI~YA/ hsX&iA퓴I4Ttɹ"ڮ%5 vo#}L_3Z\8H'mDns+NHwXgKP/5oQ}]Wp6?xRwAC@﹯R[{qI%4e',QvfS3t*TwG༽-6ӽw]|Jq%vjaIxْON?~=k@LJ#> +?`V:/ ~mL .kf_ή;ճ' nHendstream endobj 437 0 obj << /Filter /FlateDecode /Length 4143 >> stream xn] C>k/A - ͥ郓nV*:Rw]- ?xDqs!9ԛ냧::~J^fpaAqzeԫ/׀@XoXo;Qn%[i]wH)'}Fоۮ7 X/t70y#3R:,˜rag;=A!NsX̐NX5 3ݰӥka"[+3Lvmacg(W\JǷ8ylקQ线\S H:%L"Ӣ{E("Mzx= S wB^jБӠNOj#uAE3@F(""`,ȔwA'3c#8Ié}ESr4q&=2E`Al ʔ7Am6*n ,펁u';gҸn{1*Ʉ)UL]E@4[8蜬 D*C?˄0Q1⨗Eg[j(_ΝC{~xF1$a[1I1kWV4cJ Oz4JI/ xUO 8A7t.-OՎ xS=[QkE " gKtQ8A4PS8BX`|@(8'{5$j dƮ𬞋jQ xY x^4En HV;)Ew%j?5W#ob xJ{U2Z@0KO6n'{HR<&"  +k%(LRX&@I} *hs!R=A0[Bhܘ S֒q/8 eOp,y\Uoَm }xͅul]QrX7 jk2{u V8).OrRR ,Vq!%!fqpыI\CI$,i )>U;c"O Ѥ“S5 a5Нsiv\wUrD2f 'B]N1gz,NcX暗T UY*ԘiZr#/aq\aoC-%$lUq^g"P5)!^{Yb,vi3#OݳRv_CkyQe:]~:@Ԩd >+ @(fe]ih8nfVZQE‡a[!{3wԿB:Mx0eU}Fk]l2 ѠcMIvjsM|AHIpH; ҲՒ _'= L6+c\"ʈ]eJ8$9nbZtd O II!%HԊ(PR1;]qKceQ+bWyУx %>/-f($S]|g$+#{[ë¤$:oH,j_KctkK#xӧ=nmMaN .HZbOOVw[vEK3$P_[g'xtQȫ (ȂQN$s#>Nag Ȅ !ZAB;PfAԭc]4-vmCe"ױKgLB5ՑPUE"f{ uiDy8DZedt ^) Vf Sʹ+msB$(wqyMP72QFmD>ӽL9Q64 AW꛴[Z\W$iԄ^{j MxccdMe3ʖJj,A<`|MS`G VLw)B\B@j_ӥ%gWS]nszx2ob ;+,4%9fmA{?̡ko a`qWE6$l 樅a;ni-e xSj6{ME'#i.l*'Csg䬅.+罒"Ene ̫CMĻQ{tɮ ?iTI2iAdDq# ?PpYəzÙ¼}uSwec>;nh:0 >-\^7%)=b_71k8JdL?m2Lxo20ͣgi?Ŏ)릀J/'޾\b\%KK=~p@݊%{{|U°kpޤx6t|\ oh"#RmZ|V`[UD)T)|H;{b$IM4.aݮ-M8f4M/C΂ '?2C:Fz>,='B)%"H=GzɅhP툔yS=IHq}]yXA>iwɈ'x۽ @6ܻw/i t9.P@Ruj8 k>47;A. }oqBU}'d uS B3GNim&yڜ+J9j 5Ro{m f*MKHUH$ilPf>cZ*:x= o x3[`:ImI{Qj+~Q~s7e^/=PPoiMuU 9x1]ö [x>65E8 S^l-jxoxH.abk]Vpw.k[u{)ء=ܖ{H0;s$K @LaRɬy7vǓMNj}o.W-kоr.RK nQ'} 7L NN.aPb¦6oeu 8Įvp&+tקExc߾5Y"si'0SL_*wqmWxu@':pkE ^ĬæHE(.[~pbU7*[n3dz}n^(Gu| ЯeB ڴu+!k&iZZ*maBpkzT5X@;ܤG+C$ 2E{t* D/DPtw6밈=j]"/`of2ne'#z"PPSv/G1'*pZ|Z}u3+u-"|皆t@ҪG Hi}㾫o^FIy@F[ t4&0e3z4Qy{!$pbڐzzP"ش> stream xcd`ab`dd v 5400qH3a#ewgς 0012:)槤)& 2000v00t;gu`Í ʅ|(YQϡ;çg /xk76i?~뙱wh7{r\-< jGendstream endobj 439 0 obj << /Filter /FlateDecode /Length 16392 >> stream x}K.q~'zwqۅWP7d4R8$-hbH&%>LdY=ף+ @ɓ'Կ\oo_z7M9\kiyYex^?}Orqvz.w߼OuROoc>Vv?zk{9J~t][/^vW%~]cԊ\[?ك=x|{{'s_}/EzLW֚zrZwm weͽo?Kn?^oQV)iշZ;rK^'WRA}Пh=*vIW<y]}kOddW۟W-ں?y!n.c[1ֺVe^g}bKL_j_G}%loeQꗿ?K d1Kz+ܷ /<?'y?|㥷R|yזw6"ޤEnyQo[2Eelko}KoѲ= ]Gbvm]&D~>ebz evdiY/륏_7Ci:ZGQe?Y£^o&;y5&iH "-㼂,kZIۈaJǬo!Kiԛ)fte+Q7KtzoiI"a+(c"-}X^#}5t.W>n}Zj=u$[[i@O˰Ss+hDl kX:]0>/Ϗ؋vn[^Y`s[y~IFKVOe]3] U_IɫWn<_I8o}; *8#U?c/ ,1UP~ѪEݿ~,>f@P\=ͮlZԃFi64*ovek,:>Z[ˮ~W% [*p^Z4ƂhASxg>oN0±`p]-cPRJ ɩb 2mIRN CPlVbɞԼ*vPK2Kvd,ałV2Gp=H"jc;*\;lrxp.̫g/bM6{C3 0SK̖EEN*BifEȋIYfQrxgd-[4B6pF\߽Gx0!{@Ȟ"Vr0N9Z Qe:C7gᝳG &MJRH7hM$8Z% -M~Deы@hjtF9+)]nOHh $|$HbSW:kӋ~0f!DriY&D0o֘YVrdǔ7kUOb,V4bE,1hy x9)*p tDHep-eR,a)9S`m-eioYvӉf-̀Q f"-xAisJ&)qoV-LHƑNE>0GF7#GPDF 1*9c2%a]Ø3aI0H~alTcdHvaEŞm?]0}(]Yҧ"|khohH\ E:2GdKLi T`vqҐ1k3EyX L"t.K{WfK^%6y #H"pqIfG)W@#\b3GKfVuD&D/} DP6-JWk#*KKs--ܣT @ZK ;M i L)lY^}Gjw{1 2MWfHwgzgz'WB$$H QҲOH 4NFo>M}Y:!j|?N5> ux3ex{R,!0Hyva ZNHKp 9!tUR(i'.RCm=$d]PÝF.lim!rCLNK]UIYQpPZ읉T HQP y?i9rh"q5\4 [HHpa ̙آ,ђ$x_Z2 4*U(sHxz~xCgܩѐ},Bp! y}*{da<-ӐBv4(rx;Yp'M7^PdOCh CD\#Hrc5aR-yU$RY¬ȅ# @B.1 e"pW$Hb&=0 shH CL##7'19>A2@P TB%@(21 B=ōЉ!\!wF21TB1! C !!R@ ]"SBRN1+T`^Bn"05BDGZC/`H}!C ~!* o2=!t$1y)>BNPߤ S2q>t\Yr:5u\PůBŝCCfbՆp EܦO'g=5NJVo[_o_-!6ԡ(QU*4ܦJVlbۀZRA=맍=@maGQ4mw]qpmʼdje^e!S+2v3/ۊvvz%qұU;u5k]-O[~w[,ї»P AV6uuEFe]VnK`n]uP­@Z;Ti%uw+g5X0b0U} wUd>*2߈*2ߚ*2{Fa8T9T9T9aԌ9QÉLh hL W@^uvJ՘\mvIa_,PQhbs?cd˔sP%UIϒ<QUNwTd֎qjءADT%w1Db, }}褦C-UoCBxbˤ)k #s[dsc.4zBV!1֡~#oUkʡ2^&DS߂xI&@3r1g34%CZl\(wJ-Lm*)yC;}~R1 'e}l3ե:36iZӶRZ. Jq=vTMCאw6V=fu1q۳Lo;gS⸶,Ppz$ :"Oa\Z|Җ¸* ~.qac83qyh%Gk]h>a!HB !FPZhPdCUà ={Y(PáC Ӈ`tUR8R5cP(нe#]@Kw!{W/e/9R< $zP> *RIN1GI%in~MZ!-pfz_*Jm8a]Z*V,QAҢQPH1%2]`\-^v۸,y4wq;Fڤݖ ` КҎ*l;Z\_Zͻi{Sgx`fOZhwdj6~]{{Pb=޿j5mIzF$-})ieZN u(Ҳrbi/i-%~$?y _/ A˨+`$ъFugp11,+pXV@#`3u4JhȀôQY@@>:u"WӬ#]K% H}z6`# =%+\1Ggr(ZoҮSA8Жi},armydt &@dT0ݶA .:G 7MRZ3T7'gq]K{Q׽#@/=hyՉ*-7H 1x)Gx)_k>mNvw618@ix)f /ux#~L^mcמI=g?'=\[51=T꬘vz 7KUstxp%=ѳsѪ$}ex݄u\j۶ŗZQ<=JG+BICTIMOg$t~>DZ^F7cz@_Ͱx.h9>K(EcLq³l1o>?QF%̺Ba+q ) Ѱ(;.m7 Ѱ(; ?QK,;ݢ_i ǎ3*% 3_4QvE5eE7gcQް1 :7qNUf_MHh њhR|i?spI5e| BT**#W͜v+# } {Ћ22wqwo=[4xf05/oFEaCVǥ{6;47?^Abs0sI]ZC&dƍ_3JHEUc#/[oKRP:U#YҖL!2Y ,@xdɂDg@eQf N-H1[ Bȴ8B ֋l 1i1eSZ橭EIszakØ-H˩_Ra\Kȩ;nװJɜ-T]<)ǎ 򧢪.뿿Lؙ(QǠR \, 5} X9 g.x)ĚK30X~d@E0X7 p tXUS2_vz3_ FZHl57GNt}|LH3-,B`8/Pr<nN(#]@TH˥P|gbt1*Bb]Zj;̴ b{^ZM`<-0 \9td!-z3 i=1]b7 <,bN ڂXɈvL>8YZ}%~Lb ? pw8D7/8_e6p^ ő/shx>q~LCҨЋ?b QDR/5kK sй:H=Y c\=NHd|kK\"Nw)s-nEJWEQ[a (PsN zLY⇬kQ!k ۊ!k/2@Ws~_~>LOa6 !禋WjSçE+ |:Vӵ6VK d{2ޫV,ֻwZ,-W='QwWm9{^Ry1a'{U6r/*:/BIRUz=tc/yoe1k^(;|x+[Q"KQ,֗001&Sk߉q{;]3&=|߅CU,w*SUh<(SߩU12~.I0ťܶj)wP8#tСߥeDr߫.-rObLBd@g[ D1WRC+⻤hR4.{UY~$γth~?$s`ʂ߱r= nF|az&ʵgySp~j+7?mOն)^@Ep=ayU-/:~$wbR6G?c{Uuzi=ٗ0&0!/`,Q(0όﴅ 0æ`vZ߹"(+$0$9ZKf(+pۤ&@Ya|'5B ;`jUw`QR0Ӓvؘ(<((M߁I;h)=,$ {$AP6<"YKS|GP?|'!d?$e/y "G2Ď3,9/1gSw3i4=W|EBhΜgnت}5uA SM~eDFR-]gF KG\u=qGMZ X{傤IZ6OnG3;)MZ|k~9*5'3kTojx)v?<ަykޗL,?t;'dK.Sy~ʦ|Rq&:N/ɻDZa١T4RڄP\ElSڄT0 3|vMuS\PAѼ:%IH`!GG24CioǍ FĘk$nXQ=dyy8ஞ/=.8^*Nǔb~V$R ԥԛp'=̛pW=:&UxW]U7aUkJL0_O7z2NZn /8ljFs8lëJstZ⵾vD;VO\z&a6[%& MD'& zIʠ;! v0!7!A v&Ę`gLĘ`N8!fC/iXILb Hڴ!'JUy_ԮáP&ʋD~8#O=hj(mWhO쉨3odrڣuUA$قTGO۶֓tmmS23%8إ3?ߊ]obγ$K&Nγ51Ө%N:988>k瀄|V#D1tkh~e/>qd߃|x;x5#_@RuAƕke2m||?聆J'֗f>M>QK22`ODF$&;|> a1Gj馊~8Qk/[8xvJ[W9. AVKtWOぼoigV !4U/Ur{x:NHi]K­#g$\h4>ωOy&8GYpQ]Q8U: " FY,q უQ_F(IN׋QFb2F#G+F#G/wxM;:*럿/-oߔ7˟˄UT=֠z܇kaX7v%Gk׬~Jq xM-<އ qVNk3όhXЂti 4Kń4cKr'vIW=^] shaH ?{6:/E^o?1G50|c$E aXվu1p;cc5t<l2}Q~52] s:FCkZfo rE9p^wKeMi\# 5ӒsUӃ,{ankƛ|O˽25LMr>\:y|M2jq|^؝CZuhYi~$!X;k+AnG 씦=/ -AF?go荂em͞7X+ⴢy+e0#tngUsp qn_G]{0N؍h%qJB݌;++z"֞teA}tS9+X!1^ؾ19:T{~5FU{١לc(L\w1:?ړ^8l)\إ"m6#۷RkA?]IUSJ-t}ף~3b9tKw:TOY8qg;G\>>.a@JѦ-|j&0d?Me7E "Ũ3Jtܰ< r8XgSʽNt螩y.*/wZ~ae;,tj5A{.0Xll[hEi7S$+2냏qr}^ HG( |w/AܐG*űLbwGL#ænh0=_if-Om&BsW!Q\[i +=qox>B_Q.zH=E@DCԍQEdGA YS%MZ8hQd%:2Z& D' hHkkpG::,9OHp $dHS D+])10՛QXQ>k2h얮#5U__\spdg $zȽk9f>z=:HS ;)j8Y3-w0nhXwi*2fmٙ0| aƳȏA1A6411-z3t'7e]2G`nFZ65K cCt  lO8Ot NM~)959*ʨPU~:OySP6Lr 2G w&{@0{J&x G 01$LG&9F ;@H [A {Bh CLTC,Ma8ȧGj:y"tNO#m j>M$&瓩y̻L>o- ~MxAN)evU)}D'mp,Jmaq>=􆠇D2覀Do; 0y>yg=WK\]'ݞtvfG2G#e5RMfc,9\c2/# $q;۶ p7dKIA ݳ[X.j8>3J@Pkfdүb;6S]!,~[E]2g ؙZ_W=BTk cYAc[a49'|eF-y#_?@w7Ҋ04O2G"I{U绞d)@}72fP9'p<>w{މ)=u⁴)3#($n 7}ҳKlϺd;Cӥ7*Q=@3\KA SHYpB6E{BdKl vHDi<ɱh$>yOӓo.֌SUܕhBū{__,5m}aMm3ČtryP#7_%n:RhJpU'2Ώ:'U'2ݠCxY_]Zt y$$1χT2;g"&aQykQj!!7Գ8#7#Z8Аq`zV\tVmYG_󺮪>#v=F#WRΠzpක4tihQiauڲgnc"A,HCO' })$+F0q2M Ҁ` Di>50z6e 7Ps؃J`jq@Ƥ'‐ueSI\!_UT9s9ǭ2"~u4ypJf^˲}N5 V2?FϪ7[fw|#C\{""ĻT)vF#88&8SɠÎakGYk}(bXx؃][l̯ۿn>K㛌\>ժ->"e弑2pqU;2"0kkX_Ή `7!-g"EɁYW&n mף9p+cN"n]~5 . 1ewW(V[ w*FBhU*bGU}h004%F@ ~cs_Du{jv )"j#"s<1 @9;WF8H| V9EOS bibz=z"vJ_"v=V4~_Ox\zDcg>[41^cS@0ZW0=s !bVSlݍ)(h6``f %泉"|?]pe( (2-ϝ6sOd!EDd~}(h_wbJ%_RL7 i]Й Ct/SbRȇ_sY~[ژU=}ҙU>8ҿgq6uJv2`DĂ*:7q]WZ:G<x m޵e~uUdBK*A&9[a܄6Mh闋ub8UZ*F5gJ۟죓pGAi[(!f4!z<o^¢BC s1l1?-C3fnܱb#c嬧׽9se +҄AfK@R9jOSlt2SaNJj*Qxp]y@׍l̸1>+T}PX~V=7R:N/Iwӓ/ݯ{ &¯J?9MvBӢ"d7+{>VB+RAb1΁t)Nd\々vt9xy hh| K4Iή),ר@OaFwSX!yv#>>2),<章%Q؟8WSXxOaU^SXxU:W^|O\{O|8sX> qJcˇSXI ]%]+jz?^EpOz>i_^IKksQ !嵌?ʹEn9~ISV~(#1/i5V~&l~>:W`W"> Oq~OcHS}WəSOwƞbroW7/m)endstream endobj 440 0 obj << /Filter /FlateDecode /Length 4006 >> stream x]o]ҽƷF] E؅ۤHpIkI$wýY$-R~`=3<(zy(Ow/;<ód#hAZ*<m.:Gd)do5Go/jTC:^([Lvamvd ?#=))=#{`Lo/T 1߽msD0B`w -h,؞ Ը̆0 ۜvJ <,toK}Xj'= ~w7r$Bmu$TZxu wm~ ?|KJWNra?B:a@}0B o cU,Y) 6QΈtN WR^T2(R{k޹ %3&t+_D2n?r 몂Y{|.IંIUۮb< ~ W~!,PڀåԽ5A% oln+x\#qGMmIq_W +PG?e%-r [[v PY}'eCb|Z[D%]VGbUWT1.{T;[$[U/Wl=.a~%9?վٍkK6ۨH(D@{~p۟8/Q 8Fy[^"# o(e)Td -8]YS^#^#tXausF}ɭQi8j]LF1""&1&>b"aPBLTsƻfArKQZ s/?*H ~^/xHE~mTUZΈo~ &Zpjmn--Y ?H' @ #.JJ̀(buE?RE2U8 ^SqG?pV4Ĺ<>jms,Qe^?jaW -!! H[`ز MY9n?Txd5+VD$9SbG|RþV'ȩu&Yku֫[Vh|{&ĵIbauHLȑD!g;fAD@sI-dozk粳X@^n֎㉢rV",~*;gDz/PȮpJ\C=b7||=e][6/NJK:EGSd28B!n=TN>L_JEyu>o>s vi%ӐGvZyiLͬ#s8Bfel9Ik*$H($:jI鵕3jPY,,9&nƤY .ΐAJpa25[fʹi 4p2__)v*/⨺ls]Ag :3CfفxT_Ng\Uyb{x9ؾ.G4k]%pElBu/0hg#+G٦Cz<4>@)#8W46!WIRD<1eFȚ|=&ěq+[mӎ: s.K|sDpX䎘郖1p.+#gaa]v@Ra;!tB8.*8ȃӒ(]L*f-(@c,"eP1;;F;"ocs$ >Yd ! "Rn2 r,\LO& XI]# }Ǣ~PJ*K7euĐ G@;7TlF-# ݐ&IB[i~5Zk6{) b%BWHb3A$ 7c,D] RP;޼l+^KLZ|xԔN iiVQRV^2biEIҢ1觑|Pw69; PDŽtI<-ma:ُ/Kg":q2셸Iq;=Γʀ7 2buቱJb6[IއPTil3a^0 /'y3ff4\jBah؎֤ۙI$z%UW$A "S[EWFH1OKr 2+'k!@ZNCniNSӻX9ZA^cf% PRONnqu^(;7YU,UɳO*t=yʿ~o?_%;YL ӟt-/y=K! n*xRk ˡxp5h"ꦂk, ݓik7&f+;GMlڜ!]Ss3-B^;!HZ.Vs5WW :q5C+X;fX'yI*ZP4I]<^DqӇL~:*gw.ƕׯƯ֯M$}5H=e.91>W H#Q_RCHÝf8:`-RBRG.T>NףPbC2 ki}h9.>`(TxfPG2X -iθC V{y:,̅Vj['˱~gx\4u=CT,5-bOz@.gi A˱݇)G?fRendstream endobj 441 0 obj << /Filter /FlateDecode /Length 1529 >> stream xXˎ\5Wܥ[*؁HIZdX43MHΐ΄S}v&@Q4s\O, N?NO8<}q կ4|\d+4ڴ4P6PRHp-XX"M%`)Jeo^`)8esy\C1۝O֑'%8%s WgoGC,bUs+\,c<Ÿ#UsfGĩr()%% RbH bnof1Jdll3Cn˭=8d7ͅI·ƥgzJa,ًa/܇b¿ICMu Ͷ FHXW,Q87D5%w?k<+[흀e!E&lLE=z&F5OCl1fGˍɆ \pc!!@o "m'4$^q7"R܄pr.ڬbEMh_oH \P[*YC骮8 "]y` Uhsy$Ҥ};V0VS T4mK1 3Δ#g7M4e;u&5cF˃Ewۑ_\2?VwgwWˈߍٿa>GnBQՋ/)J]cJY\{!odendstream endobj 442 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1245 >> stream x[LgǿS:PNP}M$6EtGt enTUZJPjK KBh) ԡIJrٝf9V>ovM+3qMdGiD!Dq 7p޳geݏZ4g+|d2灚FAX٪rFP<i}> stream x\Ks9Vi'x?!ĩf*;\O74fgV$.ACG_70|{$zy$_j;:[ۅL=\zH"ʣ+ [Gm?t]EӭoQE.+.UzTw FzCw\i'}Z.WB*DcuNiխOn$BzHae0 Y;2F :(\a1׭層R9XaW02t1:뻟Rta1Viv|a][C o=qhQ :"c@"TpMhd^{wI2t1(s}\ڂo.VȣTb ֯p)X*^hة,WF>:R[:ZAuk&su37mIgef(&fg#sDrn\($A5/q?kv:$ 9$ijk[@O;U A %̆V6W͂&Yw4ufN3A~fUɓuRi e  )reQX|?D2fvrW i`m$jgu`<7х- >6>60MAޚhfv.A]=c#M O+NnҾ4iA4kH>ioLҴժZ7X5M焚$=;;ఽs6NjuZU6Ajm)12Ua F~g)"y r"Fa]E!LQK]b:ІDŽxQ_xxϙBϿ\{M٘D4~[= ^ڱ@fvB pR@ot EBtiTSj; JoDՈLdjia<$adnmSov!'!*!8vVʦ>2w gLhv?9u `QƉ`C$e$ 6z@Q5q5[x_.ĐpH ξ("h{^Bkyc/ESf68וN F>@Mc HaDؓ !aF*RJ!-wjtA0WGoypKRR{Ʌbse:z4lbPp9oY6v==̴luKlD R fVaxSj) V9$]:[dU+uuib[S`fs]X eS6 qWgA`!8.4Di ɷݱja.VF4"N+ԑuQ1%V:{!VIA d89N=f.qh}E+ĭ7%e;. <(Nyx R1V3.?̻0qf[sm`wRJ wߩ (\rkяsė΅gm}u}|EYpg1cTQ8:`d_6㹗kd*D ůY?WI X"*hXDba- @oڧrpA$6oMyc T5, l6Z":/ۭXFr*zzeY椕UeTId%,MHŃgifjδzLi-s}dw8{t@東8S}[D 0vvI3YYq$.Hw׃X4oMs*ə '/5r(:W`o,ŘӶ9=AI;d97)ĺ9Rq(6,T6#ڨ<6+yNT&)N&Uy P`1`\G%U*3ۦzt_*͕ˬH'zS@kIπF4L#I=lFD3%yE3(;jf!KxEUT.͕Z*yUdӠ!'K*hMce Oixz>c\6Ϩ3 5 SiJ[^̡TTr#ӤQM*MiA:;:%W7M*чuqcNK6Ny顪U s)* KX +nKVn4n!Ѱ4Mg$>'W>ܔP5ӣ^v I  o͸h$E^<6Wu,U%GL@4)&ۖ%(/G1pt!t̳A/%zY}E5uv@zTރJRPE 5.GtETUTA\QU{Ka얣Ȋ.KBEjT3GZm )r) JG=.yo"9fO1'NC3epx7DSM~\V$ܵ`/2 R{5nOO2P M21'ay|M7u"xu)5gFf+r0E ^ɴ06 t±u=qbpr%敪_V*TV5g]98Vj Q;-؝1g4v)}R$7cW>Vh_SH|`][88Z:^*9jϦV^K;JqM} PI-_NB8D*qZ3\-O3jid8 @൲Lz6[vw `ۣvtLTIT1ptLDϋJ~6o|w%J0T05#FPi\0٠2{8Q=xO8",E$bukOݹ9PwF)0FgϗY^fVLk Plc.J́WlW6ZtEBQ]` Ҳ &0 BT"C0{S:9$lQ~>I}CUl2ҊJ qej_sM 35nMPtUhwY:|]ap~&} ECR@Ϫ` }ЂVcH( , 6/-s`yI6Dq_ Ԫˏ!sc`Z#9P_Ġ=T3D07_"q[Kk]i21:)oOg{i4TÎ"zvEp 'Lz9}垼y:*$>>Z=+TiUh*o^ñVi6}$e!v-t{=^5OYuc]/O._ D`l #Oשt W{l fy?!|a:yyj'X3(%AWk. Of p /QhYHYݚ~E|ַs4^-!2) r;|yendstream endobj 444 0 obj << /Filter /FlateDecode /Length 2104 >> stream xYMo5+]<6qۤI IMRJ^{ٕZzA=ufg^GIg?w?o3o(#.S88zǨ @bS{Wh@y1ʍ6(#NLWχuϾ#~9|(#уH^3!10JQ6נ)柕{ i?N^l+1_s Pe2ᤵF)BpJwCCUqejAt$6>RC }E BNE|!q㎮&['2 =CF*W UbzH"Y9>stAJSTEOMLޣUǓ !Wgd]AA0om-( [.FbZ;Yrҡ&d&} lXe>蓩e6Dx)t) 8eߤ祒 %S+7}vG9QB0hyުP`CDCVK>#Uibtx&dTE_b5%J0ݬ9;!d:$P̾CΌVuY1 \)IX" :Zͫ8-@DPqSE"%j2oMp4t]`{1J*υQS y;AS&.=jt#+A>'HJtĔNiô+Lpڛk77ў '.os-^ Rb-B )^LS(rkLN[jEt vLN.RE~mĻl\y#4DI})bHZKR DgJ`>>5lg;Xxߎv Fw1n3=jGV 'JXp OB!@aq0(0& =>I{دiR* qjǫt f߶܎Ў/|@r&7$)Aoqp0XEǛ"#B"ETGc)>(s8l}nyĔbYU%BZ)MR*I礨3z-h"2>Ň[" =e:-f2i4Qr[RKLnc_Ȃ`f:yڛ‚>BSO8l"}6JB5..CJf`uy0APi yuƻvQclG GA{}. H!̪+7V}Z h`5f"um)nNf0M N'.WgG? *C@ΙY[@zdzjk43-Dv:# Vhf/KpₐGsIŶX-6vbu~iZbѺ`H[v"۴s|-LC2j=VYJ =ܕiodmm8G- 9SmZI1MG?!c>Cl$rÄ́G+b'1haz4!ȕ2R.)2˄t:/!Ѐo>!%\UV+\L߃)G$8 EMn-%g>+f!\ģÒyNSy;}z-zonv9|(̠kb%FCCQ܄It8 筠0d ^W]ꑭ(YmRA#x Iv(>#bfwcJb\|D k;P:`!Uoҡ*UM֛z}/^3{=4NTwe_SQЕTJ{Y3Z5l.J`1R\%X>tSSz10כ/r/qjGTRpl׋AkĶbrLZED+<= |vendstream endobj 445 0 obj << /Type /XRef /Length 351 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 446 /ID [] >> stream x+q4ݝݕe&)%&Z"$8(Q]8r#֞$7' W+.&'Hf<2La)azzۈg؞О<=OsYwCn CRڐIoC<"ɹqՖ")Û ") options(width=70) ################################################### ### code chunk number 2: deSolve.Rnw:181-184 ################################################### parameters <- c(a = -8/3, b = -10, c = 28) ################################################### ### code chunk number 3: deSolve.Rnw:192-195 ################################################### state <- c(X = 1, Y = 1, Z = 1) ################################################### ### code chunk number 4: deSolve.Rnw:222-233 ################################################### Lorenz<-function(t, state, parameters) { with(as.list(c(state, parameters)),{ # rate of change dX <- a*X + Y*Z dY <- b * (Y-Z) dZ <- -X*Y + c*Y - Z # return the rate of change list(c(dX, dY, dZ)) }) # end with(as.list ... } ################################################### ### code chunk number 5: deSolve.Rnw:243-244 ################################################### times <- seq(0, 100, by = 0.01) ################################################### ### code chunk number 6: deSolve.Rnw:259-262 ################################################### library(deSolve) out <- ode(y = state, times = times, func = Lorenz, parms = parameters) head(out) ################################################### ### code chunk number 7: ode ################################################### par(oma = c(0, 0, 3, 0)) plot(out, xlab = "time", ylab = "-") plot(out[, "X"], out[, "Z"], pch = ".") mtext(outer = TRUE, side = 3, "Lorenz model", cex = 1.5) ################################################### ### code chunk number 8: figode ################################################### par(oma = c(0, 0, 3, 0)) plot(out, xlab = "time", ylab = "-") plot(out[, "X"], out[, "Z"], pch = ".") mtext(outer = TRUE, side = 3, "Lorenz model", cex = 1.5) ################################################### ### code chunk number 9: deSolve.Rnw:316-319 ################################################### outb <- radau(state, times, Lorenz, parameters, atol = 1e-4, rtol = 1e-4) outc <- ode(state, times, Lorenz, parameters, method = "radau", atol = 1e-4, rtol = 1e-4) ################################################### ### code chunk number 10: deSolve.Rnw:335-341 ################################################### print(system.time(out1 <- rk4 (state, times, Lorenz, parameters))) print(system.time(out2 <- lsode (state, times, Lorenz, parameters))) print(system.time(out <- lsoda (state, times, Lorenz, parameters))) print(system.time(out <- lsodes(state, times, Lorenz, parameters))) print(system.time(out <- daspk (state, times, Lorenz, parameters))) print(system.time(out <- vode (state, times, Lorenz, parameters))) ################################################### ### code chunk number 11: deSolve.Rnw:359-360 ################################################### rkMethod() ################################################### ### code chunk number 12: deSolve.Rnw:369-370 ################################################### rkMethod("rk23") ################################################### ### code chunk number 13: deSolve.Rnw:383-404 ################################################### func <- function(t, x, parms) { with(as.list(c(parms, x)),{ dP <- a * P - b * C * P dC <- b * P * C - c * C res <- c(dP, dC) list(res) }) } rKnew <- rkMethod(ID = "midpoint", varstep = FALSE, A = c(0, 1/2), b1 = c(0, 1), c = c(0, 1/2), stage = 2, Qerr = 1 ) out <- ode(y = c(P = 2, C = 1), times = 0:100, func, parms = c(a = 0.1, b = 0.1, c = 0.1), method = rKnew) head(out) ################################################### ### code chunk number 14: deSolve.Rnw:438-440 ################################################### diagnostics(out1) diagnostics(out2) ################################################### ### code chunk number 15: deSolve.Rnw:444-445 ################################################### summary(out1) ################################################### ### code chunk number 16: deSolve.Rnw:519-527 ################################################### Aphid <- function(t, APHIDS, parameters) { deltax <- c (0.5, rep(1, numboxes - 1), 0.5) Flux <- -D * diff(c(0, APHIDS, 0)) / deltax dAPHIDS <- -diff(Flux) / delx + APHIDS * r # the return value list(dAPHIDS ) } # end ################################################### ### code chunk number 17: deSolve.Rnw:532-539 ################################################### D <- 0.3 # m2/day diffusion rate r <- 0.01 # /day net growth rate delx <- 1 # m thickness of boxes numboxes <- 60 # distance of boxes on plant, m, 1 m intervals Distance <- seq(from = 0.5, by = delx, length.out = numboxes) ################################################### ### code chunk number 18: deSolve.Rnw:544-548 ################################################### # Initial conditions: # ind/m2 APHIDS <- rep(0, times = numboxes) APHIDS[30:31] <- 1 state <- c(APHIDS = APHIDS) # initialise state variables ################################################### ### code chunk number 19: deSolve.Rnw:555-559 ################################################### times <-seq(0, 200, by = 1) print(system.time( out <- ode.1D(state, times, Aphid, parms = 0, nspec = 1, names = "Aphid") )) ################################################### ### code chunk number 20: deSolve.Rnw:565-566 ################################################### head(out[,1:5]) ################################################### ### code chunk number 21: deSolve.Rnw:570-571 ################################################### summary(out) ################################################### ### code chunk number 22: deSolve.Rnw:604-606 ################################################### data <- cbind(dist = c(0,10, 20, 30, 40, 50, 60), Aphid = c(0,0.1,0.25,0.5,0.25,0.1,0)) ################################################### ### code chunk number 23: matplot1d ################################################### par (mfrow = c(1,2)) matplot.1D(out, grid = Distance, type = "l", mfrow = NULL, subset = time %in% seq(0, 200, by = 10), obs = data, obspar = list(pch = 18, cex = 2, col="red")) plot.1D(out, grid = Distance, type = "l", mfrow = NULL, subset = time == 100, obs = data, obspar = list(pch = 18, cex = 2, col="red")) ################################################### ### code chunk number 24: matplot1d ################################################### par (mfrow = c(1,2)) matplot.1D(out, grid = Distance, type = "l", mfrow = NULL, subset = time %in% seq(0, 200, by = 10), obs = data, obspar = list(pch = 18, cex = 2, col="red")) plot.1D(out, grid = Distance, type = "l", mfrow = NULL, subset = time == 100, obs = data, obspar = list(pch = 18, cex = 2, col="red")) ################################################### ### code chunk number 25: deSolve.Rnw:672-687 ################################################### daefun <- function(t, y, dy, parameters) { res1 <- dy[1] + y[1] - y[2] res2 <- y[2] * y[1] - t list(c(res1, res2)) } library(deSolve) yini <- c(1, 0) dyini <- c(1, 0) times <- seq(0, 10, 0.1) ## solver system.time(out <- daspk(y = yini, dy = dyini, times = times, res = daefun, parms = 0)) ################################################### ### code chunk number 26: dae ################################################### matplot(out[,1], out[,2:3], type = "l", lwd = 2, main = "dae", xlab = "time", ylab = "y") ################################################### ### code chunk number 27: figdae ################################################### matplot(out[,1], out[,2:3], type = "l", lwd = 2, main = "dae", xlab = "time", ylab = "y") ################################################### ### code chunk number 28: deSolve.Rnw:720-730 ################################################### pendulum <- function (t, Y, parms) { with (as.list(Y), list(c(u, v, -lam * x, -lam * y - 9.8, x^2 + y^2 -1 )) ) } ################################################### ### code chunk number 29: deSolve.Rnw:733-734 ################################################### yini <- c(x = 1, y = 0, u = 0, v = 1, lam = 1) ################################################### ### code chunk number 30: deSolve.Rnw:737-740 ################################################### M <- diag(nrow = 5) M[5, 5] <- 0 M ################################################### ### code chunk number 31: deSolve.Rnw:744-748 ################################################### index <- c(2, 2, 1) times <- seq(from = 0, to = 10, by = 0.01) out <- radau (y = yini, func = pendulum, parms = NULL, times = times, mass = M, nind = index) ################################################### ### code chunk number 32: pendulum ################################################### plot(out, type = "l", lwd = 2) plot(out[, c("x", "y")], type = "l", lwd = 2) ################################################### ### code chunk number 33: pendulum ################################################### plot(out, type = "l", lwd = 2) plot(out[, c("x", "y")], type = "l", lwd = 2) ################################################### ### code chunk number 34: deSolve.Rnw:782-795 ################################################### ZODE2 <- function(Time, State, Pars) { with(as.list(State), { df <- 1i * f dg <- -1i * g * g * f return(list(c(df, dg))) }) } yini <- c(f = 1+0i, g = 1/2.1+0i) times <- seq(0, 2 * pi, length = 100) out <- zvode(func = ZODE2, y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10) ################################################### ### code chunk number 35: deSolve.Rnw:807-809 ################################################### analytical <- cbind(f = exp(1i*times), g = 1/(exp(1i*times)+1.1)) tail(cbind(out[,2], analytical[,1])) ################################################### ### code chunk number 36: deSolve.Rnw:822-833 ################################################### f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } ################################################### ### code chunk number 37: deSolve.Rnw:838-840 ################################################### yini <- 1:5 times <- 1:20 ################################################### ### code chunk number 38: deSolve.Rnw:847-848 ################################################### out <- lsode(yini, times, f1, parms = 0, jactype = "fullint") ################################################### ### code chunk number 39: deSolve.Rnw:855-864 ################################################### fulljac <- function (t, y, parms) { jac <- matrix(nrow = 5, ncol = 5, byrow = TRUE, data = c(0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1)) return(jac) } ################################################### ### code chunk number 40: deSolve.Rnw:869-871 ################################################### out2 <- lsode(yini, times, f1, parms = 0, jactype = "fullusr", jacfunc = fulljac) ################################################### ### code chunk number 41: deSolve.Rnw:878-880 ################################################### out3 <- lsode(yini, times, f1, parms = 0, jactype = "bandint", bandup = 1, banddown = 1) ################################################### ### code chunk number 42: deSolve.Rnw:885-892 ################################################### bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } ################################################### ### code chunk number 43: deSolve.Rnw:897-899 ################################################### out4 <- lsode(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) ################################################### ### code chunk number 44: deSolve.Rnw:905-906 ################################################### out5 <- lsode(yini, times, f1, parms = 0, mf = 10) ################################################### ### code chunk number 45: deSolve.Rnw:937-943 ################################################### eventmod <- function(t, var, parms) { list(dvar = -0.1*var) } yini <- c(v1 = 1, v2 = 2) times <- seq(0, 10, by = 0.1) ################################################### ### code chunk number 46: deSolve.Rnw:950-954 ################################################### eventdat <- data.frame(var = c("v1", "v2", "v2", "v1"), time = c(1, 1, 5, 9), value = c(1, 2, 3, 4), method = c("add", "mult", "rep", "add")) eventdat ################################################### ### code chunk number 47: deSolve.Rnw:959-961 ################################################### out <- ode(func = eventmod, y = yini, times = times, parms = NULL, events = list(data = eventdat)) ################################################### ### code chunk number 48: event1 ################################################### plot(out, type = "l", lwd = 2) ################################################### ### code chunk number 49: figevent1 ################################################### plot(out, type = "l", lwd = 2) ################################################### ### code chunk number 50: deSolve.Rnw:983-988 ################################################### ballode<- function(t, y, parms) { dy1 <- y[2] dy2 <- -9.8 list(c(dy1, dy2)) } ################################################### ### code chunk number 51: deSolve.Rnw:995-996 ################################################### root <- function(t, y, parms) y[1] ################################################### ### code chunk number 52: deSolve.Rnw:1001-1006 ################################################### event <- function(t, y, parms) { y[1]<- 0 y[2]<- -0.9 * y[2] return(y) } ################################################### ### code chunk number 53: deSolve.Rnw:1012-1017 ################################################### yini <- c(height = 0, v = 20) times <- seq(from = 0, to = 20, by = 0.01) out <- lsode(times = times, y = yini, func = ballode, parms = NULL, events = list(func = event, root = TRUE), rootfun = root) ################################################### ### code chunk number 54: event2 ################################################### plot(out, which = "height", type = "l",lwd = 2, main = "bouncing ball", ylab = "height") ################################################### ### code chunk number 55: figevent2 ################################################### plot(out, which = "height", type = "l",lwd = 2, main = "bouncing ball", ylab = "height") ################################################### ### code chunk number 56: deSolve.Rnw:1066-1068 ################################################### times <- seq(0, 1, 0.1) eventtimes <- c(0.7, 0.9) ################################################### ### code chunk number 57: deSolve.Rnw:1073-1074 ################################################### eventtimes %in% times ################################################### ### code chunk number 58: deSolve.Rnw:1081-1083 ################################################### times2 <- round(times, 1) times - times2 ################################################### ### code chunk number 59: deSolve.Rnw:1094-1095 ################################################### eventtimes %in% times2 ################################################### ### code chunk number 60: deSolve.Rnw:1100-1101 ################################################### all(eventtimes %in% times2) ################################################### ### code chunk number 61: deSolve.Rnw:1111-1114 ################################################### times <- 1:10 eventtimes <- c(1.3, 3.4, 4, 7.9, 8.5) newtimes <- sort(unique(c(times, eventtimes))) ################################################### ### code chunk number 62: deSolve.Rnw:1120-1123 ################################################### times <- 1:10 eventtimes <- c(1.3, 3.4, 4, 7.9999999999999999, 8.5) newtimes <- sort(c(eventtimes, cleanEventTimes(times, eventtimes))) ################################################### ### code chunk number 63: deSolve.Rnw:1152-1186 ################################################### library(deSolve) #----------------------------- # the derivative function #----------------------------- derivs <- function(t, y, parms) { if (t < 0) lag <- 19 else lag <- lagvalue(t - 0.74) dy <- r * y * (1 - lag/m) list(dy, dy = dy) } #----------------------------- # parameters #----------------------------- r <- 3.5; m <- 19 #----------------------------- # initial values and times #----------------------------- yinit <- c(y = 19.001) times <- seq(-0.74, 40, by = 0.01) #----------------------------- # solve the model #----------------------------- yout <- dede(y = yinit, times = times, func = derivs, parms = NULL, atol = 1e-10) ################################################### ### code chunk number 64: dde ################################################### plot(yout, which = 1, type = "l", lwd = 2, main = "Lemming model", mfrow = c(1,2)) plot(yout[,2], yout[,3], xlab = "y", ylab = "dy", type = "l", lwd = 2) ################################################### ### code chunk number 65: figdde ################################################### plot(yout, which = 1, type = "l", lwd = 2, main = "Lemming model", mfrow = c(1,2)) plot(yout[,2], yout[,3], xlab = "y", ylab = "dy", type = "l", lwd = 2) ################################################### ### code chunk number 66: deSolve.Rnw:1223-1235 ################################################### Stages <- c("DS 1yr", "DS 2yr", "R small", "R medium", "R large", "F") NumStages <- length(Stages) # Population matrix A <- matrix(nrow = NumStages, ncol = NumStages, byrow = TRUE, data = c( 0, 0, 0, 0, 0, 322.38, 0.966, 0, 0, 0, 0, 0 , 0.013, 0.01, 0.125, 0, 0, 3.448 , 0.007, 0, 0.125, 0.238, 0, 30.170, 0.008, 0, 0.038, 0.245, 0.167, 0.862 , 0, 0, 0, 0.023, 0.75, 0 ) ) ################################################### ### code chunk number 67: deSolve.Rnw:1240-1244 ################################################### Teasel <- function (t, y, p) { yNew <- A %*% y list (yNew / sum(yNew)) } ################################################### ### code chunk number 68: deSolve.Rnw:1247-1249 ################################################### out <- ode(func = Teasel, y = c(1, rep(0, 5) ), times = 0:50, parms = 0, method = "iteration") ################################################### ### code chunk number 69: difference ################################################### matplot(out[,1], out[,-1], main = "Teasel stage distribution", type = "l") legend("topright", legend = Stages, lty = 1:6, col = 1:6) ################################################### ### code chunk number 70: difference ################################################### matplot(out[,1], out[,-1], main = "Teasel stage distribution", type = "l") legend("topright", legend = Stages, lty = 1:6, col = 1:6) ################################################### ### code chunk number 71: deSolve.Rnw:1292-1296 ################################################### library(deSolve) combustion <- function (t, y, parms) list(y^2 * (1-y) ) ################################################### ### code chunk number 72: deSolve.Rnw:1298-1300 ################################################### yini <- 0.01 times <- 0 : 200 ################################################### ### code chunk number 73: deSolve.Rnw:1302-1306 ################################################### out <- ode(times = times, y = yini, parms = 0, func = combustion) out2 <- ode(times = times, y = yini*2, parms = 0, func = combustion) out3 <- ode(times = times, y = yini*3, parms = 0, func = combustion) out4 <- ode(times = times, y = yini*4, parms = 0, func = combustion) ################################################### ### code chunk number 74: plotdeSolve ################################################### plot(out, out2, out3, out4, main = "combustion") legend("bottomright", lty = 1:4, col = 1:4, legend = 1:4, title = "yini*i") ################################################### ### code chunk number 75: plotdeSolve ################################################### plot(out, out2, out3, out4, main = "combustion") legend("bottomright", lty = 1:4, col = 1:4, legend = 1:4, title = "yini*i") ################################################### ### code chunk number 76: deSolve.Rnw:1336-1337 ################################################### head(ccl4data) ################################################### ### code chunk number 77: deSolve.Rnw:1340-1343 ################################################### obs <- subset (ccl4data, animal == "A", c(time, ChamberConc)) names(obs) <- c("time", "CP") head(obs) ################################################### ### code chunk number 78: deSolve.Rnw:1349-1363 ################################################### parms <- c(0.182, 4.0, 4.0, 0.08, 0.04, 0.74, 0.05, 0.15, 0.32, 16.17, 281.48, 13.3, 16.17, 5.487, 153.8, 0.04321671, 0.40272550, 951.46, 0.02, 1.0, 3.80000000) yini <- c(AI = 21, AAM = 0, AT = 0, AF = 0, AL = 0, CLT = 0, AM = 0) out <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = parms) par2 <- parms par2[1] <- 0.1 out2 <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = par2) par3 <- parms par3[1] <- 0.05 out3 <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = par3) ################################################### ### code chunk number 79: plotobs ################################################### plot(out, out2, out3, which = c("AI", "MASS", "CP"), col = c("black", "red", "green"), lwd = 2, obs = obs, obspar = list(pch = 18, col = "blue", cex = 1.2)) legend("topright", lty = c(1,2,3,NA), pch = c(NA, NA, NA, 18), col = c("black", "red", "green", "blue"), lwd = 2, legend = c("par1", "par2", "par3", "obs")) ################################################### ### code chunk number 80: plotobs ################################################### plot(out, out2, out3, which = c("AI", "MASS", "CP"), col = c("black", "red", "green"), lwd = 2, obs = obs, obspar = list(pch = 18, col = "blue", cex = 1.2)) legend("topright", lty = c(1,2,3,NA), pch = c(NA, NA, NA, 18), col = c("black", "red", "green", "blue"), lwd = 2, legend = c("par1", "par2", "par3", "obs")) ################################################### ### code chunk number 81: deSolve.Rnw:1389-1391 ################################################### obs2 <- data.frame(time = 6, MASS = 12) obs2 ################################################### ### code chunk number 82: obs2 ################################################### plot(out, out2, out3, lwd = 2, obs = list(obs, obs2), obspar = list(pch = c(16, 18), col = c("blue", "black"), cex = c(1.2 , 2)) ) ################################################### ### code chunk number 83: plotobs2 ################################################### plot(out, out2, out3, lwd = 2, obs = list(obs, obs2), obspar = list(pch = c(16, 18), col = c("blue", "black"), cex = c(1.2 , 2)) ) ################################################### ### code chunk number 84: hist ################################################### hist(out, col = grey(seq(0, 1, by = 0.1)), mfrow = c(3, 4)) ################################################### ### code chunk number 85: plothist ################################################### hist(out, col = grey(seq(0, 1, by = 0.1)), mfrow = c(3, 4)) ################################################### ### code chunk number 86: deSolve.Rnw:1450-1452 ################################################### options(prompt = " ") options(continue = " ") ################################################### ### code chunk number 87: deSolve.Rnw:1455-1479 ################################################### lvmod <- function (time, state, parms, N, rr, ri, dr, dri) { with (as.list(parms), { PREY <- state[1:N] PRED <- state[(N+1):(2*N)] ## Fluxes due to diffusion ## at internal and external boundaries: zero gradient FluxPrey <- -Da * diff(c(PREY[1], PREY, PREY[N]))/dri FluxPred <- -Da * diff(c(PRED[1], PRED, PRED[N]))/dri ## Biology: Lotka-Volterra model Ingestion <- rIng * PREY * PRED GrowthPrey <- rGrow * PREY * (1-PREY/cap) MortPredator <- rMort * PRED ## Rate of change = Flux gradient + Biology dPREY <- -diff(ri * FluxPrey)/rr/dr + GrowthPrey - Ingestion dPRED <- -diff(ri * FluxPred)/rr/dr + Ingestion * assEff - MortPredator return (list(c(dPREY, dPRED))) }) } ################################################### ### code chunk number 88: deSolve.Rnw:1481-1483 ################################################### options(prompt = " ") options(continue = " ") ################################################### ### code chunk number 89: deSolve.Rnw:1486-1500 ################################################### R <- 20 # total radius of surface, m N <- 100 # 100 concentric circles dr <- R/N # thickness of each layer r <- seq(dr/2,by = dr,len = N) # distance of center to mid-layer ri <- seq(0,by = dr,len = N+1) # distance to layer interface dri <- dr # dispersion distances parms <- c(Da = 0.05, # m2/d, dispersion coefficient rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of pred assEff = 0.5, # -, assimilation efficiency cap = 10) # density, carrying capacity ################################################### ### code chunk number 90: deSolve.Rnw:1503-1513 ################################################### state <- rep(0, 2 * N) state[1] <- state[N + 1] <- 10 times <- seq(0, 200, by = 1) # output wanted at these time intervals print(system.time( out <- ode.1D(y = state, times = times, func = lvmod, parms = parms, nspec = 2, names = c("PREY", "PRED"), N = N, rr = r, ri = ri, dr = dr, dri = dri) )) ################################################### ### code chunk number 91: deSolve.Rnw:1516-1517 ################################################### summary(out) ################################################### ### code chunk number 92: deSolve.Rnw:1521-1523 ################################################### p10 <- subset(out, select = "PREY", subset = time == 10) head(p10, n = 5) ################################################### ### code chunk number 93: deSolve.Rnw:1569-1574 ################################################### Simple2D <- function(t, Y, par) { y <- matrix(nrow = nx, ncol = ny, data = Y) # vector to 2-D matrix dY <- - r_x2y2 * y # consumption return(list(dY)) } ################################################### ### code chunk number 94: deSolve.Rnw:1578-1585 ################################################### dy <- dx <- 1 # grid size nx <- ny <- 100 x <- seq (dx/2, by = dx, len = nx) y <- seq (dy/2, by = dy, len = ny) # in each grid cell: consumption depending on position r_x2y2 <- outer(x, y, FUN=function(x,y) ((x-50)^2 + (y-50)^2)*1e-4) ################################################### ### code chunk number 95: deSolve.Rnw:1589-1592 ################################################### C <- matrix(nrow = nx, ncol = ny, 1) ODE3 <- ode.2D(y = C, times = 1:100, func = Simple2D, parms = NULL, dimens = c(nx, ny), names = "C", method = "ode45") ################################################### ### code chunk number 96: deSolve.Rnw:1595-1598 ################################################### summary(ODE3) t50 <- matrix(nrow = nx, ncol = ny, data = subset(ODE3, select = "C", subset = (time == 50))) ################################################### ### code chunk number 97: twoD ################################################### par(mfrow = c(1, 2)) contour(x, y, r_x2y2, main = "consumption") contour(x, y, t50, main = "Y(t = 50)") ################################################### ### code chunk number 98: twoD ################################################### par(mfrow = c(1, 2)) contour(x, y, r_x2y2, main = "consumption") contour(x, y, t50, main = "Y(t = 50)") ################################################### ### code chunk number 99: deSolve.Rnw:1628-1636 ################################################### PCmod <- function(t, x, parms) { with(as.list(c(parms, x)), { dP <- c*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dP, dC) list(res) }) } ################################################### ### code chunk number 100: deSolve.Rnw:1643-1644 ################################################### parms <- c(c = 10, d = 0.1, e = 0.1, f = 0.1) ################################################### ### code chunk number 101: deSolve.Rnw:1650-1656 ################################################### xstart <- c(P = 0.5, C = 1) times <- seq(0, 200, 0.1) out <- ode(y = xstart, times = times, func = PCmod, parms = parms) tail(out) ################################################### ### code chunk number 102: deSolve.Rnw:1677-1681 ################################################### out <- ode(y = xstart,times = times, func = PCmod, parms = parms, atol = 0) matplot(out[,1], out[,2:3], type = "l", xlab = "time", ylab = "Producer, Consumer") ################################################### ### code chunk number 103: deSolve.Rnw:1737-1761 ################################################### LVmod <- function(Time, State, Pars) { with(as.list(c(State, Pars)), { Ingestion <- rIng * Prey * Predator GrowthPrey <- rGrow * Prey * (1 - Prey/K) MortPredator <- rMort * Predator dPrey <- GrowthPrey - Ingestion dPredator <- Ingestion * assEff - MortPredator return(list(c(dPrey, dPredator))) }) } pars <- c(rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of predator assEff = 0.5, # -, assimilation efficiency K = 10) # mmol/m3, carrying capacity yini <- c(Prey = 1, Predator = 2) times <- seq(0, 200, by = 1) out <- ode(func = LVmod, y = yini, parms = pars, times = times) ################################################### ### code chunk number 104: deSolve.Rnw:1773-1776 ################################################### pars["rIng"] <- 100 out2 <- ode(func = LVmod, y = yini, parms = pars, times = times) ################################################### ### code chunk number 105: err ################################################### plot(out2, type = "l", lwd = 2, main = "corrupt Lotka-Volterra model") ################################################### ### code chunk number 106: deSolve.Rnw:1825-1828 ################################################### pars["rIng"] <- 100 out3 <- ode(func = LVmod, y = yini, parms = pars, times = times, method = "ode45", atol = 1e-14, rtol = 1e-14) ################################################### ### code chunk number 107: err ################################################### plot(out2, type = "l", lwd = 2, main = "corrupt Lotka-Volterra model") deSolve/inst/doc/deSolve.Rnw0000644000176000001440000020043213136461014015516 0ustar ripleyusers\documentclass[article,nojss]{jss} \DeclareGraphicsExtensions{.pdf, .eps, .png, .jpeg} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Add-on packages and fonts \usepackage{graphicx} \usepackage{amsmath} \newcommand{\noun}[1]{\textsc{#1}} %% Bold symbol macro for standard LaTeX users \providecommand{\boldsymbol}[1]{\mbox{\boldmath $#1$}} %% Because html converters don't know tabularnewline \providecommand{\tabularnewline}{\\} \usepackage{array} % table commands \setlength{\extrarowheight}{0.1cm} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% User specified LaTeX commands. \newcommand{\R}{\proglang{R }} \newcommand{\ds}{\textbf{\textsf{deSolve }}} \newcommand{\bs}{\textbf{\textsf{bvpSolve }}} \newcommand{\rt}{\textbf{\textsf{ReacTran }}} \newcommand{\rb}[1]{\raisebox{1.5ex}{#1}} \title{Package \pkg{deSolve}: Solving Initial Value Differential Equations in \proglang{R}} \Plaintitle{Package deSolve: Solving Initial Value Differential Equations in R} \Keywords{differential equations, ordinary differential equations, differential algebraic equations, partial differential equations, initial value problems, \proglang{R}} \Plainkeywords{differential equations, ordinary differential equations, differential algebraic equations, partial differential equations, initial value problems, R} \author{ Karline Soetaert\\ Royal Netherlands Institute\\ of Sea Research (NIOZ)\\ Yerseke, The Netherlands \And Thomas Petzoldt\\ Technische Universit\"at \\ Dresden\\ Germany \And R. Woodrow Setzer\\ National Center for\\ Computational Toxicology\\ US Environmental Protection Agency } \Plainauthor{Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer} \Abstract{ \R package \ds \citep{deSolve_jss,deSolve} the successor of \proglang{R} package \pkg{odesolve} is a package to solve initial value problems (IVP) of: \begin{itemize} \item ordinary differential equations (ODE), \item differential algebraic equations (DAE), \item partial differential equations (PDE) and \item delay differential equations (DeDE). \end{itemize} The implementation includes stiff and nonstiff integration routines based on the \pkg{ODEPACK} \proglang{FORTRAN} codes \citep{Hindmarsh83}. It also includes fixed and adaptive time-step explicit Runge-Kutta solvers and the Euler method \citep{Press92}, and the implicit Runge-Kutta method RADAU \citep{Hairer2}. In this vignette we outline how to implement differential equations as \R-functions. Another vignette (``compiledCode'') \citep{compiledCode}, deals with differential equations implemented in lower-level languages such as \proglang{FORTRAN}, \proglang{C}, or \proglang{C++}, which are compiled into a dynamically linked library (DLL) and loaded into \proglang{R} \citep{Rcore}. Note that another package, \bs provides methods to solve boundary value problems \citep{bvpSolve}. } %% The address of (at least) one author should be given %% in the following format: \Address{ Karline Soetaert\\ Centre for Estuarine and Marine Ecology (CEME)\\ Royal Netherlands Institute of Sea Research (NIOZ)\\ 4401 NT Yerseke, Netherlands \\ E-mail: \email{karline.soetaert@nioz.nl}\\ URL: \url{http://www.nioz.nl}\\ \\ Thomas Petzoldt\\ Institut f\"ur Hydrobiologie\\ Technische Universit\"at Dresden\\ 01062 Dresden, Germany\\ E-mail: \email{thomas.petzoldt@tu-dresden.de}\\ URL: \url{http://tu-dresden.de/Members/thomas.petzoldt/}\\ \\ R. Woodrow Setzer\\ National Center for Computational Toxicology\\ US Environmental Protection Agency\\ URL: \url{http://www.epa.gov/comptox} } %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% R/Sweave specific LaTeX commands. %% need no \usepackage{Sweave} %\VignetteIndexEntry{R Package deSolve: Solving Initial Value Differential Equations in R} %\VignetteKeywords{differential equations, ordinary differential equations, differential algebraic equations, partial differential equations, initial value problems, R} %\VignettePackage{deSolve} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Begin of the document \begin{document} \SweaveOpts{engine=R,eps=FALSE} \SweaveOpts{keep.source=TRUE} <>= library("deSolve") options(prompt = "> ") options(width=70) @ \maketitle \section{A simple ODE: chaos in the atmosphere} The Lorenz equations (Lorenz, 1963) were the first chaotic dynamic system to be described. They consist of three differential equations that were assumed to represent idealized behavior of the earth's atmosphere. We use this model to demonstrate how to implement and solve differential equations in \proglang{R}. The Lorenz model describes the dynamics of three state variables, $X$, $Y$ and $Z$. The model equations are: \begin{align*} \frac{dX}{dt} &= a \cdot X + Y \cdot Z \\ \frac{dY}{dt} &= b \cdot (Y - Z) \\ \frac{dZ}{dt} &= - X \cdot Y + c \cdot Y - Z \end{align*} with the initial conditions: \[ X(0) = Y(0) = Z(0) = 1 \] Where $a$, $b$ and $c$ are three parameters, with values of -8/3, -10 and 28 respectively. Implementation of an IVP ODE in \R can be separated in two parts: the model specification and the model application. Model specification consists of: \begin{itemize} \item Defining model parameters and their values, \item Defining model state variables and their initial conditions, \item Implementing the model equations that calculate the rate of change (e.g. $dX/dt$) of the state variables. \end{itemize} The model application consists of: \begin{itemize} \item Specification of the time at which model output is wanted, \item Integration of the model equations (uses R-functions from \pkg{deSolve}), \item Plotting of model results. \end{itemize} Below, we discuss the \proglang{R}-code for the Lorenz model. \subsection{Model specification} \subsubsection{Model parameters} There are three model parameters: $a$, $b$, and $c$ that are defined first. Parameters are stored as a vector with assigned names and values: <<>>= parameters <- c(a = -8/3, b = -10, c = 28) @ \subsubsection{State variables} The three state variables are also created as a vector, and their initial values given: <<>>= state <- c(X = 1, Y = 1, Z = 1) @ \subsubsection{Model equations} The model equations are specified in a function (\code{Lorenz}) that calculates the rate of change of the state variables. Input to the function is the model time (\code{t}, not used here, but required by the calling routine), and the values of the state variables (\code{state}) and the parameters, in that order. This function will be called by the \R routine that solves the differential equations (here we use \code{ode}, see below). The code is most readable if we can address the parameters and state variables by their names. As both parameters and state variables are `vectors', they are converted into a list. The statement \code{with(as.list(c(state, parameters)), {...})} then makes available the names of this list. The main part of the model calculates the rate of change of the state variables. At the end of the function, these rates of change are returned, packed as a list. Note that it is necessary \textbf{to return the rate of change in the same ordering as the specification of the state variables. This is very important.} In this case, as state variables are specified $X$ first, then $Y$ and $Z$, the rates of changes are returned as $dX, dY, dZ$. <<>>= Lorenz<-function(t, state, parameters) { with(as.list(c(state, parameters)),{ # rate of change dX <- a*X + Y*Z dY <- b * (Y-Z) dZ <- -X*Y + c*Y - Z # return the rate of change list(c(dX, dY, dZ)) }) # end with(as.list ... } @ \subsection{Model application} \subsubsection{Time specification} We run the model for 100 days, and give output at 0.01 daily intervals. R's function \code{seq()} creates the time sequence: <<>>= times <- seq(0, 100, by = 0.01) @ \subsubsection{Model integration} The model is solved using \ds function \code{ode}, which is the default integration routine. Function \code{ode} takes as input, a.o. the state variable vector (\code{y}), the times at which output is required (\code{times}), the model function that returns the rate of change (\code{func}) and the parameter vector (\code{parms}). Function \code{ode} returns an object of class \code{deSolve} with a matrix that contains the values of the state variables (columns) at the requested output times. <<>>= library(deSolve) out <- ode(y = state, times = times, func = Lorenz, parms = parameters) head(out) @ \subsubsection{Plotting results} Finally, the model output is plotted. We use the plot method designed for objects of class \code{deSolve}, which will neatly arrange the figures in two rows and two columns; before plotting, the size of the outer upper margin (the third margin) is increased (\code{oma}), such as to allow writing a figure heading (\code{mtext}). First all model variables are plotted versus \code{time}, and finally \code{Z} versus \code{X}: <>= par(oma = c(0, 0, 3, 0)) plot(out, xlab = "time", ylab = "-") plot(out[, "X"], out[, "Z"], pch = ".") mtext(outer = TRUE, side = 3, "Lorenz model", cex = 1.5) @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the ordinary differential equation - see text for R-code} \label{fig:dae} \end{figure} \clearpage \section{Solvers for initial value problems of ordinary differential equations} Package \ds contains several IVP ordinary differential equation solvers, that belong to the most important classes of solvers. Most functions are based on original (\proglang{FORTRAN}) implementations, e.g. the Backward Differentiation Formulae and Adams methods from \pkg{ODEPACK} \citep{Hindmarsh83}, or from \citep{Brown89,Petzold1983}, the implicit Runge-Kutta method RADAU \citep{Hairer2}. The package contains also a de novo implementation of several Runge-Kutta methods \citep{Butcher1987, Press92, Hairer1}. All integration methods\footnote{except \code{zvode}, the solver used for systems containing complex numbers.} can be triggered from function \code{ode}, by setting \code{ode}'s argument \code{method}), or can be run as stand-alone functions. Moreover, for each integration routine, several options are available to optimise performance. For instance, the next statements will use integration method \code{radau} to solve the model, and set the tolerances to a higher value than the default. Both statements are the same: <<>>= outb <- radau(state, times, Lorenz, parameters, atol = 1e-4, rtol = 1e-4) outc <- ode(state, times, Lorenz, parameters, method = "radau", atol = 1e-4, rtol = 1e-4) @ The default integration method, based on the \proglang{FORTRAN} code LSODA is one that switches automatically between stiff and non-stiff systems \citep{Petzold1983}. This is a very robust method, but not necessarily the most efficient solver for one particular problem. See \citep{deSolve_jss} for more information about when to use which solver in \pkg{deSolve}. For most cases, the default solver, \code{ode} and using the default settings will do. Table \ref{tb:rs} also gives a short overview of the available methods. To show how to trigger the various methods, we solve the model with several integration routines, each time printing the time it took (in seconds) to find the solution: <<>>= print(system.time(out1 <- rk4 (state, times, Lorenz, parameters))) print(system.time(out2 <- lsode (state, times, Lorenz, parameters))) print(system.time(out <- lsoda (state, times, Lorenz, parameters))) print(system.time(out <- lsodes(state, times, Lorenz, parameters))) print(system.time(out <- daspk (state, times, Lorenz, parameters))) print(system.time(out <- vode (state, times, Lorenz, parameters))) @ \subsection{Runge-Kutta methods and Euler} The explicit Runge-Kutta methods are de novo implementations in \proglang{C}, based on the Butcher tables \citep{Butcher1987}. They comprise simple Runge-Kutta formulae (Euler's method \code{euler}, Heun's method \code{rk2}, the classical 4th order Runge-Kutta, \code{rk4}) and several Runge-Kutta pairs of order 3(2) to order 8(7). The embedded, explicit methods are according to \citet{Fehlberg1967} (\code{rk..f}, \code{ode45}), \citet{Dormand1980,Dormand1981} (\code{rk..dp.}), \citet{Bogacki1989} (\code{rk23bs}, \code{ode23}) and \citet{Cash1990} (\code{rk45ck}), where \code{ode23} and \code{ode45} are aliases for the popular methods \code{rk23bs} resp. \code{rk45dp7}. With the following statement all implemented methods are shown: <<>>= rkMethod() @ This list also contains implicit Runge-Kutta's (\code{irk..}), but they are not yet optimally coded. The only well-implemented implicit Runge-Kutta is the \code{radau} method \citep{Hairer2} that will be discussed in the section dealing with differential algebraic equations. The properties of a Runge-Kutta method can be displayed as follows: <<>>= rkMethod("rk23") @ Here \code{varstep} informs whether the method uses a variable time-step; \code{FSAL} whether the first same as last strategy is used, while \code{stage} and \code{Qerr} give the number of function evaluations needed for one step, and the order of the local truncation error. \code{A, b1, b2, c} are the coefficients of the Butcher table. Two formulae (\code{rk45dp7, rk45ck}) support dense output. It is also possible to modify the parameters of a method (be very careful with this) or define and use a new Runge-Kutta method: <<>>= func <- function(t, x, parms) { with(as.list(c(parms, x)),{ dP <- a * P - b * C * P dC <- b * P * C - c * C res <- c(dP, dC) list(res) }) } rKnew <- rkMethod(ID = "midpoint", varstep = FALSE, A = c(0, 1/2), b1 = c(0, 1), c = c(0, 1/2), stage = 2, Qerr = 1 ) out <- ode(y = c(P = 2, C = 1), times = 0:100, func, parms = c(a = 0.1, b = 0.1, c = 0.1), method = rKnew) head(out) @ \subsubsection{Fixed time-step methods} There are two explicit methods that do not adapt the time step: the \code{euler} method and the \code{rk4} method. They are implemented in two ways: \begin{itemize} \item as a \code{rkMethod} of the \textbf{general} \code{rk} solver. In this case the time step used can be specified independently from the \code{times} argument, by setting argument \code{hini}. Function \code{ode} uses this general code. \item as \textbf{special} solver codes \code{euler} and \code{rk4}. These implementations are simplified and with less options to avoid overhead. The timestep used is determined by the time increment in the \code{times} argument. \end{itemize} For example, the next two statements both trigger the Euler method, the first using the ``special'' code with a time step = 1, as imposed by the \code{times} argument, the second using the generalized method with a time step set by \code{hini}. Unsurprisingly, the first solution method completely fails (the time step $= 1$ is much too large for this problem). \begin{verbatim} out <- euler(y = state, times = 0:40, func = Lorenz, parms = parameters) outb <- ode(y = state, times = 0:40, func = Lorenz, parms = parameters, method = "euler", hini = 0.01) \end{verbatim} \subsection{Model diagnostics and summaries} Function \code{diagnostics} prints several diagnostics of the simulation to the screen. For the Runge-Kutta and \code{lsode} routine called above they are: <<>>= diagnostics(out1) diagnostics(out2) @ There is also a \code{summary} method for \code{deSolve} objects. This is especially handy for multi-dimensional problems (see below) <<>>= summary(out1) @ \clearpage \section{Partial differential equations} As package \ds includes integrators that deal efficiently with arbitrarily sparse and banded Jacobians, it is especially well suited to solve initial value problems resulting from 1, 2 or 3-dimensional partial differential equations (PDE), using the method-of-lines approach. The PDEs are first written as ODEs, using finite differences. This can be efficiently done with functions from R-package \rt \citep{ReacTran}. However, here we will create the finite differences in R-code. Several special-purpose solvers are included in \pkg{deSolve}: \begin{itemize} \item \code{ode.band} integrates 1-dimensional problems comprizing one species, \item \code{ode.1D} integrates 1-dimensional problems comprizing one or many species, \item \code{ode.2D} integrates 2-dimensional problems, \item \code{ode.3D} integrates 3-dimensional problems. \end{itemize} As an example, consider the Aphid model described in \citet{Soetaert08}. It is a model where aphids (a pest insect) slowly diffuse and grow on a row of plants. The model equations are: \[ \frac{{\partial N}}{{\partial t}} = - \frac{{\partial Flux}}{{\partial {\kern 1pt} x}} + g \cdot N \] and where the diffusive flux is given by: \[ Flux = - D\frac{{\partial N}}{{\partial {\kern 1pt} x}} \] with boundary conditions \[ N_{x=0}=N_{x=60}=0 \] and initial condition \begin{center} $N_x=0$ for $x \neq 30$ $N_x=1$ for $x = 30$ \end{center} In the method of lines approach, the spatial domain is subdivided in a number of boxes and the equation is discretized as: \[ \frac{{dN_i }}{{dt}} = - \frac{{Flux_{i,i + 1} - Flux_{i - 1,i} }}{{\Delta x_i }} + g \cdot N_i \] with the flux on the interface equal to: \[ Flux_{i - 1,i} = - D_{i - 1,i} \cdot \frac{{N_i - N_{i - 1} }}{{\Delta x_{i - 1,i} }} \] Note that the values of state variables (here densities) are defined in the centre of boxes (i), whereas the fluxes are defined on the box interfaces. We refer to \citet{Soetaert08} for more information about this model and its numerical approximation. Here is its implementation in \proglang{R}. First the model equations are defined: <<>>= Aphid <- function(t, APHIDS, parameters) { deltax <- c (0.5, rep(1, numboxes - 1), 0.5) Flux <- -D * diff(c(0, APHIDS, 0)) / deltax dAPHIDS <- -diff(Flux) / delx + APHIDS * r # the return value list(dAPHIDS ) } # end @ Then the model parameters and spatial grid are defined <<>>= D <- 0.3 # m2/day diffusion rate r <- 0.01 # /day net growth rate delx <- 1 # m thickness of boxes numboxes <- 60 # distance of boxes on plant, m, 1 m intervals Distance <- seq(from = 0.5, by = delx, length.out = numboxes) @ Aphids are initially only present in two central boxes: <<>>= # Initial conditions: # ind/m2 APHIDS <- rep(0, times = numboxes) APHIDS[30:31] <- 1 state <- c(APHIDS = APHIDS) # initialise state variables @ The model is run for 200 days, producing output every day; the time elapsed in seconds to solve this 60 state-variable model is estimated (\code{system.time}): <<>>= times <-seq(0, 200, by = 1) print(system.time( out <- ode.1D(state, times, Aphid, parms = 0, nspec = 1, names = "Aphid") )) @ Matrix \code{out} consist of times (1st column) followed by the densities (next columns). <<>>= head(out[,1:5]) @ The \code{summary} method gives the mean, min, max, ... of the entire 1-D variable: <<>>= summary(out) @ Finally, the output is plotted. It is simplest to do this with \pkg{deSolve}'s \proglang{S3}-method \code{image} %% Do this offline %%<>= \begin{verbatim} image(out, method = "filled.contour", grid = Distance, xlab = "time, days", ylab = "Distance on plant, m", main = "Aphid density on a row of plants") \end{verbatim} %%@ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} %%<>= %%<> %%@ \includegraphics{aphid.png} \end{center} \caption{Solution of the 1-dimensional aphid model - see text for \R-code} \label{fig:aphid} \end{figure} As this is a 1-D model, it is best solved with \ds function \code{ode.1D}. A multi-species IVP example can be found in \citet{Soetaert08}. For 2-D and 3-D problems, we refer to the help-files of functions \code{ode.2D} and \code{ode.3D}. The output of one-dimensional models can also be plotted using S3-method \code{plot.1D} and \code{matplot.1D}. In both cases, we can simply take a \code{subset} of the output, and add observations. <<>>= data <- cbind(dist = c(0,10, 20, 30, 40, 50, 60), Aphid = c(0,0.1,0.25,0.5,0.25,0.1,0)) @ <>= par (mfrow = c(1,2)) matplot.1D(out, grid = Distance, type = "l", mfrow = NULL, subset = time %in% seq(0, 200, by = 10), obs = data, obspar = list(pch = 18, cex = 2, col="red")) plot.1D(out, grid = Distance, type = "l", mfrow = NULL, subset = time == 100, obs = data, obspar = list(pch = 18, cex = 2, col="red")) @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the Aphid model - plotted with matplot.1D, plot.1D - see text for R-code} \label{fig:matplot1d} \end{figure} \clearpage \section{Differential algebraic equations} Package \ds contains two functions that solve initial value problems of differential algebraic equations. They are: \begin{itemize} \item \code{radau} which implements the implicit Runge-Kutta RADAU5 \citep{Hairer2}, \item \code{daspk}, based on the backward differentiation code DASPK \citep{Brenan96}. \end{itemize} Function \code{radau} needs the input in the form $M y' = f(t,y,y')$ where $M$ is the mass matrix. Function \code{daspk} also supports this input, but can also solve problems written in the form $F(t, y, y') = 0$. \code{radau} solves problems up to index 3; \code{daspk} solves problems of index $\leq$ 1. \subsection{DAEs of index maximal 1} Function \code{daspk} from package \ds solves (relatively simple) DAEs of index\footnote{note that many -- apparently simple -- DAEs are higher-index DAEs} maximal 1. The DAE has to be specified by the \emph{residual function} instead of the rates of change (as in ODE). Consider the following simple DAE: \begin{eqnarray*} \frac{dy_1}{dt}&=&-y_1+y_2\\ y_1 \cdot y_2 &=& t \end{eqnarray*} where the first equation is a differential, the second an algebraic equation. To solve it, it is first rewritten as residual functions: \begin{eqnarray*} 0&=&\frac{dy_1}{dt}+y_1-y_2\\ 0&=&y_1 \cdot y_2 - t \end{eqnarray*} In \R we write: <<>>= daefun <- function(t, y, dy, parameters) { res1 <- dy[1] + y[1] - y[2] res2 <- y[2] * y[1] - t list(c(res1, res2)) } library(deSolve) yini <- c(1, 0) dyini <- c(1, 0) times <- seq(0, 10, 0.1) ## solver system.time(out <- daspk(y = yini, dy = dyini, times = times, res = daefun, parms = 0)) @ <>= matplot(out[,1], out[,2:3], type = "l", lwd = 2, main = "dae", xlab = "time", ylab = "y") @ \setkeys{Gin}{width=0.4\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the differential algebraic equation model - see text for R-code} \label{fig:dae2} \end{figure} \subsection{DAEs of index up to three} Function \code{radau} from package \ds can solve DAEs of index up to three provided that they can be written in the form $M dy/dt = f(t,y)$. Consider the well-known pendulum equation: \begin{eqnarray*} x' &=& u\\ y' &=& v\\ u' &=& -\lambda x\\ v' &=& -\lambda y - 9.8\\ 0 &=& x^2 + y^2 - 1 \end{eqnarray*} where the dependent variables are $x, y, u, v$ and $\lambda$. Implemented in \R to be used with function \code{radau} this becomes: <<>>= pendulum <- function (t, Y, parms) { with (as.list(Y), list(c(u, v, -lam * x, -lam * y - 9.8, x^2 + y^2 -1 )) ) } @ A consistent set of initial conditions are: <<>>= yini <- c(x = 1, y = 0, u = 0, v = 1, lam = 1) @ and the mass matrix $M$: <<>>= M <- diag(nrow = 5) M[5, 5] <- 0 M @ Function \code{radau} requires that the index of each equation is specified; there are 2 equations of index 1, two of index 2, one of index 3: <<>>= index <- c(2, 2, 1) times <- seq(from = 0, to = 10, by = 0.01) out <- radau (y = yini, func = pendulum, parms = NULL, times = times, mass = M, nind = index) @ <>= plot(out, type = "l", lwd = 2) plot(out[, c("x", "y")], type = "l", lwd = 2) @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the pendulum problem, an index 3 differential algebraic equation using \code{radau} - see text for \proglang{R}-code} \label{fig:pendulum} \end{figure} \clearpage \section{Integrating systems containing complex numbers, function zvode} Function \code{zvode} solves ODEs that are composed of complex variables. We use \code{zvode} to solve the following system of 2 ODEs: \begin{align*} \frac{dz}{dt} &= i \cdot z\\ \frac{dw}{dt} &= -i \cdot w \cdot w \cdot z\\ \intertext{where} w(0) &= 1/2.1 \\ z(0) &= 1 \end{align*} on the interval $t = [0, 2 \pi]$ <<>>= ZODE2 <- function(Time, State, Pars) { with(as.list(State), { df <- 1i * f dg <- -1i * g * g * f return(list(c(df, dg))) }) } yini <- c(f = 1+0i, g = 1/2.1+0i) times <- seq(0, 2 * pi, length = 100) out <- zvode(func = ZODE2, y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10) @ The analytical solution is: \begin{align*} f(t) &= \exp (1i \cdot t) \intertext{and} g(t) &= 1/(f(t) + 1.1) \end{align*} The numerical solution, as produced by \code{zvode} matches the analytical solution: <<>>= analytical <- cbind(f = exp(1i*times), g = 1/(exp(1i*times)+1.1)) tail(cbind(out[,2], analytical[,1])) @ \clearpage \section{Making good use of the integration options} The solvers from \pkg{ODEPACK} can be fine-tuned if it is known whether the problem is stiff or non-stiff, or if the structure of the Jacobian is sparse. We repeat the example from \code{lsode} to show how we can make good use of these options. The model describes the time evolution of 5 state variables: <<>>= f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } @ and the initial conditions and output times are: <<>>= yini <- 1:5 times <- 1:20 @ The default solution, using \code{lsode} assumes that the model is stiff, and the integrator generates the Jacobian, which is assummed to be \emph{full}: <<>>= out <- lsode(yini, times, f1, parms = 0, jactype = "fullint") @ It is possible for the user to provide the Jacobian. Especially for large problems this can result in substantial time savings. In a first case, the Jacobian is written as a full matrix: <<>>= fulljac <- function (t, y, parms) { jac <- matrix(nrow = 5, ncol = 5, byrow = TRUE, data = c(0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1)) return(jac) } @ and the model solved as: <<>>= out2 <- lsode(yini, times, f1, parms = 0, jactype = "fullusr", jacfunc = fulljac) @ The Jacobian matrix is banded, with one nonzero band above (up) and one below(down) the diagonal. First we let \code{lsode} estimate the banded Jacobian internally (\code{jactype = "bandint"}): <<>>= out3 <- lsode(yini, times, f1, parms = 0, jactype = "bandint", bandup = 1, banddown = 1) @ It is also possible to provide the nonzero bands of the Jacobian in a function: <<>>= bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } @ in which case the model is solved as: <<>>= out4 <- lsode(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) @ Finally, if the model is specified as ``non-stiff'' (by setting \code{mf=10}), there is no need to specify the Jacobian: <<>>= out5 <- lsode(yini, times, f1, parms = 0, mf = 10) @ \clearpage \section{Events and roots} As from version 1.6, \code{events} are supported. Events occur when the values of state variables are instantaneously changed. They can be specified as a \code{data.frame}, or in a function. Events can also be triggered by a root function. Several integrators (\code{lsoda}, \code{lsodar}, \code{lsode}, \code{lsodes} and \code{radau}) can estimate the root of one or more functions. For the first 4 integration methods, the root finding algorithm is based on the algorithm in solver LSODAR, and implemented in FORTRAN. For \code{radau}, the root solving algorithm is written in C-code, and it works slightly different. Thus, some problems involving roots may be more efficient to solve with either \code{lsoda, lsode}, or \code{lsodes}, while other problems are more efficiently solved with \code{radau}. If a root is found, then the integration will be terminated, unless an event function is defined. A help file with information on roots and events can be opened by typing \code{?events} or \code{?roots}. \subsection{Event specified in a data.frame} In this example, two state variables with constant decay are modeled: <<>>= eventmod <- function(t, var, parms) { list(dvar = -0.1*var) } yini <- c(v1 = 1, v2 = 2) times <- seq(0, 10, by = 0.1) @ At time 1 and 9 a value is added to variable \code{v1}, at time 1 state variable \code{v2} is multiplied with 2, while at time 5 the value of \code{v2} is replaced with 3. These events are specified in a \code{data.frame}, eventdat: <<>>= eventdat <- data.frame(var = c("v1", "v2", "v2", "v1"), time = c(1, 1, 5, 9), value = c(1, 2, 3, 4), method = c("add", "mult", "rep", "add")) eventdat @ The model is solved with \code{ode}: <<>>= out <- ode(func = eventmod, y = yini, times = times, parms = NULL, events = list(data = eventdat)) @ <>= plot(out, type = "l", lwd = 2) @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A simple model that contains events} \label{fig:event1} \end{figure} \subsection{Event triggered by a root function} This model describes the position (\code{y1}) and velocity (\code{y2}) of a bouncing ball: <<>>= ballode<- function(t, y, parms) { dy1 <- y[2] dy2 <- -9.8 list(c(dy1, dy2)) } @ An event is triggered when the ball hits the ground (height = 0) Then velocity (\code{y2}) is reversed and reduced by 10 percent. The root function, \code{y[1] = 0}, triggers the event: <<>>= root <- function(t, y, parms) y[1] @ The event function imposes the bouncing of the ball <<>>= event <- function(t, y, parms) { y[1]<- 0 y[2]<- -0.9 * y[2] return(y) } @ After specifying the initial values and times, the model is solved, here using \code{lsode}. <<>>= yini <- c(height = 0, v = 20) times <- seq(from = 0, to = 20, by = 0.01) out <- lsode(times = times, y = yini, func = ballode, parms = NULL, events = list(func = event, root = TRUE), rootfun = root) @ <>= plot(out, which = "height", type = "l",lwd = 2, main = "bouncing ball", ylab = "height") @ \setkeys{Gin}{width=0.4\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A model, with event triggered by a root function} \label{fig:event2} \end{figure} \subsection{Events and time steps} The use of events requires that all event times are contained in the output time steps, otherwise such events would be skipped. This sounds easy but sometimes problems can occur due to the limited accuracy of floating point arithmetics of the computer. To make things work as excpected, two requirements have to be fulfilled: \begin{enumerate} \item all event times have to be contained \textbf{exactly} in times, i.e. with the maximum possible accuracy of floating point arithmetics. \item two time steps should not be too close together, otherwise numerical problems would occur during the integration. \end{enumerate} Starting from version 1.10 of \pkg{deSolve} this is now checked (and if necessary also fixed) automatically by the solver functions. A warning is issued to inform the user about possible problems, especially that the output time steps were now adjusted and therefore different from the ones originally specified by the user. This means that all values of \code{eventtimes} are now contained but only the subset of times that have no exact or ``rather close'' neighbors in \code{eventtimes}. Instead of relying on this automatism, matching times and eventtimes can also be managed by the user, either by appropriate rounding or by using function \code{cleanEventTimes} shown below. Let's assume we have a vector of time steps \code{times} and another vector of event times \code{eventtimes}: <<>>= times <- seq(0, 1, 0.1) eventtimes <- c(0.7, 0.9) @ If we now check whether the \code{eventtimes} are in \code{times}: <<>>= eventtimes %in% times @ we get the surprising answer that this is only partly the case, because \code{seq} made small numerical errors. The easiest method to get rid of this is rounding: <<>>= times2 <- round(times, 1) times - times2 @ The last line shows us that the error was always smaller than, say $10^{-15}$, what is typical for ordinary double precision arithmetics. The accuracy of the machine can be determined with \code{.Machine\$double.eps}. To check if all \code{eventtimes} are now contained in the new times vector \code{times2}, we use: <<>>= eventtimes %in% times2 @ or <<>>= all(eventtimes %in% times2) @ and see that everything is o.k. now. In few cases, rounding may not work properly, for example if a pharmacokinetic model is simulated with a daily time step, but drug injection occurs at precisely fixed times within the day. Then one has to add all additional event times to the ordinary time stepping: <<>>= times <- 1:10 eventtimes <- c(1.3, 3.4, 4, 7.9, 8.5) newtimes <- sort(unique(c(times, eventtimes))) @ If, however, an event and a time step are almost (but not exactly) the same, then it is more safe to use: <<>>= times <- 1:10 eventtimes <- c(1.3, 3.4, 4, 7.9999999999999999, 8.5) newtimes <- sort(c(eventtimes, cleanEventTimes(times, eventtimes))) @ because \code{cleanEventTimes} removes not only the doubled 4 (like \code{unique}, but also the ``almost doubled'' 8, while keeping the exact event time. The tolerance of \code{cleanEventTimes} can be adjusted using an optional argument \code{eps}. As said, this is normally done automatically by the differential equation solvers and in most cases appropriate rounding will be sufficient to get rid of the warnings. \clearpage \section{Delay differential equations} As from \pkg{deSolve} version 1.7, time lags are supported, and a new general solver for delay differential equations, \code{dede} has been added. We implement the lemming model, example 6 from \citep{ST2000}. Function \code{lagvalue} calculates the value of the state variable at \code{t - 0.74}. As long a these lag values are not known, the value 19 is assigned to the state variable. Note that the simulation starts at \code{time = - 0.74}. <<>>= library(deSolve) #----------------------------- # the derivative function #----------------------------- derivs <- function(t, y, parms) { if (t < 0) lag <- 19 else lag <- lagvalue(t - 0.74) dy <- r * y * (1 - lag/m) list(dy, dy = dy) } #----------------------------- # parameters #----------------------------- r <- 3.5; m <- 19 #----------------------------- # initial values and times #----------------------------- yinit <- c(y = 19.001) times <- seq(-0.74, 40, by = 0.01) #----------------------------- # solve the model #----------------------------- yout <- dede(y = yinit, times = times, func = derivs, parms = NULL, atol = 1e-10) @ <>= plot(yout, which = 1, type = "l", lwd = 2, main = "Lemming model", mfrow = c(1,2)) plot(yout[,2], yout[,3], xlab = "y", ylab = "dy", type = "l", lwd = 2) @ \setkeys{Gin}{width=\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A delay differential equation model} \label{fig:dde} \end{figure} \clearpage \section{Discrete time models, difference equations} There is one special-purpose solver, triggered with \code{method = "iteration"} which can be used in cases where the new values of the state variables are directly estimated by the user, and need not be found by numerical integration. This is for instance useful when the model consists of difference equations, or for 1-D models when transport is implemented by an implicit or a semi-implicit method. We give here an example of a discrete time model, represented by a difference equation: the Teasel model as from \citet[p287]{Soetaert08}. The dynamics of this plant is described by 6 stages and the transition from one stage to another is in a transition matrix: We define the stages and the transition matrix first: <<>>= Stages <- c("DS 1yr", "DS 2yr", "R small", "R medium", "R large", "F") NumStages <- length(Stages) # Population matrix A <- matrix(nrow = NumStages, ncol = NumStages, byrow = TRUE, data = c( 0, 0, 0, 0, 0, 322.38, 0.966, 0, 0, 0, 0, 0 , 0.013, 0.01, 0.125, 0, 0, 3.448 , 0.007, 0, 0.125, 0.238, 0, 30.170, 0.008, 0, 0.038, 0.245, 0.167, 0.862 , 0, 0, 0, 0.023, 0.75, 0 ) ) @ The difference function is defined as usual, but does not return the ``rate of change'' but rather the new relative stage densities are returned. Thus, each time step, the updated values are divided by the summed densities: <<>>= Teasel <- function (t, y, p) { yNew <- A %*% y list (yNew / sum(yNew)) } @ The model is solved using method ``iteration'': <<>>= out <- ode(func = Teasel, y = c(1, rep(0, 5) ), times = 0:50, parms = 0, method = "iteration") @ and plotted using R-function \code{matplot}: <>= matplot(out[,1], out[,-1], main = "Teasel stage distribution", type = "l") legend("topright", legend = Stages, lty = 1:6, col = 1:6) @ \setkeys{Gin}{width=0.6\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A difference model solved with method = ``iteration''} \label{fig:difference} \end{figure} \section{Plotting deSolve Objects} There are \proglang{S3} \code{plot} and \code{image} methods for plotting 0-D (plot), and 1-D and 2-D model output (image) as generated with \code{ode}, \code{ode.1D}, \code{ode.2D}. How to use it and examples can be found by typing \code{?plot.deSolve}. \subsection{Plotting Multiple Scenario's} The \code{plot} method for \code{deSolve} objects can also be used to compare different scenarios, e.g from the same model but with different sets of parameters or initial values, with one single call to \code{plot}. As an example we implement the simple combustion model, which can be found on \url{http://www.scholarpedia.org/article/Stiff_systems}: \[ y' = y^2 \cdot (1-y) \] The model is run with 4 different values of the initial conditions: $y = 0.01, 0.02, 0.03, 0.04$ and written to \code{deSolve} objects \code{out}, \code{out2}, \code{out3}, \code{out4}. <<>>= library(deSolve) combustion <- function (t, y, parms) list(y^2 * (1-y) ) @ <<>>= yini <- 0.01 times <- 0 : 200 @ <<>>= out <- ode(times = times, y = yini, parms = 0, func = combustion) out2 <- ode(times = times, y = yini*2, parms = 0, func = combustion) out3 <- ode(times = times, y = yini*3, parms = 0, func = combustion) out4 <- ode(times = times, y = yini*4, parms = 0, func = combustion) @ The different scenarios are plotted at once, and a suitable legend is written. <>= plot(out, out2, out3, out4, main = "combustion") legend("bottomright", lty = 1:4, col = 1:4, legend = 1:4, title = "yini*i") @ \setkeys{Gin}{width=\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Plotting 4 outputs in one figure} \label{fig:plotdeSolve} \end{figure} \subsection{Plotting Output with Observations} With the help of the optional argument \code{obs} it is possible to specify observed data that should be added to a \code{deSolve} plot. We exemplify this using the \code{ccl4model} in package \code{deSolve}. (see \code{?ccl4model} for what this is about). This model example has been implemented in compiled code. An observed data set is also available, called \code{ccl4data}. It contains toxicant concentrations in a chamber where rats were dosed with CCl4. <<>>= head(ccl4data) @ We select the data from animal ``A'': <<>>= obs <- subset (ccl4data, animal == "A", c(time, ChamberConc)) names(obs) <- c("time", "CP") head(obs) @ After assigning values to the parameters and providing initial conditions, the \code{ccl4model} can be run. We run the model three times, each time with a different value for the first parameter. Output is written to matrices \code{out} \code{out2}, and \code{out3}. <<>>= parms <- c(0.182, 4.0, 4.0, 0.08, 0.04, 0.74, 0.05, 0.15, 0.32, 16.17, 281.48, 13.3, 16.17, 5.487, 153.8, 0.04321671, 0.40272550, 951.46, 0.02, 1.0, 3.80000000) yini <- c(AI = 21, AAM = 0, AT = 0, AF = 0, AL = 0, CLT = 0, AM = 0) out <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = parms) par2 <- parms par2[1] <- 0.1 out2 <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = par2) par3 <- parms par3[1] <- 0.05 out3 <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = par3) @ We plot all these scenarios and the observed data at once: <>= plot(out, out2, out3, which = c("AI", "MASS", "CP"), col = c("black", "red", "green"), lwd = 2, obs = obs, obspar = list(pch = 18, col = "blue", cex = 1.2)) legend("topright", lty = c(1,2,3,NA), pch = c(NA, NA, NA, 18), col = c("black", "red", "green", "blue"), lwd = 2, legend = c("par1", "par2", "par3", "obs")) @ \setkeys{Gin}{width=\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Plotting output and observations in one figure} \label{fig:plotobs} \end{figure} If we do not select specific variables, then only the ones for which there are observed data are plotted. Assume we have measured the total mass at the end of day 6. We put this in a second data set: <<>>= obs2 <- data.frame(time = 6, MASS = 12) obs2 @ then we plot the data together with the three model runs as follows: <>= plot(out, out2, out3, lwd = 2, obs = list(obs, obs2), obspar = list(pch = c(16, 18), col = c("blue", "black"), cex = c(1.2 , 2)) ) @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Plotting variables in common with observations} \label{fig:plotobs2} \end{figure} \subsection{Plotting Summary Histograms} The \code{hist} function plots the histogram for each variable; all plot parameters can be set individually (here for \code{col}). To generate the next plot, we overrule the default \code{mfrow} setting which would plot the figures in 3 rows and 3 columns (and hence plot one figure in isolation) <>= hist(out, col = grey(seq(0, 1, by = 0.1)), mfrow = c(3, 4)) @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Plotting histograms of all output variables} \label{fig:plothist} \end{figure} \subsection{Plotting multi-dimensional output} The \code{image} function plots time versus x images for models solved with \code{ode.1D}, or generates x-y plots for models solved with \code{ode.2D}. \subsubsection{1-D model output} We exemplify its use by means of a Lotka-Volterra model, implemented in 1-D. The model describes a predator and its prey diffusing on a flat surface and in concentric circles. This is a 1-D model, solved in the cylindrical coordinate system. Note that it is simpler to implement this model in R-package \code{ReacTran} \citep{ReacTran}. <>= options(prompt = " ") options(continue = " ") @ We start by defining the derivative function <<>>= lvmod <- function (time, state, parms, N, rr, ri, dr, dri) { with (as.list(parms), { PREY <- state[1:N] PRED <- state[(N+1):(2*N)] ## Fluxes due to diffusion ## at internal and external boundaries: zero gradient FluxPrey <- -Da * diff(c(PREY[1], PREY, PREY[N]))/dri FluxPred <- -Da * diff(c(PRED[1], PRED, PRED[N]))/dri ## Biology: Lotka-Volterra model Ingestion <- rIng * PREY * PRED GrowthPrey <- rGrow * PREY * (1-PREY/cap) MortPredator <- rMort * PRED ## Rate of change = Flux gradient + Biology dPREY <- -diff(ri * FluxPrey)/rr/dr + GrowthPrey - Ingestion dPRED <- -diff(ri * FluxPred)/rr/dr + Ingestion * assEff - MortPredator return (list(c(dPREY, dPRED))) }) } @ <>= options(prompt = " ") options(continue = " ") @ Then we define the parameters, which we put in a list <<>>= R <- 20 # total radius of surface, m N <- 100 # 100 concentric circles dr <- R/N # thickness of each layer r <- seq(dr/2,by = dr,len = N) # distance of center to mid-layer ri <- seq(0,by = dr,len = N+1) # distance to layer interface dri <- dr # dispersion distances parms <- c(Da = 0.05, # m2/d, dispersion coefficient rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of pred assEff = 0.5, # -, assimilation efficiency cap = 10) # density, carrying capacity @ After defining initial conditions, the model is solved with routine \code{ode.1D} <<>>= state <- rep(0, 2 * N) state[1] <- state[N + 1] <- 10 times <- seq(0, 200, by = 1) # output wanted at these time intervals print(system.time( out <- ode.1D(y = state, times = times, func = lvmod, parms = parms, nspec = 2, names = c("PREY", "PRED"), N = N, rr = r, ri = ri, dr = dr, dri = dri) )) @ The \code{summary} method provides summaries for both 1-dimensional state variables: <<>>= summary(out) @ while the S3-method \code{subset} can be used to extract only specific values of the variables: <<>>= p10 <- subset(out, select = "PREY", subset = time == 10) head(p10, n = 5) @ We first plot both 1-dimensional state variables at once; we specify that the figures are arranged in two rows, and 2 columns; when we call \code{image}, we overrule the default mfrow setting (\code{mfrow = NULL}). Next we plot "PREY" again, once with the default xlim and ylim, and next zooming in. Note that xlim and ylim are a list here. When we call \code{image} for the second time, we overrule the default \code{mfrow} setting by specifying (\code{mfrow = NULL}). %% This is done offline. %%<>= \begin{verbatim} image(out, grid = r, mfrow = c(2, 2), method = "persp", border = NA, ticktype = "detailed", legend = TRUE) image(out, grid = r, which = c("PREY", "PREY"), mfrow = NULL, xlim = list(NULL, c(0, 10)), ylim = list(NULL, c(0, 5)), add.contour = c(FALSE, TRUE)) \end{verbatim} %%@ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} %%<>= %%<> %%@ \includegraphics{image1D.png} \end{center} \caption{image plots} \label{fig:plotimg} \end{figure} \subsubsection{2-D model output} When using \code{image} with a 2-D model, then the 2-D values at all output times will be plotted. Sometimes we want only output at a specific time value. We then use \proglang{S3}-method \code{subset} to extract 2-D variables at suitable time-values and use \proglang{R}'s \code{image}, \code{filled.contour} or \code{contour} method to depict them. Consider the very simple 2-D model (100*100), containing just 1-st order consumption, at a rate \code{r_x2y2}, where \code{r_x2y2} depends on the position along the grid. First the derivative function is defined: <<>>= Simple2D <- function(t, Y, par) { y <- matrix(nrow = nx, ncol = ny, data = Y) # vector to 2-D matrix dY <- - r_x2y2 * y # consumption return(list(dY)) } @ Then the grid is created, and the consumption rate made a function of grid position (\code{outer}). <<>>= dy <- dx <- 1 # grid size nx <- ny <- 100 x <- seq (dx/2, by = dx, len = nx) y <- seq (dy/2, by = dy, len = ny) # in each grid cell: consumption depending on position r_x2y2 <- outer(x, y, FUN=function(x,y) ((x-50)^2 + (y-50)^2)*1e-4) @ After defining the initial values, the model is solved using solver \code{ode.2D}. We use Runge-Kutta method \code{ode45}. <<>>= C <- matrix(nrow = nx, ncol = ny, 1) ODE3 <- ode.2D(y = C, times = 1:100, func = Simple2D, parms = NULL, dimens = c(nx, ny), names = "C", method = "ode45") @ We print a summary, and extract the 2-D variable at \code{time = 50} <<>>= summary(ODE3) t50 <- matrix(nrow = nx, ncol = ny, data = subset(ODE3, select = "C", subset = (time == 50))) @ We use function \code{contour} to plot both the consumption rate and the values of the state variables at \code{time = 50}. <>= par(mfrow = c(1, 2)) contour(x, y, r_x2y2, main = "consumption") contour(x, y, t50, main = "Y(t = 50)") @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Contour plot of 2-D variables} \label{fig:twoD} \end{figure} \clearpage \section{Troubleshooting} \subsection{Avoiding numerical errors} The solvers from \pkg{ODEPACK} should be first choice for any problem and the defaults of the control parameters are reasonable for many practical problems. However, there are cases where they may give dubious results. Consider the following Lotka-Volterra type of model: <<>>= PCmod <- function(t, x, parms) { with(as.list(c(parms, x)), { dP <- c*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dP, dC) list(res) }) } @ and with the following (biologically not very realistic)% \footnote{they are not realistic because producers grow unlimited with a high rate and consumers with 100 \% efficiency} parameter values: <<>>= parms <- c(c = 10, d = 0.1, e = 0.1, f = 0.1) @ After specification of initial conditions and output times, the model is solved -- using \code{lsoda}: <<>>= xstart <- c(P = 0.5, C = 1) times <- seq(0, 200, 0.1) out <- ode(y = xstart, times = times, func = PCmod, parms = parms) tail(out) @ We see that the simulation was stopped before reaching the final simulation time and both producers and consumer values may have negative values. What has happened? Being an implicit method, \code{lsoda} generates very small negative values for producers, from day 40 on; these negative values, small at first grow in magnitude until they become infinite or even NaNs (not a number). This is because the model equations are not intended to be used with negative numbers, as negative concentrations are not realistic. A quick-and-dirty solution is to reduce the maximum time step to a considerably small value (e.g. \code{hmax = 0.02} which, of course, reduces computational efficiency. However, a much better solution is to think about the reason of the failure, i.e in our case the \textbf{absolute} accuracy because the states can reach very small absolute values. Therefore, it helps here to reduce \code{atol} to a very small number or even to zero: <<>>= out <- ode(y = xstart,times = times, func = PCmod, parms = parms, atol = 0) matplot(out[,1], out[,2:3], type = "l", xlab = "time", ylab = "Producer, Consumer") @ It is, of course, not possible to set both, \code{atol} and \code{rtol} simultaneously to zero. As we see from this example, it is always a good idea to test simulation results for plausibility. This can be done by theoretical considerations or by comparing the outcome of different ODE solvers and parametrizations. \subsection{Checking model specification} If a model outcome is obviously unrealistic or one of the \ds functions complains about numerical problems it is even more likely that the ``numerical problem'' is in fact a result of an unrealistic model or a programming error. In such cases, playing with solver parameters will not help. Here are some common mistakes we observed in our models and the codes of our students: \begin{itemize} \item The function with the model definition must return a list with the derivatives of all state variables in correct order (and optionally some global values). Check if the number and order of your states is identical in the initial states \code{y} passed to the solver, in the assignments within your model equations and in the returned values. Check also whether the return value is the last statement of your model definition. \item The order of function arguments in the model definition is \code{t, y, parms, ...}. This order is strictly fixed, so that the \ds solvers can pass their data, but naming is flexible and can be adapted to your needs, e.g. \code{time, init, params}. Note also that all three arguments must be given, even if \code{t} is not used in your model. \item Mixing of variable names: if you use the \code{with()}-construction explained above, you must ensure to avoid naming conflicts between parameters (\code{parms}) and state variables (\code{y}). \end{itemize} The solvers included in package \ds are thorougly tested, however they come with \textbf{no warranty} and the user is solely responsible for their correct application. If you encounter unexpected behavior, first check your model and read the documentation. If this doesn't help, feel free to ask a question to an appropriate mailing list, e.g. \url{r-help@r-project.org} or, more specific, \url{r-sig-dynamic-models@r-project.org}. \subsection{Making sense of deSolve's error messages} As many of \pkg{deSolve}'s functions are wrappers around existing \proglang{FORTRAN} codes, the warning and error messages are derived from these codes. Whereas these codes are highly robust, well tested, and efficient, they are not always as user-friendly as we would like. Especially some of the warnings/error messages may appear to be difficult to understand. Consider the first example on the \code{ode} function: <<>>= LVmod <- function(Time, State, Pars) { with(as.list(c(State, Pars)), { Ingestion <- rIng * Prey * Predator GrowthPrey <- rGrow * Prey * (1 - Prey/K) MortPredator <- rMort * Predator dPrey <- GrowthPrey - Ingestion dPredator <- Ingestion * assEff - MortPredator return(list(c(dPrey, dPredator))) }) } pars <- c(rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of predator assEff = 0.5, # -, assimilation efficiency K = 10) # mmol/m3, carrying capacity yini <- c(Prey = 1, Predator = 2) times <- seq(0, 200, by = 1) out <- ode(func = LVmod, y = yini, parms = pars, times = times) @ This model is easily solved by the default integration method, \code{lsoda}. Now we change one of the parameters to an unrealistic value: \code{rIng} is set to $100$. This means that the predator ingests 100 times its own body-weight per day if there are plenty of prey. Needless to say that this is very unhealthy, if not lethal. Also, \code{lsoda} cannot solve the model anymore. Thus, if we try: <>= pars["rIng"] <- 100 out2 <- ode(func = LVmod, y = yini, parms = pars, times = times) @ A lot of seemingly incomprehensible messages will be written to the screen. We repeat the latter part of them: \begin{verbatim} DLSODA- Warning..Internal T (=R1) and H (=R2) are such that in the machine, T + H = T on the next step (H = step size). Solver will continue anyway. In above message, R1 = 53.4272, R2 = 2.44876e-15 DLSODA- Above warning has been issued I1 times. It will not be issued again for this problem. In above message, I1 = 10 DLSODA- At current T (=R1), MXSTEP (=I1) steps taken on this call before reaching TOUT In above message, I1 = 5000 In above message, R1 = 53.4272 Warning messages: 1: In lsoda(y, times, func, parms, ...) : an excessive amount of work (> maxsteps ) was done, but integration was not successful - increase maxsteps 2: In lsoda(y, times, func, parms, ...) : Returning early. Results are accurate, as far as they go \end{verbatim} The first sentence tells us that at T = 53.4272, the solver used a step size H = 2.44876e-15. This step size is so small that it cannot tell the difference between T and T + H. Nevertheless, the solver tried again. The second sentence tells that, as this warning has been occurring 10 times, it will not be outputted again. As expected, this error did not go away, so soon the maximal number of steps (5000) has been exceeded. This is indeed what the next message is about: The third sentence tells that at T = 53.4272, maxstep = 5000 steps have been done. The one before last message tells why the solver returned prematurely, and suggests a solution. Simply increasing maxsteps will not work and it makes more sense to first see if the output tells what happens: <>= plot(out2, type = "l", lwd = 2, main = "corrupt Lotka-Volterra model") @ You may, of course, consider to use another solver: <>= pars["rIng"] <- 100 out3 <- ode(func = LVmod, y = yini, parms = pars, times = times, method = "ode45", atol = 1e-14, rtol = 1e-14) @ but don't forget to think about this too and, for example, increase simulation time to 1000 and try different values of \code{atol} and \code{rtol}. We leave this open as an exercise to the reader. \setkeys{Gin}{width=\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A model that cannot be solved correctly} \label{fig:err} \end{figure} \clearpage %\section{Function overview} \begin{table*}[b] \caption{Summary of the functions that solve differential equations}\label{tb:rs} \centering \begin{tabular}{p{.15\textwidth}p{.75\textwidth}}\hline \rule[-3mm]{0mm}{8mm} Function &Description\\ \hline \hline \code{ode} & integrates systems of ordinary differential equations, assumes a full, banded or arbitrary sparse Jacobian \\ \hline \code{ode.1D} & integrates systems of ODEs resulting from 1-dimensional reaction-transport problems \\ \hline \code{ode.2D} & integrates systems of ODEs resulting from 2-dimensional reaction-transport problems \\ \hline \code{ode.3D} & integrates systems of ODEs resulting from 3-dimensional reaction-transport problems \\ \hline \code{ode.band} & integrates systems of ODEs resulting from unicomponent 1-dimensional reaction-transport problems \\ \hline \code{dede} & integrates systems of delay differential equations \\ \hline \code{daspk} & solves systems of differential algebraic equations, assumes a full or banded Jacobian \\ \hline \code{radau} & solves systems of ordinary or differential algebraic equations, assumes a full or banded Jacobian; includes a root solving procedure \\ \hline \code{lsoda} & integrates ODEs, automatically chooses method for stiff or non-stiff problems, assumes a full or banded Jacobian \\ \hline \code{lsodar} & same as \code{lsoda}, but includes a root-solving procedure \\ \hline \code{lsode} or \code{vode} & integrates ODEs, user must specify if stiff or non-stiff assumes a full or banded Jacobian; Note that, as from version 1.7, \code{lsode} includes a root finding procedure, similar to \code{lsodar}. \\ \hline \code{lsodes} & integrates ODEs, using stiff method and assuming an arbitrary sparse Jacobian. Note that, as from version 1.7, \code{lsodes} includes a root finding procedure, similar to \code{lsodar} \\ \hline \code{rk} & integrates ODEs, using Runge-Kutta methods (includes Runge-Kutta 4 and Euler as special cases) \\ \hline \code{rk4} & integrates ODEs, using the classical Runge-Kutta 4th order method (special code with less options than \code{rk}) \\ \hline \code{euler} & integrates ODEs, using Euler's method (special code with less options than \code{rk}) \\ \hline \code{zvode} & integrates ODEs composed of complex numbers, full, banded, stiff or nonstiff \\ \hline \hline \end{tabular} \end{table*} \begin{table*}[b] \caption{Meaning of the integer return parameters in the different integration routines. If \code{out} is the output matrix, then this vector can be retrieved by function \code{attributes(out)\$istate}; its contents is displayed by function \code{diagnostics(out)}. Note that the number of function evaluations, is without the extra evaluations needed to generate the output for the ordinary variables. } \centering \begin{tabular}{p{.05\textwidth}p{.95\textwidth}}\hline \rule[-3mm]{0mm}{8mm} Nr &Description\\ \hline \hline 1 & the return flag; the conditions under which the last call to the solver returned. For \code{lsoda, lsodar, lsode, lsodes, vode, rk, rk4, euler} these are: 2: the solver was successful, -1: excess work done, -2: excess accuracy requested, -3: illegal input detected, -4: repeated error test failures, -5: repeated convergence failures, -6: error weight became zero \\ \hline 2 & the number of steps taken for the problem so far\\ \hline 3 & the number of function evaluations for the problem so far\\ \hline 4 & the number of Jacobian evaluations so far\\ \hline 5 & the method order last used (successfully)\\ \hline 6 & the order of the method to be attempted on the next step\\ \hline 7 & If return flag = -4,-5: the largest component in the error vector\\ \hline 8 & the length of the real work array actually required. (\proglang{FORTRAN} code)\\ \hline 9 & the length of the integer work array actually required. (\proglang{FORTRAN} code)\\ \hline 10 & the number of matrix LU decompositions so far\\ \hline 11 & the number of nonlinear (Newton) iterations so far\\ \hline 12 & the number of convergence failures of the solver so far\\ \hline 13 & the number of error test failures of the integrator so far\\ \hline 14 & the number of Jacobian evaluations and LU decompositions so far\\ \hline 15 & the method indicator for the last succesful step, 1 = adams (nonstiff), 2 = bdf (stiff)\\ \hline 17 & the number of nonzero elements in the sparse Jacobian\\ \hline 18 & the current method indicator to be attempted on the next step, 1 = adams (nonstiff), 2 = bdf (stiff)\\ \hline 19 & the number of convergence failures of the linear iteration so far\\ \hline \hline \end{tabular} \end{table*} \begin{table*}[b] \caption{Meaning of the double precision return parameters in the different integration routines. If \code{out} is the output matrix, then this vector can be retrieved by function \code{attributes(out)\$rstate}; its contents is displayed by function \code{diagnostics(out)}} \centering \begin{tabular}{p{.05\textwidth}p{.95\textwidth}}\hline \rule[-3mm]{0mm}{8mm} Nr &Description\\ \hline \hline 1 & the step size in t last used (successfully)\\ \hline 2 & the step size to be attempted on the next step\\ \hline 3 & the current value of the independent variable which the solver has actually reached\\ \hline 4 & a tolerance scale factor, greater than 1.0, computed when a request for too much accuracy was detected\\ \hline 5 & the value of t at the time of the last method switch, if any (only \code{lsoda, lsodar}) \\ \hline \hline \end{tabular} \end{table*} %% this adds References to the PDF-Index without adding an obsolete section \phantomsection \addcontentsline{toc}{section}{References} \bibliography{integration} \end{document} deSolve/inst/doc/dynload/0000755000176000001440000000000013603425022015054 5ustar ripleyusersdeSolve/inst/doc/dynload/ex_SCOC.c0000644000176000001440000000145413136461015016452 0ustar ripleyusers/* -------- scoc.f -> scoc.dll ------ c compile in R with: system("g77 -shared -o scoc.dll SCOC.f") c or with system("R CMD SHLIB scoc.f") c Initialiser for parameter commons */ #include static double parms[1]; #define k parms[0] static double forcs[1]; #define depo forcs[0] void scocpar(void (* odeparms)(int *, double *)) { int N=1; odeparms(&N, parms); } /* Initialiser for forcing commons */ void scocforc(void (* odeforcs)(int *, double *)) { int N=1; odeforcs(&N, forcs); } /* Derivatives and output variable */ void scocder (int *neq, double *t, double *y, double *ydot, double *out, int *ip) { if (ip[0] <2) error("nout should be at least 2"); ydot[0] = -k*y[0] + depo; out[0]= k*y[0]; out[1]= depo; } deSolve/inst/doc/dynload/ex_SCOC.f0000644000176000001440000000203513136461015016451 0ustar ripleyusersc -------- scoc.f -> scoc.dll ------ c compile in R with: system("g77 -shared -o scoc.dll SCOC.f") c or with system("R CMD SHLIB scoc.f") c Initialiser for parameter common block subroutine scocpar(odeparms) external odeparms integer N double precision parms(1) common /myparms/parms N = 1 call odeparms(N, parms) return end c Initialiser for forcing common block subroutine scocforc(odeforcs) external odeforcs integer N double precision forcs(1) common /myforcs/forcs N = 1 call odeforcs(N, forcs) return end c Rate of change and output variables subroutine scocder (neq, t, y, ydot,out,IP) integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*), k, depo common /myparms/k common /myforcs/depo if(IP(1) < 2) call rexit("nout should be at least 2") ydot(1) = -k*y(1) + depo out(1)= k*y(1) out(2)= depo return end deSolve/inst/doc/dynload/radaudae.f0000644000176000001440000000465613136461015017007 0ustar ripleyusersc---------------------------------------------------------------- c---------------------------------------------------------------- c--- The car axis problem of radau c---------------------------------------------------------------- c---------------------------------------------------------------- c -------- radaudae.f -> radaudae.dll ------ c compile in R with: system("g77 -shared -o radaudae.dll radaudae.f") c or with system("R CMD SHLIB radaudae.f") c---------------------------------------------------------------- c Initialiser for parameter common block c---------------------------------------------------------------- subroutine initcaraxis(daeparms) external daeparms integer, parameter :: N = 8 double precision parms(N) common /myparms/parms call daeparms(N, parms) return end c---------------------------------------------------------------- c rate of change c---------------------------------------------------------------- subroutine caraxis(neq, t, y, ydot, out, ip) implicit none integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*) double precision eps, M, k, L, L0, r, w, g common /myparms/ eps, M, k, L, L0, r, w, g double precision xl, yl, xr, yr, ul, vl, ur, vr, lam1, lam2 double precision yb, xb, Ll, Lr, dxl, dyl, dxr, dyr double precision dul, dvl, dur, dvr, c1, c2 c expand state variables xl = y(1) yl = y(2) xr = y(3) yr = y(4) ul = y(5) vl = y(6) ur = y(7) vr = y(8) lam1 = y(9) lam2 = y(10) yb = r * sin(w * t) xb = sqrt(L * L - yb * yb) Ll = sqrt(xl**2 + yl**2) Lr = sqrt((xr - xb)**2 + (yr - yb)**2) dxl = ul dyl = vl dxr = ur dyr = vr dul = (L0-Ll) * xl/Ll + 2 * lam2 * (xl-xr) + lam1*xb dvl = (L0-Ll) * yl/Ll + 2 * lam2 * (yl-yr) + lam1*yb - k*g dur = (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr) dvr = (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k*g c1 = xb * xl + yb * yl c2 = (xl - xr)**2 + (yl - yr)**2 - L * L c function values in ydot ydot(1) = dxl ydot(2) = dyl ydot(3) = dxr ydot(4) = dyr ydot(5) = dul ydot(6) = dvl ydot(7) = dur ydot(8) = dvr ydot(9) = c1 ydot(10) = c2 return end deSolve/inst/doc/dynload/Forcing_lv.c0000644000176000001440000000166413136461015017322 0ustar ripleyusers/* compile within R with system("R CMD SHLIB Forcing_lv.c") */ #include static double parms[6]; static double forc[1]; /* A trick to keep up with the parameters and forcings */ #define b parms[0] #define c parms[1] #define d parms[2] #define e parms[3] #define f parms[4] #define g parms[5] #define import forc[0] /* initializers*/ void parmsc(void (* odeparms)(int *, double *)) { int N=6; odeparms(&N, parms); } void forcc(void (* odeforcs)(int *, double *)) { int N=1; odeforcs(&N, forc); } /* derivative function */ void derivsc(int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] <2) error("nout should be at least 2"); ydot[0] = import - b*y[0]*y[1] + g*y[2]; ydot[1] = c*y[0]*y[1] - d*y[2]*y[1]; ydot[2] = e*y[1]*y[2] - f*y[2]; yout[0] = y[0]+y[1]+y[2]; yout[1] = import; } void event(int *n, double *t, double *y) { y[2] = y[2]*0.5; } deSolve/inst/doc/dynload/CCL4model.f0000644000176000001440000001124513136461015016737 0ustar ripleyusers c the CCl4 inhalation model c based on the demo in odesolve c -------- ccl4model.f -> ccl4model.dll ------ c compile in R with: system("g77 -shared -o ccl4model.dll ccl4model.f") c or with system("R CMD SHLIB ccl4model.f") c======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= c Initialise primary parameter common block c======================================================================= subroutine initccl4(odeparms) external odeparms integer N c parameters are divided into primary and derived parameters double precision pars(21), derivedpars(15) common /myparms/pars,derivedpars N = 21 call odeparms(N, pars) call derived() return end c======================================================================= c In this "event", state variable 1 is increased with 1. DOES NOT WORK... c======================================================================= subroutine eventfun(n, t, y) integer n double precision t, y(7) y(1) = y(1) + 1 end subroutine c======================================================================= c Calculate derived parameters from primary parameters c======================================================================= subroutine derived implicit none double precision BW,QP,QC,VFC,VLC,VMC,QFC,QLC,QMC,PLA,PFA, & & PMA,PTA,PB,MW,VMAX,KM,CONC,KL,RATS,VCHC, & & VCH,VM,VT,VF,VL,PM,PT,PF,PL,AI0,VTC,QM,QT,QF,QL common /myparms/ BW,QP,QC,VFC,VLC,VMC,QFC,QLC,QMC,PLA,PFA, & & PMA,PTA,PB,MW,VMAX,KM,CONC,KL,RATS,VCHC, & VCH,VM,VT,VF,VL,PM,PT,PF,PL,AI0,VTC,QM,QT,QF,QL c Fraction viscera (kg/(kg BW)) VTC = 0.91 - (VLC+VFC+VMC) c Net chamber volume VCH = VCHC - RATS*BW VM = VMC*BW VT = VTC*BW VF = VFC*BW VL = VLC*BW c Initial amt. in chamber (mg) AI0 = CONC*VCH*MW/24450. PL = PLA/PB PF = PFA/PB PT = PTA/PB PM = PMA/PB QF = QFC*QC QL = QLC*QC QM = QMC*QC QT = QC - (QF+QL+QM) return end subroutine derived c======================================================================= c The dynamic model c======================================================================= subroutine derivsccl4 (neq, t, y, ydot,out,IP) implicit none integer neq, IP(*), i double precision t, y(neq), ydot(neq), out(*) double precision BW,QP,QC,VFC,VLC,VMC,QFC,QLC,QMC,PLA,PFA, & & PMA,PTA,PB,MW,VMAX,KM,CONC,KL,RATS,VCHC, & & V(5), P(4),AI0,VTC,Q(4) c here we lump parameters Vx, Qx and Px into vectors common /myparms/ BW,QP,QC,VFC,VLC,VMC,QFC,QLC,QMC,PLA,PFA, & & PMA,PTA,PB,MW,VMAX,KM,CONC,KL,RATS,VCHC, & & V, P, AI0,VTC, Q double precision tconc(5), vconc(5), dose, mass, cp, ca, cx, RAM c check if provision has been made for at least 3 output variables if (IP(1) < 3) call rexit("nout should be at least 3") c y = AI, AAM, AT, AF, AL CLT, AM c where clt = the area under the concentration-time curve in the liver c AM = total amount metabolised c concentrations do i =1,5 tconc(i) = y(i)/v(i) enddo c vconc(1) is conc in mixed venous blood vconc(1) = 0.d0 do i = 2,5 vconc(i) = tconc(i)/P(i-1) vconc(1) = vconc(1) + vconc(i)*Q(i-1)/QC enddo c CA is conc in arterial blood CA = (QC * Vconc(1) + QP * tconc(1))/ (QC + QP/PB) c Exhaled chemical CX = CA/PB c metabolisation rate RAM = VMAX*Vconc(5)/(KM + Vconc(5)) c the rate of change ydot(1) = RATS*QP*(CX - tconc(1)) - KL*y(1) do i = 2,5 ydot(i) = Q(i-1)*(CA-vconc(i)) enddo ydot(5) = ydot(5) - RAM ydot(6) = tconc(5) ydot(7) = RAM c the mass balance (MASS=AAM+AT+AF+AL+AM), should be constant DOSE = AI0 - y(1) MASS = (y(2)+y(3)+y(4)+y(5)+y(7))*RATS CP = tconc(1)*24450.0/MW out(1) = DOSE out(2) = MASS out(3) = CP return end deSolve/inst/doc/dynload/lsodarfor.f0000644000176000001440000000336413136461015017227 0ustar ripleyusersc---------------------------------------------------------------- c---------------------------------------------------------------- c--- The root model example of lsodar c---------------------------------------------------------------- c---------------------------------------------------------------- c -------- lsodarfor.f -> lsodarfor.dll ------ c compile in R with: system("g77 -shared -o lsodarfor.dll lsodarfor.f") c or with system("R CMD SHLIB lsodarfor.f") c---------------------------------------------------------------- c Initialiser for parameter common block c---------------------------------------------------------------- subroutine lsodarfor(odeparms) external odeparms integer, parameter :: N = 3 double precision parms(N) common /myparms/parms call odeparms(N, parms) return end c---------------------------------------------------------------- c rate of change and 1 output variable c---------------------------------------------------------------- subroutine modfor(neq, t, y, ydot,out,IP) integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*), aa, bb, cc common /myparms/aa,bb,cc if(IP(1) < 1) call rexit("nout should be at least 1") ydot(1) = aa*y(1) + bb*y(2)*y(3) ydot(3) = cc*y(2)*y(2) ydot(2) = -ydot(1) - ydot(3) out(1)=y(1)+y(2)+y(3) return end c---------------------------------------------------------------- c The root function c---------------------------------------------------------------- subroutine myroot(neq, t, y, ng, gout) integer :: neq, ng double precision :: t, y(neq), gout(ng) gout(1) = y(1) - 1.e-4 gout(2) = y(3) - 1e-2 return end deSolve/inst/doc/dynload/intakes.RData0000644000176000001440000000501413136461015017432 0ustar ripleyusersPiT by/z EQ7` Jd A@EZ$t)Qgok/ 'Es1|73 C&ҏ*J_ m5i_gpx Ԕ4CVKtJڽtl/d,PٲSjǐ7H:KtH~ 0c(VQq6} ۏEi6GG(RQ8VoзS) }BwP;('('('*'va@6OH?}Pu}P?>V•*aKAfA=ss>7l7يI'wRA"5H]>9i4FG@ M#fQHsr -r,r 9i-ȞAm-j;vQۣffv@SwsWz;N<.*$x e;0Ol 4j ް~)w"M Iɑ&;(FVXcEnz3'ցbVr(?GOF&ix'pfCm=bĢXO@<{I!Ee$\޵GXnMB#Wݴ(of6ؽ&QYy$|yyM*V@.4 p^*t3@:x`}"DT4+0.6%^Ś$|yӔodU6k=R9j%c)㡣߼;nđ  tŦV E\GµխD7oYrZ;~`mDݯm//y<+AfWv]0"ށ."ab/:&Sghߝ =Fݡ Zk ?a?˳qOonJI<%bQ%h<2GYs`A۝U$\CLԥǙgTf:U^SqtqT0y7:gݦeo tv:0R7p/ͮKuGk;jXc`M>4ygPCOR3˂(ac\1GJvx]=^BNW)ƙ ~!>h<usC&U]>FȘ>i]=_uXu^Vg!:5uq dYkI/ .^zBΛVACҮow9V~b.y`h%?O!"Z&dRԅ o@dJ^VjDo7SkZTe;oz]qCENM9Ǭ')pFʋzV m}DCY9TP\FjUTXO`z&:;m!T>?wSΦ9?khPOEB;Qg 7>ٙw{iis{D7D;~SZЫ\r9-GvJSZj>meo?J<:{=JLȺx7c"vښ{ ÇXC|>d‡,2C&|2C|HJ>C|bPjC |b>A A C)|C)|‡<>$|C2|C|H!>DÇh>0>a+| v]>1|8‡>:p>GC=|ÇZP C!|!|!|C|Ȅ?a|Xz||k>xއ‡<‡>=Y 䞬a |H)!>|>TÇ* 5>TÇZP jC5|C5|ÇC'> xC*|>,>xO{>‡< C%|Ç>Çzp>C|8 ‡:P C%|(%ADA C|C6\g܇ X ?#Z-[ tIWX9mnqdmp@;tOW_ t=t/Bs+j!V򝑽s*EJuuu] 6m–[Kڇڧ/deSolve/inst/doc/dynload/odec.c0000644000176000001440000000234213136461015016136 0ustar ripleyusers/* compile within R with system("R CMD SHLIB odec.c") */ /* Example adapted from lsoda documentation */ #include /* gives F77_CALL through R_ext/RS.h */ static double parms[3]; /* A trick to keep up with the parameters */ #define k1 parms[0] #define k2 parms[1] #define k3 parms[2] /* initializer: same name as the dll (without extension) */ void odec(void (* odeparms)(int *, double *)) { int N=3; odeparms(&N, parms); } /* Derivatives */ void derivsc(int *neq, double *t, double *y, double *ydot, double *yout, int*ip) { if (ip[0] <3) error("nout should be at least 3"); ydot[0] = -k1*y[0] + k2*y[1]*y[2]; ydot[2] = k3 * y[1]*y[1]; ydot[1] = -ydot[0]-ydot[2]; yout[0] = y[0]+y[1]+y[2]; yout[1] = y[0]*2; yout[2] = k3; } /* Jacobian */ void jacc(int *neq, double *t, double *y, int *ml, int *mu, double *pd, int *nrowpd, double *yout, int*ip) { pd[0] = -k1; pd[1] = k1; pd[2] = 0.0; pd[(*nrowpd)] = k2*y[2]; pd[(*nrowpd) + 1] = -k2*y[2] - 2*k3*y[1]; pd[(*nrowpd) + 2] = 2*k3*y[1]; pd[(*nrowpd)*2] = k2*y[1]; pd[2*(*nrowpd) + 1] = -k2 * y[1]; pd[2*(*nrowpd) + 2] = 0.0; } /* End of example */ deSolve/inst/doc/dynload/satres.R0000644000176000001440000002145313136461015016510 0ustar ripleyusers##--------------------------------------------------------------------------- ## A Physiologically Based Pharmacokinetic (PBPK) model ## before trying this code, the C or FORTRAN program has to be compiled ## this can be done in R: ## system("R CMD SHLIB satres.f") ## or: ## system("R CMD SHLIB satresC.c") ## do make sure that this file is in the working directory... ## (if not, use setwd() ) ##--------------------------------------------------------------------------- ## We want to be able to run three kinds of dosing regimens with the same ## model: ## - single gavage ## - repeated gavage ## - dietary library(deSolve) wh <- menu(c("C version", "FORTRAN version"), graphics = TRUE, title = "Which language version?") if (wh == 0) stop("User cancelled", cal. = FALSE) DLLname <- switch(wh, "satresC", "satres") FullDLLname <- paste(DLLname, .Platform$dynlib.ext, sep = "") if (!file.exists(FullDLLname)) stop(paste("You need to create", FullDLLname, "using 'R CMD SHLIB", DLLname, "'"), call. = FALSE) dyn.load(FullDLLname) if(length(grep("intakes", search())) == 0) attach("intakes.RData") ## Dose is the Dose in mg/kg ## Doseint is NA for single dose, interval ## between doses in hours for repeated dosing, -1 to use the intake data ## MaxTime is the largest requested output time, and is calculated ## internally. ## Other parms as in satres.c defParms <- c(Vc = 0.0027, Vt = 0.0545, kd = 0.00059/0.0027, ka = 0.537, Tm = 860.9, KT = 0.0015, kfil = 0.6830/0.0027, Vfil = 0.01, free = 0.02, BW = 0.025, Dose = NA, Doseint = NA, Qd = NA, Qfil = NA, MaxTime = NA, TDose = NA) ## initparms is called as, for example ## P <- initparms(list(Dose = 60, Doseint = 24, Vc = 0.0030)) ## Gives a parameter list that the model can use, for 60 mg/kg ## every 24 hours dosing, setting Vc to 0.003 L initparms <- function(newParms = NULL) { Parms <- defParms if (!is.null(newParms)) { ldots <- as.list(newParms) if (!all(names(ldots) %in% names(defParms))) stop("illegal parameter name") Parms[names(ldots)] <- unlist(ldots) } lParms <- as.list(Parms) Parms["Qd"] <- with(lParms, kd * Vc) Parms["Qfil"] <- with(lParms, kfil*Vc) Parms["TDose"] <- Parms["Dose"] * Parms["BW"] Parms } ## newParms is a list with parameter names initforcs <- function(Parms) { if (is.na(Parms["Doseint"])) RepDose <- matrix(c(0, Parms["MaxTime"], 0, 0), ncol = 2) else if (Parms["Doseint"] > 0) { Parms["TDose"] <- Parms["TDose"]/(5/3600) dosetimes <- seq(0, Parms["MaxTime"] - 5/3600, by = Parms["Doseint"]) dosesoff <- dosetimes + 5/3600 RepDose <- cbind(sort(c(dosetimes, dosesoff)), rep(c(Parms["TDose"], 0), length(dosetimes))) } else if (Parms["Doseint"] < 0) { maxdays <- ceiling(Parms["MaxTime"]/24) dosetimes <- as.vector(outer(intakes[, "hours"], 24*(0:maxdays), "+")) doserates <- rep(intakes[, "Rfood.femaleB6C3F1"], (maxdays + 1)) * Parms["TDose"] RepDose <- cbind(dosetimes, doserates) } RepDose } ## initState returns the initialized state vector. initstate <- function(Parms){ if (is.na(Parms["Doseint"])) structure(c(rep(0, 3), Parms["TDose"], 0, 0), names = c("Ccentral", "Csecond", "Cfiltrate", "Agut", "Elim", "AUC")) else structure(rep(0, 6), names = c("Ccentral", "Csecond", "Cfiltrate", "Agut", "Elim", "AUC")) } ## pfoasat runs the model. On input, ## - Times is a vector of time values ## at which model results are desired. ## - newParms is a list like the input ## to initparms, above. ## - method is a string giving the solution method to use ## see the documentation for deSolve::ode for details ## there. the elipsis (...) is for additional arguments ## to the odesolver (see ode and the individual methods ## for details). ## The return value is a matrix of values. Column 1 is the ## time vector, Columns 2 - 5 are the concentrations in ## compartments 1 - 4 (just before dosing, in the case of repeated ## dosing). ## ## Example: to match the 7 and 17 day 20 mg/kg repeated dosing ## using lsode: ## out <- pfoasat(24 * c(0, 7, 17), newParms = list(Dose = 20, Doseint = 24)) ## when finished, you can unload the dll with ## dyn.unload("satres") pfoasat <- function(Times, newParms, method = "lsode", ...){ if ("MaxTime" %in% names(newParms)) newParms["MaxTime"] <- max(Times) else newParms <- c(newParms, MaxTime = max(Times)) Parmsout <- initparms(newParms) Forcings <- initforcs(Parmsout) y <- initstate(Parmsout) ode(y, Times, "derivs", parms = Parmsout, method = method, dllname = DLLname, initfunc = "initmod", forcings = Forcings, initforc = "initforc", fcontrol = list(method = "constant"), nout = 1, outnames = "Total", ...) } ## ------------------------------------------------------------------- ## Simulate a range of doses, both be repeated gavage and an equivalent ## dose via the diet. Plot the time course for 1 and 500 mg/kg/day, ## and the total dose-response. Doses <- c(1, 2, 5, 10, 20, 50, 100, 200, 500, 1000) nperhour <- 6 ## for smooth plotting ndays <- 30 ## follow for ndays outs <- vector("list", length = 2*length(Doses)) dim(outs) <- c(length(Doses), 2) rownames(outs) <- as.character(Doses) for (i in seq(along = Doses)) { outs[[i, 1]] <- list(Dose = Doses[i], out = as.data.frame(pfoasat(seq(0, 24*ndays, by = 1/nperhour), newParms = list(Dose = Doses[i], Doseint = 24), hmax = 0.001)) ) outs[[i, 2]] <- list(Dose = Doses[i], out = as.data.frame(pfoasat(seq(0, 24*ndays, by = 1/nperhour), newParms = list(Dose = Doses[i], Doseint = -1), hmax = 0.4)) ) } ## Plot 1 and 500 mg/kg/day doses, to see the contrast par(mfrow = c(1, 2), las = 1, bty = "l", mar = c(5, 4, 0, 1)) ## ------------------------ Central compartment ylim = c(0, 500) plot(Ccentral ~ I(time/24), data = outs[["1", 1]]$out, type = "l", ylim = ylim, xlab = "Days in Study", ylab = "Conc. PFOA in Central Cmpt.", sub = "A: 1 mg/kg/day") lines(Ccentral ~ I(time/24), data = outs[["1", 2]]$out, lty = "44") legend("right",legend = c("Daily gavage", "Feed"), lty = c("solid", "44"), bty = "n") plot(Ccentral ~ I(time/24), data = outs[["500", 1]]$out, type = "l", ylim = ylim, xlab = "Days in Study", ylab = "Conc. PFOA in Central Cmpt.", sub = "B: 500 mg/kg/day") lines(Ccentral ~ I(time/24), data = outs[["500", 2]]$out, lty = "44") ## Force a pause after this figure tmp <- readline(prompt = "press to continue ... ") ## now, the curve relating external dose to internal dose-metric. ## Function to extract the dose-metric ## z is a dataframe like the ones we've made here ## We compute the average daily peak concentration in ## the central compartment and the daily average AUC in the ## central compartment. dosemetric <- function(z) { ## drop the first time (0) z <- z[-1,] ## split the data on day: day <- ceiling(z$time/24) dailypeaks <- tapply(z$Ccentral, day, function(x) max(x)) dailyaucs <- tapply(z$AUC, day, function(x) (x[length(x)] - x[1]))/24 c(avgpeak = mean(dailypeaks), avgauc = mean(dailyaucs)) } ## Create a matrix to hold the doses DoseMets <- matrix(nrow = length(Doses), ncol = 4, dimnames = list(rownames(outs), c("gavage.peak", "gavage.auc", "diet.peak", "diet.auc"))) for (dose in rownames(outs)) { DoseMets[dose, c("gavage.peak", "gavage.auc")] <- dosemetric(outs[[dose, 1]]$out) DoseMets[dose, c("diet.peak", "diet.auc")] <- dosemetric(outs[[dose, 2]]$out) } DoseMets <- as.data.frame(cbind(Doses, DoseMets)) par(mfrow = c(1, 1), bty = "l", las = 1, mar = c(4, 4, 0, 0)) plot(gavage.peak ~ Doses, DoseMets, ylim = range(DoseMets[, 2:5]), xlab = "Administered Dose (mg/kg/day)", ylab = "Dose Metric", log = "xy", pch = 1) zz <- spline(log(DoseMets$Doses), log(DoseMets$gavage.peak)) lines(exp(zz[[1]]), exp(zz[[2]])) points(gavage.auc ~ Doses, DoseMets, pch = 20) zz <- spline(log(DoseMets$Doses), log(DoseMets$gavage.auc)) lines(exp(zz[[1]]), exp(zz[[2]]), lty = "33") points(diet.peak ~ Doses, DoseMets, pch = 1, col = "blue") zz <- spline(log(DoseMets$Doses), log(DoseMets$diet.peak)) lines(exp(zz[[1]]), exp(zz[[2]]), col = "blue") points(diet.auc ~ Doses, DoseMets, pch = 20, col = "blue") zz <- spline(log(DoseMets$Doses), log(DoseMets$diet.auc)) lines(exp(zz[[1]]), exp(zz[[2]]), lty = "33", col = "blue") legend("topleft", legend = c("gavage peak", "gavage AUC", "diet peak", "diet auc"), pch = c(1, 20, 1, 20), lty = c("solid", "33", "solid", "33"), col = c("black", "black", "blue", "blue"), bty = "n") ## unload the DLL dyn.unload(FullDLLname) deSolve/inst/doc/dynload/odedll.R0000644000176000001440000002307013136461015016447 0ustar ripleyusers############################################################################### # Implements the test model, as given in the vode code. # Demonstrates several ways to write models, and estimates the time required # user system elapsed # before trying this code, the FORTRAN, and C programs have to be compiled # this can be done in R: # system("R CMD SHLIB odec.c") # system("R CMD SHLIB odefor.f") # system("R CMD SHLIB odefor2.f") # do make sure that these files are in the working directory... # (if not, use setwd() ) ############################################################################### # model settings # parameters k1 <- 0.04 k2 <- 1e4 k3 <- 3e7 parms <- c(k1 = k1, k2 = k2, k3 = k3) # parameters Y <- c(1.0, 0.0, 0.0) # initial conditions times <- c(0, 0.4*10^(0:11) ) # output times RTOL <- 1.e-4 # tolerances, lower for second var ATOL <- c(1.e-8, 1.e-14, 1.e-6) MF <- 21 # stiff, full Jacobian, specified as function require(deSolve) #------------------------------------------------------------ # test model fully implemented in R, parameters passed #------------------------------------------------------------ #----------------------# # the model equations: # #----------------------# model<-function(t, Y, parameters){ with (as.list(parameters), { dy1 <- -k1*Y[1] + k2*Y[2]*Y[3] dy3 <- k3*Y[2]*Y[2] dy2 <- -dy1 - dy3 list(c(dy1, dy2, dy3)) # the output, packed as a list }) } #----------------------# # the Jacobian: # #----------------------# jac <- function (t, Y, parameters) { with (as.list(parameters), { PD[1, 1] <- -k1 PD[1, 2] <- k2*Y[3] PD[1, 3] <- k2*Y[2] PD[2, 1] <- k1 PD[2, 3] <- -PD[1, 3] PD[3, 2] <- k3*Y[2] PD[2, 2] <- -PD[1, 2] - PD[3, 2] return(PD) }) } PD <- matrix(nrow = 3, ncol = 3, data = 0) print("all in R - vode") print(system.time( for (i in 1:10) out <- vode(Y, times, model, parms = parms, rtol = RTOL, atol = ATOL, mf = MF, jacfunc = jac, verbose = FALSE, ynames = FALSE ) )/10) print("all in R - lsoda") print(system.time( for (i in 1:10) out <- lsoda(Y, times, model, parms = parms, rtol = RTOL, atol = ATOL, jac = "fullusr", jacfunc = jac, verbose = FALSE, ynames = FALSE ) )/10) print("all in R - lsode") print(system.time( for (i in 1:10) out <- lsode(Y, times, model, parms = parms, rtol = RTOL, atol = ATOL, jac = "fullusr", jacfunc = jac, verbose = FALSE, ynames = FALSE ) )/10) #------------------------------------------------------------ # test model fully implemented in R, NO parameters passed #------------------------------------------------------------ #----------------------# # the model equations: # #----------------------# model <- function(t, Y, parameters) { dy1 <- -k1*Y[1] + k2*Y[2]*Y[3] dy3 <- k3*Y[2]*Y[2] dy2 <- -dy1 - dy3 list(c(dy1, dy2, dy3)) } #----------------------# # the Jacobian: # #----------------------# jac <- function (t, Y, parameters) { PD[1, 1] <- -k1 PD[1, 2] <- k2*Y[3] PD[1, 3] <- k2*Y[2] PD[2, 1] <- k1 PD[2, 3] <- -PD[1, 3] PD[3, 2] <- k3*Y[2] PD[2, 2] <- -PD[1, 2] - PD[3, 2] return(PD) } PD <- matrix(nrow = 3, ncol = 3, data = 0) print("all in R, no pars passed - vode") print(system.time( for (i in 1:10) out <- vode(Y, times, model, parms = parms, rtol = RTOL, atol = ATOL, mf = MF, jacfunc = jac, verbose = FALSE, ynames = FALSE ) )/10) print("all in R, no pars passed - lsoda") print(system.time( for (i in 1:10) out <- lsoda(Y, times, model, parms = parms, rtol = RTOL, atol = ATOL, jac = "fullusr", jacfunc = jac, verbose = FALSE, ynames = FALSE ) )/10) print("all in R, no pars passed - lsode") print(system.time( for (i in 1:10) out <- lsode(Y, times, model, parms = parms, rtol = RTOL, atol = ATOL, jac = "fullusr", jacfunc = jac, verbose = FALSE, ynames = FALSE ) )/10) #------------------------------------------------------------ # DLL TEST 1. Fortran code in odefor.f; DLL passed to vode #------------------------------------------------------------ # compiled within R with: system("R CMD SHLIB odefor.f") dyn.load(paste("odefor", .Platform$dynlib.ext, sep = "")) print("Fortran dll passed to vode") print(system.time( for(i in 1:100) outF <- vode(Y, times, "derivsfor", parms = parms, rtol = RTOL, atol = ATOL, mf = MF, jacfunc = "jacfor", dllname = "odefor", verbose = FALSE, ynames = FALSE, nout = 3, rpar = runif(5)) )/100) #------------------------------------------------------------ # and now lsoda #------------------------------------------------------------ print("Fortran dll passed to lsoda") print(system.time( for(i in 1:100) outL <- lsoda(Y, times, "derivsfor", parms = parms, rtol = RTOL, atol = ATOL, mf = MF, jacfunc = "jacfor", dllname = "odefor", verbose = FALSE, ynames = FALSE, nout = 3) )/100) #------------------------------------------------------------ # and now lsode #------------------------------------------------------------ print("Fortran dll passed to lsode") print(system.time( for(i in 1:100) outL <- lsode(Y, times, "derivsfor", parms = parms, rtol = RTOL, atol = ATOL, mf = MF, jacfunc = "jacfor", dllname = "odefor", verbose = FALSE, ynames = FALSE, nout = 3) )/100) #------------------------------------------------------------ # DLL TEST 2. C code in odec.c; DLL passed to vode #------------------------------------------------------------ # compiled within R with: system("R CMD SHLIB odec.c") #system("R CMD SHLIB odec.c") dyn.load(paste("odec", .Platform$dynlib.ext, sep = "")) print("C dll passed to vode") print(system.time( for(i in 1:100) outC <- vode(Y, times, "derivsc", parms = parms, rtol = RTOL, atol = ATOL, mf = MF, jacfunc = "jacc", dllname = "odec", verbose = FALSE, ynames = FALSE, nout = 3) )/100) #------------------------------------------------------------ # DLL TEST 3. Fortran code in odefor.f; DLL passed to R-functions func and jac #------------------------------------------------------------ dyn.load(paste("odefor", .Platform$dynlib.ext, sep = "")) #----------------------# # DEFINING the model: # #----------------------# # rate of change function, now a dll moddll <- function (t, Y, parameters) { FF <-.Fortran("derivsfor", PACKAGE = "odefor", as.integer(3), as.double(t), as.double(Y), Ydot = as.double(rep(0., 3)), Out = as.double(rep(0., 3)), as.integer(3)) return(list(c(dy = FF$Ydot), c(out = FF$Out))) } # the Jacobian, a dll jacdll <- function (t, Y, parameters) { .Fortran("jacfor", PACKAGE = "odefor", as.integer(3), as.double(t), as.double(Y), as.integer(1), as.integer(1), PD = matrix(nr = 3, nc = 3, as.double(0)), as.integer(3), as.double(1:3), as.integer(1))$PD } #----------------------# # RUNNING the model: # #----------------------# print("Fortran dll passed to R-functions, including initialiser") print(system.time( for (i in 1:10) outDLL <- lsode(Y, times, moddll, parms = parms, dllname = "odefor", initfunc = "odefor", rtol = RTOL, atol = ATOL, mf = MF, jacfunc = jacdll, verbose = FALSE, ynames = FALSE ) )/10) #------------------------------------------------------------ # DLL TEST 4. C code in odefor.c; DLL passed to R-functions func and jac #------------------------------------------------------------ dyn.load(paste("odec", .Platform$dynlib.ext, sep = "")) #----------------------# # DEFINING the model: # #----------------------# # rate of change function, now a dll moddll <- function (t, Y, parameters) { FF <-.C("derivsc", PACKAGE = "odec", as.integer(3), as.double(t), as.double(Y), Ydot = as.double(rep(0., 3)), Out = as.double(rep(0., 3)), as.integer(3)) return(list(c(dy = FF$Ydot), c(out = FF$Out))) } # the Jacobian, a dll jacdll <- function (t, Y, parameters) { .C("jacc", PACKAGE = "odec", as.integer(3), as.double(t), as.double(Y), as.integer(1), as.integer(1), PD = matrix(nr = 3, nc = 3, as.double(0)), as.integer(3), as.double(1:3), as.integer(1))$PD } #----------------------# # RUNNING the model: # #----------------------# print("C dll passed to R-functions, including initialiser") print(system.time( for (i in 1:10) outDLLC <- vode(Y, times, moddll, parms = parms, dllname = "odec", rtol = RTOL, atol = ATOL, mf = MF, jacfunc = jacdll, verbose = FALSE, ynames = FALSE ) )/10) #------------------------------------------------------------ # DLL TEST 5. Fortran code in vodefor2.f; DLL passed to R-functions func and jac # NO initialiser #------------------------------------------------------------ dyn.load(paste("odefor2", .Platform$dynlib.ext, sep = "")) #----------------------# # DEFINING the model: # #----------------------# # rate of change function, now a dll moddll <- function (t, Y, parameters) { FF <-.Fortran("derivsfor2", PACKAGE = "odefor2", as.integer(3), as.double(t), as.double(Y), Ydot = as.double(rep(0., 3)), Out = as.double(rep(0., 3)), as.integer(3)) return(list(c(dy = FF$Ydot), c(out = FF$Out))) } # the Jacobian, a dll jacdll <- function (t, Y, parameters) { .Fortran("jacfor2", PACKAGE = "odefor2", as.integer(3), as.double(t), as.double(Y), as.integer(1), as.integer(1), PD = matrix(nr = 3, nc = 3, as.double(0)), as.integer(3), as.double(1:3), as.integer(1))$PD } print("Fortran dll passed to R-functions, NO initialiser") print(system.time( for (i in 1:10) outDLL <- vode(Y, times, moddll, parms = parms, rtol = RTOL, atol = ATOL, mf = MF, jacfunc = jacdll, verbose = FALSE, ynames = FALSE ) )/10) deSolve/inst/doc/dynload/AquaphyForcing.R0000644000176000001440000000703013136461015020122 0ustar ripleyusers#--------------------------------------------------------------------------- # A phytoplankton model with uncoupled carbon and nitrogen assimilation # as a function of light and Dissolved Inorganic Nitrogen (DIN) concentration # # The example demonstrates how to use forcing functions in compiled code # # before trying this code, the FORTRAN program has to be compiled # this can be done in R: # system("R CMD SHLIB AquaphyForcing.f") # do make sure that this file is in the working directory... # (if not, use setwd() ) #--------------------------------------------------------------------------- library(deSolve) ##============================================================================== ## Running the aquaphy model with light and dilution as forcing functions... ##============================================================================== parameters <- c(maxPhotoSynt = 0.125, # mol C/mol C/hr rMortPHY = 0.001, # /hr alpha = -0.125/150, # uEinst/m2/s/hr pExudation = 0.0, # - maxProteinSynt = 0.136, # mol C/mol C/hr ksDIN = 1.0, # mmol N/m3 minpLMW = 0.05, # mol C/mol C maxpLMW = 0.15, # mol C/mol C minQuotum = 0.075, # mol C/mol C maxStorage = 0.23, # /h respirationRate= 0.0001, # /h pResp = 0.4, # - catabolismRate = 0.06, # /h rNCProtein = 0.2, # mol N/mol C inputDIN = 10.0, # mmol N/m3 rChlN = 1) # g Chl/mol N # This is how to compile it; #system("R CMD SHLIB AquaphyForcing.f") dyn.load(paste("AquaphyForcing", .Platform$dynlib.ext, sep = "")) ## ======================= ## The initial conditions ## ======================= times <- seq(10, 24*20, 1) state <- c(DIN = 6.0, # mmol N/m3 PROTEIN = 20.0, # mmol C/m3 RESERVE = 5.0, # mmol C/m3 LMW = 1.0) # mmol C/m3 ## ----------------------------- ## Create the forcing functions ## ----------------------------- ftime <- seq(0, 500, by = 0.5) parval <- pmax(0, 250 + 350*sin(ftime*2*pi/24)+(runif(length(ftime))-0.5)*250) Par <- matrix(nc = 2, c(ftime, parval)) plot(Par, type = "l") Dilu <- matrix(nc = 2, c(0, 1000, 0.01, 0.01)) Forc <- list(Par = Par, Dilu = Dilu) ## ================== ## Running the model ## ================== names(state) <- c("DIN", "PROTEIN", "RESERVE", "LMW") outnames <- c("PAR", "TotalN", "PhotoSynthesis", "NCratio", "ChlCratio", "Chlorophyll") out <- ode(state, times, dllname = "AquaphyForcing", func = "aquaphy2", initfunc = "initaqparms", initforc = "initaqforc", forcings = Forc, parms = parameters, nout = 6, outnames = outnames) out2 <- ode(state, times, dllname = "AquaphyForcing", func = "aquaphy2", initfunc = "initaqparms", initforc = "initaqforc", forcings = Forc, method = "euler", parms = parameters, nout = 6, outnames = outnames) ## ====================== ## Plotting model output ## ====================== par(oma = c(0, 0, 3, 0)) plot(out, which=c("PAR","Chlorophyll","DIN","NCratio"), xlab = "time, hours", ylab = c("uEinst/m2/s","ug/l","mmolN/m3","molN/molC"), type="l",lwd=2) mtext(outer = TRUE, side = 3, "AQUAPHY", cex = 1.5) ## ===================== ## Summary model output ## ===================== t(summary(out)) deSolve/inst/doc/dynload/odeband.R0000644000176000001440000000461113136461015016600 0ustar ripleyuserslibrary(deSolve) ## ======================================================================= ## Example 1 of help file of lsode: ## Various ways to solve the same model. ## ======================================================================= ## the model, 5 state variables f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } ## the Jacobian, written as a full matrix fulljac <- function (t, y, parms) { jac <- matrix(nrow = 5, ncol = 5, byrow = TRUE, data = c(0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1)) return(jac) } ## the Jacobian, written in banded form bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } ## initial conditions and output times yini <- 1:5 times <- 1:20 ## default: stiff method, internally generated, full Jacobian out <- lsode(yini, times, f1, parms = 0, jactype = "fullint") ## stiff method, user-generated full Jacobian out2 <- lsode(yini, times, f1, parms = 0, jactype = "fullusr", jacfunc = fulljac) ## stiff method, internally-generated banded Jacobian ## one nonzero band above (up) and below(down) the diagonal print(system.time( out3 <- lsode(yini, times, f1, parms = 0, jactype = "bandint", bandup = 1, banddown = 1) )) ## stiff method, user-generated banded Jacobian print(system.time( out4 <- lsode(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) )) ## and now a jacobian in a DLL. # system("R CMD SHLIB odeband.f") dyn.load(paste("odeband", .Platform$dynlib.ext, sep = "")) print(system.time( out5 <- lsode(yini, times, "derivsband", parms = 0, jactype = "bandusr", jacfunc = "jacband", bandup = 1, banddown = 1, dllname = "odeband") )) deSolve/inst/doc/dynload/daspkfor.f0000644000176000001440000000502313136461015017037 0ustar ripleyusersc---------------------------------------------------------------- c---------------------------------------------------------------- c--- The chemical model example of daspk c---------------------------------------------------------------- c---------------------------------------------------------------- c -------- daspkdll.f -> daspkdll.dll ------ c compile in R with: system("g77 -shared -o daspkfor.dll daspkfor.f") c or with system("R CMD SHLIB daspkfor.f") c---------------------------------------------------------------- c Initialiser for parameter common block c---------------------------------------------------------------- subroutine daspkfor(daspkparms) external daspkparms integer, parameter :: N = 4 double precision parms(N) common /myparms/parms call daspkparms(N, parms) return end c---------------------------------------------------------------- c residual of rate of change and 1 output variable c---------------------------------------------------------------- subroutine resfor (t, y, ydot, cj, delta, ires, out, ipar) integer :: ires, ipar(*) integer, parameter :: neq = 3 double precision :: t, y(neq), ydot(neq), delta(neq), out(*) double precision :: K, ka, r, prod, ra, rb common /myparms/K,ka,r,prod if(IPar(1) < 1) call rexit("nout should be at least 1") ra = ka* y(3) ! forward rate rb = ka/K *y(1) * y(2) ! backward rate ! residuals of rates of changes delta(3) = -ydot(3) - ra + rb + prod delta(1) = -ydot(1) + ra - rb delta(2) = -ydot(2) + ra - rb - r*y(2) out(1) = y(1) + y(2) + y(3) return end c---------------------------------------------------------------- c The jacobian matrix c---------------------------------------------------------------- subroutine resjacfor (t, y, dy, pd, cj, out, ipar) integer, parameter :: neq = 3 integer :: ipar(*) double precision :: K, ka, r, prod double precision :: pd(neq,neq),y(neq),dy(neq),out(*) common /myparms/K,ka,r,prod ! residuals of rates of changes !res1 = -dD - ka*D + ka/K *A*B + prod PD(1,1) = ka/K *y(2) PD(1,2) = ka/K *y(1) PD(1,3) = -ka -cj !res2 = -dA + ka*D - ka/K *A*B PD(2,1) = -ka/K *y(2) -cj PD(2,2) = -ka/K *y(2) PD(2,3) = ka !res3 = -dB + ka*D - ka/K *A*B - r*B PD(3,1) = -ka/K *y(2) PD(3,2) = -ka/K *y(2) -r -cj PD(3,3) = ka return end deSolve/inst/doc/dynload/zvodedll.f0000644000176000001440000000167713136461015017064 0ustar ripleyusers C The program below uses ZVODE to solve the following system of 2 ODEs: C dz/dt = i*z; dw/dt = -i*w*w*z,z(0) = 1; w(0) = 1/2.1, t = 0 to 2*pi. C Solution: w = 1/(z + 1.1), z = exp(it). As z traces the unit circle, C w traces a circle of radius 10/2.1 with center at 11/2.1. SUBROUTINE FEX (NEQ, T, Y, YDOT, RPAR, IPAR) INTEGER NEQ, IPAR(*) DOUBLE COMPLEX Y(NEQ), YDOT(NEQ), RPAR(*), CMP DOUBLE PRECISION T character(len=100) msg c the imaginary unit i CMP = DCMPLX(0.0D0,1.0D0) YDOT(1) = CMP*Y(1) YDOT(2) = -CMP*Y(2)*Y(2)*Y(1) RETURN END SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD, RPAR, IPAR) INTEGER NEQ, ML, MU, NRPD, IPAR(*) DOUBLE COMPLEX Y(NEQ), PD(NRPD,NEQ), RPAR(*), CMP DOUBLE PRECISION T c the imaginary unit i CMP = DCMPLX(0.0D0,1.0D0) PD(2,3) = -2.0D0*CMP*Y(1)*Y(2) PD(2,1) = -CMP*Y(2)*Y(2) PD(1,1) = CMP RETURN END deSolve/inst/doc/dynload/satresC.c0000644000176000001440000000612113136461015016627 0ustar ripleyusers#include static double parms[16]; static double forc[1]; #define Vc parms[0] /* Volume of central compartment (L) */ #define Vt parms[1] /* Volume of second compartment (L) */ #define kd parms[2] /* 1st order rate constant central <-> second */ /* cmpt (1/hr) */ #define ka parms[3] /* absorption 1st order rate constant (1/hr) */ #define Tm parms[4] /* 0 order resorption rate in the limit of */ /* increasing filtrate PFOA concentrations */ /* (mg/L/hr) */ #define KT parms[5] /* Filtrate cmpt concentration at which */ /* resorption rate is half maximal */ /* (mg/L) */ #define kfil parms[6] /* 1st order rate constant central -> filtrate */ /* cmpartment (1/hour) */ #define Vfil parms[7] /* Volume of filtrate compartment (L) */ #define free parms[8] /* Free fraction PFOA in central compartment (-) */ #define BW parms[9] /* bodyweight (kg) */ #define Dose parms[10] /* dose (mg/kg/day) */ #define Doseint parms[11] /* interval between doses (hours) */ #define Qd parms[12] /* Clearance (kd * Vc) central <-> 2nd cmpt (L/hr) */ #define Qfil parms[13] /* rate of flow to filtrate compartment */ #define MaxTime parms[14] /* Duration of simulation */ #define TDose parms[15] /* actual dose (dose * BW) (mg/day) */ #define TDoseRt forc[0] /* initializer */ void initmod(void (* odeparms)(int *, double *)) { int N = 16; odeparms(&N, parms); } void initforc(void (* odeforcs)(int *, double *)) { int N = 1; odeforcs(&N, forc); } /* Compartments are: Cn for the central compartment Tc for the second comparment Fc for the filtrate compartment Gt for the gut Elim for total eliminated AUC for AUC in the central compartment */ #define Cn y[0] #define Tc y[1] #define Fc y[2] #define Gt y[3] #define Elim y[4] #define AUC y[5] #define Cn_dot ydot[0] #define Tc_dot ydot[1] #define Fc_dot ydot[2] #define Gt_dot ydot[3] #define Elim_dot ydot[4] #define AUC_dot ydot[5] #define MassBal yout[0] /* Derivatives and one output variable */ void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] < 1) error("nout should be at least 1"); Cn_dot = (ka * Gt - Qd * free * Cn + Qd * Tc) / Vc - kfil * Cn * free + Tm * Fc/(KT + Fc); Tc_dot = (Qd * free * Cn - Qd * Tc) / Vt; Fc_dot = (Vc * kfil * Cn * free - Vc * Tm * Fc/(KT + Fc) - Vc * kfil * Fc) / Vfil; Gt_dot = -ka * Gt + TDoseRt; Elim_dot = Vc * kfil * Fc; AUC_dot = Cn; /* Total amount in all compartments, for mass balance */ MassBal = Cn * Vc + Tc * Vt + Fc * Vfil + Gt + Elim; } deSolve/inst/doc/dynload/SCOC.f0000644000176000001440000000203513136461015015755 0ustar ripleyusersc -------- scoc.f -> scoc.dll ------ c compile in R with: system("g77 -shared -o scoc.dll SCOC.f") c or with system("R CMD SHLIB scoc.f") c Initialiser for parameter common block subroutine scocpar(odeparms) external odeparms integer N double precision parms(1) common /myparms/parms N = 1 call odeparms(N, parms) return end c Initialiser for forcing common block subroutine scocforc(odeforcs) external odeforcs integer N double precision forcs(1) common /myforcs/forcs N = 1 call odeforcs(N, forcs) return end c Rate of change and output variables subroutine scocder (neq, t, y, ydot,out,IP) integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*), k, depo common /myparms/k common /myforcs/depo if(IP(1) < 2) call rexit("nout should be at least 2") ydot(1) = -k*y(1) + depo out(1)= k*y(1) out(2)= depo return end deSolve/inst/doc/dynload/ex_Aquaphy.f0000644000176000001440000002136213136461015017336 0ustar ripleyusers c the Aquaphy algal model c -------- Aquaphy.f -> Aquaphy.dll ------ c compile in R with: system("g77 -shared -o Aquaphy Aquaphy") c or with system("R CMD SHLIB Aquaphy") c======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= c Initialise parameter common block c======================================================================= subroutine iniaqua(odeparms) external odeparms double precision pars(19) common /myparms/pars call odeparms(19, pars) return end c======================================================================= c Initialise forcing function common block c======================================================================= subroutine initaqforc(odeforc) external odeparms double precision forcs(1) common /myforcs/forcs call odeforc(1, forcs) return end c======================================================================= c Algal dynamics - light an on-off function c======================================================================= subroutine aquaphy (neq, t, y, ydot,out,IP) implicit none integer neq, ip(*) double precision t, y(*), ydot(*), out(*) c parameters double precision maxPhotoSynt,rMortPHY,alpha,pExudation, & & maxProteinSynt,ksDIN,minpLMW,maxpLMW,minQuotum, & & maxStorage,respirationRate,pResp,catabolismRate, & & dilutionRate,rNCProtein,inputDIN,rChlN,parMean, & & dayLength common /myparms/ maxPhotoSynt,rMortPHY,alpha,pExudation, & & maxProteinSynt,ksDIN,minpLMW,maxpLMW,minQuotum, & & maxStorage,respirationRate,pResp,catabolismRate, & & dilutionRate,rNCProtein,inputDIN,rChlN,parMean, & & dayLength c variables double precision :: & & DIN,PROTEIN,RESERVE,LMW,dLMW,dRESERVE,dPROTEIN,dDIN,PAR, & & PhytoC,PhytoN,NCratio,Chlorophyll,TotalN,ChlCratio,PartLMW, & & hourofday, Limfac,PhotoSynthesis,Exudation,MonodQuotum, & & ProteinSynthesis,Storage,Respiration,Catabolism c ------------------------------------------------------------------------ if(ip(1) < 6) call rexit("nout should at least be 6") DIN = y(1) PROTEIN = y(2) RESERVE = y(3) LMW = y(4) c PAR, on-off function depending on the hour within a day hourofday = mod(t,24.d0) if (hourofday < dayLength) THEN PAR = parMean else PAR = 0.d0 endif c the output variables - all components contain carbon c only proteins contain nitrogen PhytoC = PROTEIN + RESERVE + LMW PhytoN = PROTEIN * rNCProtein NCratio = PhytoN / PhytoC Chlorophyll = PhytoN * rChlN TotalN = PhytoN + DIN ChlCratio = Chlorophyll / PhytoC c the rates, in mmol/hr PartLMW = LMW / PhytoC Limfac = min(1.d0,(maxpLMW -PartLMW)/(maxpLMW-minpLMW)) Limfac = max(0.d0,Limfac) PhotoSynthesis = maxPhotoSynt*Limfac * & & (1.d0-exp(alpha*PAR/maxPhotoSynt)) * PROTEIN Exudation = pExudation * PhotoSynthesis MonodQuotum = max(0.d0,LMW / PROTEIN - minQuotum) ProteinSynthesis= maxProteinSynt*MonodQuotum & & * DIN / (DIN+ksDIN) * PROTEIN Storage = maxStorage *MonodQuotum * PROTEIN Respiration = respirationRate * LMW & & + pResp * ProteinSynthesis Catabolism = catabolismRate * RESERVE c the rates of change of state variables; includes dilution effects (last term) dLMW = PhotoSynthesis + Catabolism & & - Exudation - Storage - Respiration - ProteinSynthesis & & - dilutionRate * LMW dRESERVE = Storage - Catabolism - dilutionRate * RESERVE dPROTEIN = ProteinSynthesis - dilutionRate * PROTEIN dDIN = -ProteinSynthesis * rNCProtein & & - dilutionRate * (DIN - inputDIN) c the vector with rate of changes ydot(1) = dDIN ydot(2) = dPROTEIN ydot(3) = dRESERVE ydot(4) = dLMW c the ordinary variables out(1) = PAR out(2) = TotalN out(3) = PhotoSynthesis out(4) = NCratio out(5) = ChlCratio out(6) = Chlorophyll return end subroutine Aquaphy c======================================================================= c Algal dynamics c======================================================================= subroutine aquaphyforc (neq, t, y, ydot,out,IP) implicit none integer neq, ip(*) double precision t, y(*), ydot(*), out(*) c parameters double precision maxPhotoSynt,rMortPHY,alpha,pExudation, & & maxProteinSynt,ksDIN,minpLMW,maxpLMW,minQuotum, & & maxStorage,respirationRate,pResp,catabolismRate, & & dilutionRate,rNCProtein,inputDIN,rChlN,parMean, & & dayLength common /myparms/ maxPhotoSynt,rMortPHY,alpha,pExudation, & & maxProteinSynt,ksDIN,minpLMW,maxpLMW,minQuotum, & & maxStorage,respirationRate,pResp,catabolismRate, & & dilutionRate,rNCProtein,inputDIN,rChlN,parMean, & & dayLength c PAR is a forcing function here... double precision PAR common /myforcs/PAR c variables double precision :: & & DIN,PROTEIN,RESERVE,LMW,dLMW,dRESERVE,dPROTEIN,dDIN, & & PhytoC,PhytoN,NCratio,Chlorophyll,TotalN,ChlCratio,PartLMW, & & Limfac,PhotoSynthesis,Exudation,MonodQuotum, & & ProteinSynthesis,Storage,Respiration,Catabolism c ------------------------------------------------------------------------ if(ip(1) < 6) call rexit("nout should at least be 6") DIN = y(1) PROTEIN = y(2) RESERVE = y(3) LMW = y(4) c the output variables PhytoC = PROTEIN + RESERVE + LMW ! all components contain carbon PhytoN = PROTEIN * rNCProtein ! only proteins contain nitrogen NCratio = PhytoN / PhytoC Chlorophyll = PhytoN * rChlN TotalN = PhytoN + DIN ChlCratio = Chlorophyll / PhytoC c the rates, in mmol/hr PartLMW = LMW / PhytoC Limfac = min(1.d0,(maxpLMW -PartLMW)/(maxpLMW-minpLMW)) Limfac = max(0.d0,Limfac) PhotoSynthesis = maxPhotoSynt*Limfac * & & (1.d0-exp(alpha*PAR/maxPhotoSynt)) * PROTEIN Exudation = pExudation * PhotoSynthesis MonodQuotum = max(0.d0,LMW / PROTEIN - minQuotum) ProteinSynthesis= maxProteinSynt*MonodQuotum & & * DIN / (DIN+ksDIN) * PROTEIN Storage = maxStorage *MonodQuotum * PROTEIN Respiration = respirationRate * LMW & & + pResp * ProteinSynthesis Catabolism = catabolismRate * RESERVE c the rates of change of state variables; includes dilution effects (last term) dLMW = PhotoSynthesis + Catabolism & & - Exudation - Storage - Respiration - ProteinSynthesis & & - dilutionRate * LMW dRESERVE = Storage - Catabolism - dilutionRate * RESERVE dPROTEIN = ProteinSynthesis - dilutionRate * PROTEIN dDIN = -ProteinSynthesis * rNCProtein & & - dilutionRate * (DIN - inputDIN) c the vector with rate of changes ydot(1) = dDIN ydot(2) = dPROTEIN ydot(3) = dRESERVE ydot(4) = dLMW c the ordinary variables out(1) = PAR out(2) = TotalN out(3) = PhotoSynthesis out(4) = NCratio out(5) = ChlCratio out(6) = Chlorophyll return end subroutine aquaphyforc deSolve/inst/doc/dynload/ex_CCL4model.c0000644000176000001440000000775013136461015017436 0ustar ripleyusers/* c the CCl4 inhalation model -------- ex_ccl4model.c -> ex_ccl4model.dll ------ compile in R with: system("gcc -shared -o ex_ccl4model.dll ex_ccl4model.c") or with system("R CMD SHLIB ex_ccl4model.c") */ #include static double parms[21]; #define BW parms[0] #define QP parms[1] #define QC parms[2] #define VFC parms[3] #define VLC parms[4] #define VMC parms[5] #define QFC parms[6] #define QLC parms[7] #define QMC parms[8] #define PLA parms[9] #define PFA parms[10] #define PMA parms[11] #define PTA parms[12] #define PB parms[13] #define MW parms[14] #define VMAX parms[15] #define KM parms[16] #define CONC parms[17] #define KL parms[18] #define RATS parms[19] #define VCHC parms[20] double V[5], P[4], AI0, VTC, Q[4]; #define DOSE out[0] #define MASS out[1] #define CP out[2] /* c======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= 2c Initialise primary parameter common block c======================================================================= */ void initccl4(void (* odeparms)(int *, double *)) { void derived(); int N=21; odeparms(&N, parms); derived(); } /*======================================================================= In this "event", state variable 1 is increased with 1. DOES NOT WORK... ======================================================================= */ void eventfun(int *n, double *t, double *y) { y[0] = y[0] + 1; } /*======================================================================= c Calculate derived parameters from primary parameters c======================================================================= */ void derived () { // Fraction viscera (kg/(kg BW)) VTC = 0.91 - (VLC+VFC+VMC); // Net chamber volume V[0] = VCHC - RATS*BW; V[1] = VMC*BW; V[2] = VTC*BW; V[3] = VFC*BW; V[4] = VLC*BW; // Initial amt. in chamber (mg) AI0 = CONC*V[0]*MW/24450.; P[0] = PMA/PB; P[1] = PTA/PB; P[2] = PFA/PB; P[3] = PLA/PB; Q[2] = QFC*QC; Q[3] = QLC*QC; Q[0] = QMC*QC; Q[1] = QC - (Q[0]+Q[3]+Q[2]); } /*======================================================================= c The dynamic model c======================================================================= */ void derivsccl4 (int *neq, double *t, double *y, double *ydot, double *out, int *ip) { double vconc[5], tconc[5], CA, CX, RAM; int i; if (ip[0] < 3) error("nout should be at least 3"); /*c y = AI, AAM, AT, AF, AL CLT, AM where clt = the area under the concentration-time curve in the liver AM = total amount metabolised concentrations */ for (i =0; i<5; i++) { tconc[i] = y[i]/V[i]; } /* vconc(1) is conc in mixed venous blood */ vconc[0] = 0.0; for (i = 1; i<5; i++){ vconc[i] = tconc[i]/P[i-1]; vconc[0] = vconc[0] + vconc[i]*Q[i-1]/QC ; } /* CA is conc in arterial blood */ CA = (QC * vconc[0] + QP * tconc[0])/ (QC + QP/PB); /* Exhaled chemical */ CX = CA/PB; /* metabolisation rate */ RAM = VMAX*vconc[4]/(KM + vconc[4]); /* the rate of change */ ydot[0] = RATS*QP*(CX - tconc[0]) - KL*y[0]; for ( i = 1; i<5; i++) ydot[i] = Q[i-1]*(CA-vconc[i]); ydot[4] = ydot[4] - RAM; ydot[5] = tconc[4]; ydot[6] = RAM; /* the mass balance (MASS=AAM+AT+AF+AL+AM), should be constant */ DOSE = AI0 - y[0]; MASS = (y[1]+y[2]+y[3]+y[4]+y[6])*RATS; CP = tconc[0]*24450.0/MW; } deSolve/inst/doc/dynload/ex_CCL4model.f0000644000176000001440000001123613136461015017433 0ustar ripleyusers c the CCl4 inhalation model c based on the demo in odesolve c -------- ccl4model.f -> ccl4model.dll ------ c compile in R with: system("g77 -shared -o ccl4model.dll ccl4model.f") c or with system("R CMD SHLIB ccl4model.f") c======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= c Initialise primary parameter common block c======================================================================= subroutine initccl4(odeparms) external odeparms integer N c parameters are divided into primary and derived parameters double precision pars(21), derivedpars(15) common /myparms/pars,derivedpars N = 21 call odeparms(N, pars) call derived() return end c======================================================================= c In this "event", state variable 1 is increased with 1. DOES NOT WORK... c======================================================================= subroutine eventfun(n, t, y) integer n double precision t, y(n) y(1) = y(1) + 1 end subroutine c======================================================================= c Calculate derived parameters from primary parameters c======================================================================= subroutine derived implicit none double precision BW,QP,QC,VFC,VLC,VMC,QFC,QLC,QMC,PLA,PFA, & & PMA,PTA,PB,MW,VMAX,KM,CONC,KL,RATS,VCHC, & & VCH,VM,VT,VF,VL,PM,PT,PF,PL,AI0,VTC,QM,QT,QF,QL common /myparms/ BW,QP,QC,VFC,VLC,VMC,QFC,QLC,QMC,PLA,PFA, & & PMA,PTA,PB,MW,VMAX,KM,CONC,KL,RATS,VCHC, & VCH,VM,VT,VF,VL,PM,PT,PF,PL,AI0,VTC,QM,QT,QF,QL c Fraction viscera (kg/(kg BW)) VTC = 0.91 - (VLC+VFC+VMC) c Net chamber volume VCH = VCHC - RATS*BW VM = VMC*BW VT = VTC*BW VF = VFC*BW VL = VLC*BW c Initial amt. in chamber (mg) AI0 = CONC*VCH*MW/24450. PL = PLA/PB PF = PFA/PB PT = PTA/PB PM = PMA/PB QF = QFC*QC QL = QLC*QC QM = QMC*QC QT = QC - (QF+QL+QM) return end subroutine derived c======================================================================= c The dynamic model c======================================================================= subroutine derivsccl4 (neq, t, y, ydot,out,IP) implicit none integer neq, IP(*), i double precision t, y(neq), ydot(neq), out(*) double precision BW,QP,QC,VFC,VLC,VMC,QFC,QLC,QMC,PLA,PFA, & & PMA,PTA,PB,MW,VMAX,KM,CONC,KL,RATS,VCHC, & & V(5), P(4),AI0,VTC,Q(4) c here we lump parameters Vx, Qx and Px into vectors common /myparms/ BW,QP,QC,VFC,VLC,VMC,QFC,QLC,QMC,PLA,PFA, & & PMA,PTA,PB,MW,VMAX,KM,CONC,KL,RATS,VCHC, & & V, P, AI0,VTC, Q double precision tconc(5), vconc(5), dose, mass, cp, ca, cx, RAM c check if provision has been made for at least 3 output variables if (IP(1) < 3) call rexit("nout should be at least 3") c y = AI, AAM, AT, AF, AL CLT, AM c where clt = the area under the concentration-time curve in the liver c AM = total amount metabolised c concentrations do i =1,5 tconc(i) = y(i)/v(i) enddo c vconc(1) is conc in mixed venous blood vconc(1) = 0.d0 do i = 2,5 vconc(i) = tconc(i)/P(i-1) vconc(1) = vconc(1) + vconc(i)*Q(i-1)/QC enddo c CA is conc in arterial blood CA = (QC * Vconc(1) + QP * tconc(1))/ (QC + QP/PB) c Exhaled chemical CX = CA/PB c metabolisation rate RAM = VMAX*Vconc(5)/(KM + Vconc(5)) c the rate of change ydot(1) = RATS*QP*(CX - tconc(1)) - KL*y(1) do i = 2,5 ydot(i) = Q(i-1)*(CA-vconc(i)) enddo ydot(5) = ydot(5) - RAM ydot(6) = tconc(5) ydot(7) = RAM c the mass balance (MASS=AAM+AT+AF+AL+AM), should be constant DOSE = AI0 - y(1) MASS = (y(2)+y(3)+y(4)+y(5)+y(7))*RATS CP = tconc(1)*24450.0/MW out(1) = DOSE out(2) = MASS out(3) = CP return end deSolve/inst/doc/dynload/Aquaphy.f0000644000176000001440000001122613136461015016640 0ustar ripleyusers c the Aquaphy algal model c -------- Aquaphy.f -> Aquaphy.dll ------ c compile in R with: system("g77 -shared -o Aquaphy Aquaphy") c or with system("R CMD SHLIB Aquaphy") c======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= c Initialise parameter common block c======================================================================= subroutine initaquaphy(odeparms) external odeparms double precision pars(19) common /myparms/pars call odeparms(19, pars) return end c======================================================================= c Algal dynamics c======================================================================= subroutine aquaphy (neq, t, y, ydot,out,IP) implicit none integer neq, ip(*) double precision t, y(*), ydot(*), out(*) c parameters double precision maxPhotoSynt,rMortPHY,alpha,pExudation, & & maxProteinSynt,ksDIN,minpLMW,maxpLMW,minQuotum, & & maxStorage,respirationRate,pResp,catabolismRate, & & dilutionRate,rNCProtein,inputDIN,rChlN,parMean, & & dayLength common /myparms/ maxPhotoSynt,rMortPHY,alpha,pExudation, & & maxProteinSynt,ksDIN,minpLMW,maxpLMW,minQuotum, & & maxStorage,respirationRate,pResp,catabolismRate, & & dilutionRate,rNCProtein,inputDIN,rChlN,parMean, & & dayLength c variables double precision :: & & DIN,PROTEIN,RESERVE,LMW,dLMW,dRESERVE,dPROTEIN,dDIN,PAR, & & PhytoC,PhytoN,NCratio,Chlorophyll,TotalN,ChlCratio,PartLMW, & & hourofday, Limfac,PhotoSynthesis,Exudation,MonodQuotum, & & ProteinSynthesis,Storage,Respiration,Catabolism c ------------------------------------------------------------------------ if(ip(1) < 6) call rexit("nout should at least be 6") DIN = y(1) PROTEIN = y(2) RESERVE = y(3) LMW = y(4) c PAR, on-off function depending on the hour within a day hourofday = mod(t,24.d0) if (hourofday < dayLength) THEN PAR = parMean else PAR = 0.d0 endif c the output variables PhytoC = PROTEIN + RESERVE + LMW ! all components contain carbon PhytoN = PROTEIN * rNCProtein ! only proteins contain nitrogen NCratio = PhytoN / PhytoC Chlorophyll = PhytoN * rChlN TotalN = PhytoN + DIN ChlCratio = Chlorophyll / PhytoC c the rates, in mmol/hr PartLMW = LMW / PhytoC Limfac = min(1.d0,(maxpLMW -PartLMW)/(maxpLMW-minpLMW)) Limfac = max(0.d0,Limfac) PhotoSynthesis = maxPhotoSynt*Limfac * & & (1.d0-exp(alpha*PAR/maxPhotoSynt)) * PROTEIN Exudation = pExudation * PhotoSynthesis MonodQuotum = max(0.d0,LMW / PROTEIN - minQuotum) ProteinSynthesis= maxProteinSynt*MonodQuotum & & * DIN / (DIN+ksDIN) * PROTEIN Storage = maxStorage *MonodQuotum * PROTEIN Respiration = respirationRate * LMW & & + pResp * ProteinSynthesis Catabolism = catabolismRate * RESERVE c the rates of change of state variables; includes dilution effects (last term) dLMW = PhotoSynthesis + Catabolism & & - Exudation - Storage - Respiration - ProteinSynthesis & & - dilutionRate * LMW dRESERVE = Storage - Catabolism - dilutionRate * RESERVE dPROTEIN = ProteinSynthesis - dilutionRate * PROTEIN dDIN = -ProteinSynthesis * rNCProtein & & - dilutionRate * (DIN - inputDIN) c the vector with rate of changes ydot(1) = dDIN ydot(2) = dPROTEIN ydot(3) = dRESERVE ydot(4) = dLMW c the ordinary variables out(1) = PAR out(2) = TotalN out(3) = PhotoSynthesis out(4) = NCratio out(5) = ChlCratio out(6) = Chlorophyll return end subroutine Aquaphy deSolve/inst/doc/dynload/radaudaedll.R0000644000176000001440000000545613136461015017456 0ustar ripleyusers## ============================================================================= ## Example 3: DAE ## Car axis problem, index 3 DAE, 8 differential, 2 algebraic equations ## from ## F. Mazzia and C. Magherini. Test Set for Initial Value Problem Solvers, ## release 2.4. Department ## of Mathematics, University of Bari and INdAM, Research Unit of Bari, ## February 2008. ## Available at http://www.dm.uniba.it/~testset. ## ============================================================================= ## Problem is written as M*y = f(t,y,p). library(deSolve) ## ----------------------------------------------------------------------------- ## Implemented in R-code ## ----------------------------------------------------------------------------- ## caraxisfun implements the right-hand side: caraxisfun <- function(t, y, parms) { with(as.list(c(y, parms)), { yb <- r * sin(w * t) xb <- sqrt(L * L - yb * yb) Ll <- sqrt(xl^2 + yl^2) Lr <- sqrt((xr - xb)^2 + (yr - yb)^2) dxl <- ul; dyl <- vl; dxr <- ur; dyr <- vr dul <- (L0-Ll) * xl/Ll + 2 * lam2 * (xl-xr) + lam1*xb dvl <- (L0-Ll) * yl/Ll + 2 * lam2 * (yl-yr) + lam1*yb - k * g dur <- (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr) dvr <- (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k * g c1 <- xb * xl + yb * yl c2 <- (xl - xr)^2 + (yl - yr)^2 - L * L list(c(dxl, dyl, dxr, dyr, dul, dvl, dur, dvr, c1, c2)) }) } eps <- 0.01; M <- 10; k <- M * eps^2/2; L <- 1; L0 <- 0.5; r <- 0.1; w <- 10; g <- 1 parameter <- c(eps = eps, M = M, k = k, L = L, L0 = L0, r = r, w = w, g = g) yini <- c(xl = 0, yl = L0, xr = L, yr = L0, ul = -L0/L, vl = 0, ur = -L0/L, vr = 0, lam1 = 0, lam2 = 0) # the mass matrix Mass <- diag(nrow = 10, 1) Mass[5,5] <- Mass[6,6] <- Mass[7,7] <- Mass[8,8] <- M * eps * eps/2 Mass[9,9] <- Mass[10,10] <- 0 Mass # index of the variables: 4 of index 1, 4 of index 2, 2 of index 3 index <- c(4, 4, 2) times <- seq(0, 3, by = 0.01) out <- radau(y = yini, mass = Mass, times = times, func = caraxisfun, parms = parameter, nind = index) plot(out, which = 1:4, type = "l", lwd = 2) ## ----------------------------------------------------------------------------- ## Implemented in FORTRAN ## ----------------------------------------------------------------------------- # compiling... # system("R CMD SHLIB radaudae.f") dyn.load(paste("radaudae", .Platform$dynlib.ext, sep = "")) outDLL <- daspk(y = yini, mass = Mass, times = times, func = "caraxis", initfunc = "initcaraxis", parms = parameter, dllname = "radaudae", nind = index) dyn.unload(paste("radaudae", .Platform$dynlib.ext, sep = "")) deSolve/inst/doc/dynload/daspkdll.R0000644000176000001440000000634613136461015017011 0ustar ripleyusers#--------------------------------------------------------------------------- # The chemical model example of daspk, implemented as a DLL # before trying this code, the FORTRAN program has to be compiled # this can be done in R: # system("R CMD SHLIB daspkfor.f") # do make sure that this file is in the working directory... # (if not, use setwd() ) #--------------------------------------------------------------------------- # Dissociation constant K <- 1 # parameters pars <- c(K = K , ka = 1e6, # forward rate r = 1 , prod = 0.1) #--------------------------------------------------------- # Chemical problem formulation as R-function # Note: here it is written as the residuals of the rates of changes # This differs from the example in the daspk help file #--------------------------------------------------------- Chemres_ODE <- function (t, y, dy, pars){ with (as.list(c(y, dy, pars)), { ra <- ka * D # forward rate rb <- ka/K * A * B # backward rate # residuals of rates of changes res1 <- -dD - ra + rb + prod res2 <- -dA + ra - rb res3 <- -dB + ra - rb - r*B return(list(res = c(res1, res2, res3), CONC = A + B + D)) }) } Chemjac_ODE <- function (t, y, dy, pars, cj) { with (as.list(c(y, dy, pars)), { # residuals of rates of changes #res1 = -dD - ka*D + ka/K *A*B + prod PD[1, 1] <- ka/K * B PD[1, 2] <- ka/K * A PD[1, 3] <- -ka - cj #res2 = -dA + ka*D - ka/K * A*B PD[2, 1] <- -ka/K * B - cj PD[2, 2] <- -ka/K * A PD[2, 3] <- ka #res3 = -dB + ka*D - ka/K * A*B - r*B PD[3, 1] <- -ka/K * B PD[3, 2] <- -ka/K * A -r -cj PD[3, 3] <- ka return(PD) }) } times <- seq(0, 100, by = 2) # Initial conc and rate of change; D is in equilibrium with A,B y <- c(A = 2, B = 3, D = 2*3/K) dy <- c(dA = 0, dB = 0, dD = 0) PD <- matrix(nr = 3, nc = 3, 0) # ODE model solved with daspk - using res print("ODE solved with daspk - using res, no jac, in R") print(system.time( ODE_R <- daspk(y = y, dy = dy, times = times, res = Chemres_ODE, parms = pars, atol = 1e-10, rtol = 1e-10) )) print("ODE solved with daspk - using res, jacres, in R") print(system.time( ODE_R2 <- daspk(y = y, dy = dy, times = times, res = Chemres_ODE, jacres = Chemjac_ODE, jactype = "fullusr", parms = pars, atol = 1e-10, rtol = 1e-10) )) # plotting output plot(ODE_R, ODE_R2, xlab = "time", ylab = "conc", type = c("l", "p"), pch = c(NA, 1)) legend("bottomright", lty = c(1, NA), pch = c(NA, 1), col = c("black", "red"), legend = c("ODE", "ODE+JAC")) # same, now using DLL dyn.load(paste("daspkfor", .Platform$dynlib.ext, sep = "")) print("ODE solved with daspk - using res, no jac, DLL") print(system.time( ODE_dll <- daspk(y = y, dy = dy, times = times, res = "resfor", dllname = "daspkfor", parms = pars, atol = 1e-10, rtol = 1e-10, nout = 1) )) print("ODE solved with daspk - using res, jacres, DLL") print(system.time( ODE_dll2<- daspk(y = y, dy = dy, times = times, res = "resfor", jacres = "resjacfor", dllname = "daspkfor", parms = pars, atol = 1e-10, rtol = 1e-10, nout = 1) )) max(abs(ODE_R-ODE_dll)) max(abs(ODE_R2-ODE_dll2)) deSolve/inst/doc/dynload/ex_Aquaphy.c0000644000176000001440000001536613136461015017342 0ustar ripleyusers/* file ex_aquaphy.c The Aquaphy algal model -------- ex_Aquaphy.c -> ex_Aquaphy.dll ------ compile in R with: system("gcc -shared -o Aquaphy Aquaphy") or with system("R CMD SHLIB ex_Aquaphy") */ #include static double parms[19]; #define maxPhotoSynt parms[0] #define rMortPHY parms[1] #define alpha parms[2] #define pExudation parms[3] #define maxProteinSynt parms[4] #define ksDIN parms[5] #define minpLMW parms[6] #define maxpLMW parms[7] #define minQuotum parms[8] #define maxStorage parms[9] #define respirationRate parms[10] #define pResp parms[11] #define catabolismRate parms[12] #define dilutionRate parms[13] #define rNCProtein parms[14] #define inputDIN parms[15] #define rChlN parms[16] #define parMean parms[17] #define dayLength parms[18] static double forcs[1]; #define Light forcs[0] #define DIN y[0] #define PROTEIN y[1] #define RESERVE y[2] #define LMW y[3] #define dDIN ydot[0] #define dPROTEIN ydot[1] #define dRESERVE ydot[2] #define dLMW ydot[3] #define PAR out[0] #define TotalN out[1] #define PhotoSynthesis out[2] #define NCratio out[3] #define ChlCratio out[4] #define Chlorophyll out[5] /*======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= c Initialise parameter common block c======================================================================= */ void iniaqua(void (* odeparms)(int *, double *)) { int N=19; odeparms(&N, parms); } /* c======================================================================= c Initialise forcing function common block c======================================================================= */ void initaqforc(void (* odeforc)(int *, double *)) { int N=1; odeforc(&N, forcs); } /* c======================================================================= c Algal dynamics - light an on-off function c======================================================================= */ void aquaphy (int *neq, double *t, double *y, double *ydot, double *out, int *ip) { double PhytoC,PhytoN,PartLMW,Limfac,Exudation,MonodQuotum,hourofday, ProteinSynthesis,Storage,Respiration,Catabolism; if(ip[0] < 6) error("nout should at least be 6"); /* PAR, on-off function depending on the hour within a day*/ hourofday = fmod(*t,24.0); if (hourofday < dayLength) PAR = parMean; else PAR = 0.0; /* the output variables - all components contain carbon only proteins contain nitrogen */ PhytoC = PROTEIN + RESERVE + LMW; PhytoN = PROTEIN * rNCProtein; NCratio = PhytoN / PhytoC; Chlorophyll = PhytoN * rChlN; TotalN = PhytoN + DIN; ChlCratio = Chlorophyll / PhytoC; /* the rates, in mmol/hr */ PartLMW = LMW / PhytoC; Limfac = fmin(1.0,(maxpLMW -PartLMW)/(maxpLMW-minpLMW)); Limfac = fmax(0.0,Limfac); PhotoSynthesis = maxPhotoSynt*Limfac * (1.0-exp(alpha*PAR/maxPhotoSynt)) * PROTEIN; Exudation = pExudation * PhotoSynthesis; MonodQuotum = fmax(0.0,LMW / PROTEIN - minQuotum); ProteinSynthesis= maxProteinSynt*MonodQuotum * DIN / (DIN+ksDIN) * PROTEIN; Storage = maxStorage *MonodQuotum * PROTEIN; Respiration = respirationRate * LMW + pResp * ProteinSynthesis; Catabolism = catabolismRate * RESERVE; /* the rates of change of state variables; includes dilution effects (last term) */ dLMW = PhotoSynthesis + Catabolism - Exudation - Storage - Respiration - ProteinSynthesis - dilutionRate * LMW; dRESERVE = Storage - Catabolism - dilutionRate * RESERVE; dPROTEIN = ProteinSynthesis - dilutionRate * PROTEIN; dDIN = -ProteinSynthesis * rNCProtein - dilutionRate * (DIN - inputDIN); } /* Algal dynamics with forcings c======================================================================= */ void aquaphyforc (int *neq, double *t, double *y, double *ydot, double *out, int *ip) { double PhytoC,PhytoN,PartLMW,Limfac,Exudation,MonodQuotum, ProteinSynthesis,Storage,Respiration,Catabolism; if(ip[0] < 6) error("nout should at least be 6"); PAR = Light; /* the output variables - all components contain carbon only proteins contain nitrogen */ PhytoC = PROTEIN + RESERVE + LMW; PhytoN = PROTEIN * rNCProtein; NCratio = PhytoN / PhytoC; Chlorophyll = PhytoN * rChlN; TotalN = PhytoN + DIN; ChlCratio = Chlorophyll / PhytoC; /* the rates, in mmol/hr */ PartLMW = LMW / PhytoC; Limfac = fmin(1.0,(maxpLMW -PartLMW)/(maxpLMW-minpLMW)); Limfac = fmax(0.0,Limfac); PhotoSynthesis = maxPhotoSynt*Limfac * (1.0-exp(alpha*PAR/maxPhotoSynt)) * PROTEIN; Exudation = pExudation * PhotoSynthesis; MonodQuotum = fmax(0.0,LMW / PROTEIN - minQuotum); ProteinSynthesis= maxProteinSynt*MonodQuotum * DIN / (DIN+ksDIN) * PROTEIN; Storage = maxStorage *MonodQuotum * PROTEIN; Respiration = respirationRate * LMW + pResp * ProteinSynthesis; Catabolism = catabolismRate * RESERVE; /* the rates of change of state variables; includes dilution effects (last term) */ dLMW = PhotoSynthesis + Catabolism - Exudation - Storage - Respiration - ProteinSynthesis - dilutionRate * LMW; dRESERVE = Storage - Catabolism - dilutionRate * RESERVE; dPROTEIN = ProteinSynthesis - dilutionRate * PROTEIN; dDIN = -ProteinSynthesis * rNCProtein - dilutionRate * (DIN - inputDIN); } deSolve/inst/doc/dynload/odefor.f0000644000176000001440000000253113136461015016505 0ustar ripleyusersc -------- odefor.f -> odefor.dll ------ c compile in R with: system("g77 -shared -o odefor.dll odefor.f") c or with system("R CMD SHLIB odefor.f") c Initialiser for parameter common block subroutine odefor(odeparms) external odeparms integer N double precision parms(3) common /myparms/parms N = 3 call odeparms(N, parms) return end c Rate of change and 3 output variables subroutine derivsfor (neq, t, y, ydot,out,IP) integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*), k1, k2, k3 common /myparms/k1,k2,k3 if(IP(1) < 3) call rexit("nout should be at least 3") ydot(1) = -k1*y(1) + k2*y(2)*y(3) ydot(3) = k3*y(2)*y(2) ydot(2) = -ydot(1) - ydot(3) out(1)= y(1)+y(2)+y(3) out(2)= y(1)*2 out(3)= IP(1) return end c The jacobian matrix subroutine jacfor (neq, t, y, ml, mu, pd, nrowpd,RP,IP) integer neq, ml, mu, nrowpd ,IP(*) double precision y(*), pd(nrowpd,*), t, RP(*), k1, k2, k3 common /myparms/k1,k2,k3 pd(1,1) = -k1 pd(2,1) = k1 pd(3,1) = 0.0 pd(1,2) = k2*y(3) pd(2,2) = -k2*y(3) - 2*k3*y(2) pd(3,2) = 2*k3*y(2) pd(1,3) = k2*y(2) pd(2,3) = -k2*y(2) pd(3,3) = 0.0 return end deSolve/inst/doc/dynload/lsodardll.R0000644000176000001440000000265313136461015017170 0ustar ripleyusers#--------------------------------------------------------------------------- # The first example of lsodar, implemented as a FORTRAN DLL # before trying this code, the fortran program has to be compiled # this can be done in R: # system("R CMD SHLIB lsodarfor.f") # do make sure that this file is in the working directory... # (if not, use setwd() ) #--------------------------------------------------------------------------- Fun <- function (t, y, parms) { with (as.list(parms),{ ydot <- vector(len = 3) ydot[1] <- aa * y[1] + bb * y[2] * y[3] ydot[3] <- cc * y[2] * y[2] ydot[2] <- -ydot[1] - ydot[3] return(list(ydot, ytot = sum(y))) }) } rootFun <- function (t, y, parms) { yroot <- vector(len=2) yroot[1] <- y[1] - 1.e-4 yroot[2] <- y[3] - 1e-2 return(yroot) } y <- c(1, 0, 0) times <- c(0, 0.4*10^(0:7)) parms <- c(aa = -.04, bb = 1.e4, cc= 3.e7) #using the R-function out <- lsodar(y = y, times = times, fun = Fun, rootfun = rootFun, rtol = 1e-4, atol = c(1e-6, 1e-10, 1e-6), parms = parms) dyn.load(paste("lsodarfor", .Platform$dynlib.ext, sep = "")) out2 <- lsodar(y = y, times = times, fun = "modfor", rootfun = "myroot", dllname = "lsodarfor", rtol = 1e-4, atol = c(1e-6, 1e-10, 1e-6), parms = parms, nroot = 2, nout = 1) print(paste("root is found for eqn", which(attributes(out2)$iroot==1))) print(out[nrow(out2),]) print (max(abs(out[,1:4]-out2[,1:4])))deSolve/inst/doc/dynload/zvodedll.R0000644000176000001440000000455013136461015017031 0ustar ripleyusers## ============================================================================= ## Implements the test model, as given in the dvode code. ## before trying this code, the FORTRAN program has to be compiled ## this can be done in R: ## system("R CMD SHLIB zvodedll.f") ## do make sure that these files are in the working directory... ## (if not, use setwd() ) ## ============================================================================= ## the example in "zvode.f", ## ## df/dt = 1i*f ## dg/dt = -1i*g*g*f ## ## Initial values are ## g(0) = 1/2.1 and ## z(0) = 1 (same as above) ## ## The analytical solution is ## f(t) = exp(1i*t) (same as above) ## g(t) = 1/(f(t) + 1.1) library(deSolve) ## ----------------------------------------------------------------------------- ## implementation in R ## ----------------------------------------------------------------------------- ZODE2 <- function(Time, State, Pars) { with(as.list(State), { df <- 1i * f dg <- -1i*g*g*f return(list(c(df, dg))) }) } pars <- NULL yini <- c(f = 1+0i, g = 1/2.1+0i) times <- seq(0, 2*pi, length = 100) print(system.time( out <- zvode(func = ZODE2, y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10) )) analytical <- cbind(f = exp(1i*times), g = 1/(exp(1i*times)+1.1)) #compare numerical solution and the two analytical ones: tail(cbind(out[, 2], analytical[, 1])) #---------------------- # the Jacobian: #---------------------- jac <- function (t, Y, parameters) { PD[2, 2] = -2.0*1i*Y[1]*Y[2] PD[2, 1] = -1i*Y[2]*Y[2] PD[1, 2] = 0. PD[1, 1] = 1i return(PD) } print(system.time( out2 <- zvode(func = ZODE2, jacfunc = jac, y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10) )) tail(cbind(out2[, 2], analytical[, 1])) ## ----------------------------------------------------------------------------- ## implementation in FORTRAN ## ----------------------------------------------------------------------------- # compiled within R with: system("R CMD SHLIB zvodedll.f") dyn.load(paste("zvodedll", .Platform$dynlib.ext, sep = "")) print("FORTRAN DLL passed to zvode") print(system.time( outF <- zvode(func = "fex", jacfunc = "jex", y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10, dllname = "zvodedll", initfunc = NULL) )) tail(cbind(outF[, 2], analytical[, 1])) deSolve/inst/doc/dynload/odefor2.f0000644000176000001440000000225113136461015016566 0ustar ripleyusersc -------- odefor2.f -> odefor2.dll ------ c compile in R with: system("g77 -shared -o odefor2.dll odefor2.f") c or with system("R CMD SHLIB odefor2.f") c fortran source without initialiser c Rate of change and 3 output variables subroutine derivsfor2 (neq, t, y, ydot,out,IP) integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*), k1, k2, k3 k1 = 0.04 k2 = 1e4 k3 = 3e7 if(IP(1) < 1) call rexit("nout should be at least 1") ydot(1) = -k1*y(1) + k2*y(2)*y(3) ydot(3) = k3*y(2)*y(2) ydot(2) = -ydot(1) - ydot(3) out(1)=y(1)+y(2)+y(3) out(2)=y(1)*2 out(3)=k3 return end c The jacobian matrix subroutine jacfor2 (neq, t, y, ml, mu, pd, nrowpd,RP,IP) integer neq, ml, mu, nrowpd ,IP(*) double precision y(*), pd(nrowpd,*), t, RP(*), k1, k2, k3 k1 = 0.04 k2 = 1e4 k3 = 3e7 pd(1,1) = -k1 pd(2,1) = k1 pd(3,1) = 0.0 pd(1,2) = k2*y(3) pd(2,2) = -k2*y(3) - 2*k3*y(2) pd(3,2) = 2*k3*y(2) pd(1,3) = k2*y(2) pd(2,3) = -k2*y(2) pd(3,3) = 0.0 return end deSolve/inst/doc/dynload/AquaphyForcing.f0000644000176000001440000001177313136461015020157 0ustar ripleyusers c the Aquaphy algal model with forcing function light intensity c -------- Aquaphy2.f -> Aquaphy2.dll ------ c compile in R with: system("g77 -shared -o Aquaphy Aquaphy") c or with system("R CMD SHLIB AquaphyForcing") c======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= c Initialise parameter common block c======================================================================= subroutine initaqparms(odeparms) external odeparms double precision pars(16) common /myparms/pars call odeparms(16, pars) return end subroutine initaqforc(odeforc) external odeparms double precision forcs(2) common /myforcs/forcs call odeforc(2, forcs) return end c======================================================================= c In this "event", state variable 1 is increased with 1. DOES NOT WORK... c======================================================================= subroutine eventfun(n, t, y) integer n double precision t, y(n) y(1) = y(1) + 1 end subroutine c======================================================================= c Algal dynamics c======================================================================= subroutine aquaphy2 (neq, t, y, ydot,out,IP) implicit none integer neq, ip(*) double precision t, y(*), ydot(*), out(*) c parameters double precision maxPhotoSynt,rMortPHY,alpha,pExudation, & & maxProteinSynt,ksDIN,minpLMW,maxpLMW,minQuotum, & & maxStorage,respirationRate,pResp,catabolismRate, & & rNCProtein,inputDIN,rChlN common /myparms/ maxPhotoSynt,rMortPHY,alpha,pExudation, & & maxProteinSynt,ksDIN,minpLMW,maxpLMW,minQuotum, & & maxStorage,respirationRate,pResp,catabolismRate, & & rNCProtein,inputDIN,rChlN double precision PAR, dilutionRate common /myforcs/PAR, dilutionRate c variables double precision :: & & DIN,PROTEIN,RESERVE,LMW,dLMW,dRESERVE,dPROTEIN,dDIN, & & PhytoC,PhytoN,NCratio,Chlorophyll,TotalN,ChlCratio,PartLMW, & & hourofday, Limfac,PhotoSynthesis,Exudation,MonodQuotum, & & ProteinSynthesis,Storage,Respiration,Catabolism c ------------------------------------------------------------------------ if(ip(1) < 6) call rexit("nout should at least be 6") DIN = y(1) PROTEIN = y(2) RESERVE = y(3) LMW = y(4) c the output variables PhytoC = PROTEIN + RESERVE + LMW ! all components contain carbon PhytoN = PROTEIN * rNCProtein ! only proteins contain nitrogen NCratio = PhytoN / PhytoC Chlorophyll = PhytoN * rChlN TotalN = PhytoN + DIN ChlCratio = Chlorophyll / PhytoC c the rates, in mmol/hr PartLMW = LMW / PhytoC Limfac = min(1.d0,(maxpLMW -PartLMW)/(maxpLMW-minpLMW)) Limfac = max(0.d0,Limfac) PhotoSynthesis = maxPhotoSynt*Limfac * & & (1.d0-exp(alpha*PAR/maxPhotoSynt)) * PROTEIN Exudation = pExudation * PhotoSynthesis MonodQuotum = max(0.d0,LMW / PROTEIN - minQuotum) ProteinSynthesis= maxProteinSynt*MonodQuotum & & * DIN / (DIN+ksDIN) * PROTEIN Storage = maxStorage *MonodQuotum * PROTEIN Respiration = respirationRate * LMW & & + pResp * ProteinSynthesis Catabolism = catabolismRate * RESERVE c the rates of change of state variables; includes dilution effects (last term) dLMW = PhotoSynthesis + Catabolism & & - Exudation - Storage - Respiration - ProteinSynthesis & & - dilutionRate * LMW dRESERVE = Storage - Catabolism - dilutionRate * RESERVE dPROTEIN = ProteinSynthesis - dilutionRate * PROTEIN dDIN = -ProteinSynthesis * rNCProtein & & - dilutionRate * (DIN - inputDIN) c the vector with rate of changes ydot(1) = dDIN ydot(2) = dPROTEIN ydot(3) = dRESERVE ydot(4) = dLMW c the ordinary variables out(1) = PAR out(2) = TotalN out(3) = PhotoSynthesis out(4) = NCratio out(5) = ChlCratio out(6) = Chlorophyll return end subroutine Aquaphy2 deSolve/inst/doc/dynload/odeband.f0000644000176000001440000000237613136461015016632 0ustar ripleyusersc ========================================================================== c Example 1 of help file of lsode: c a simple function with banded jacobian - upper and lower band = 1 c note that number of rows of PD = nupper + 2*nlower + 1 c ========================================================================== c Rate of change subroutine derivsband (neq, t, y, ydot,out,IP) integer neq, IP(*) DOUBLE PRECISION T, Y(5), YDOT(5), out(*) ydot(1) = 0.1*y(1) -0.2*y(2) ydot(2) = -0.3*y(1) +0.1*y(2) -0.2*y(3) ydot(3) = -0.3*y(2) +0.1*y(3) -0.2*y(4) ydot(4) = -0.3*y(3) +0.1*y(4) -0.2*y(5) ydot(5) = -0.3*y(4) +0.1*y(5) RETURN END c The jacobian matrix subroutine jacband (neq, t, y, ml, mu, pd, nrowpd,RP,IP) INTEGER NEQ, ML, MU, nrowpd, ip(*) DOUBLE PRECISION T, Y(5), PD(nrowpd,5), rp(*) PD(:,:) = 0.D0 PD(1,1) = 0.D0 PD(1,2) = -.02D0 PD(1,3) = -.02D0 PD(1,4) = -.02D0 PD(1,5) = -.02D0 PD(2,:) = 0.1D0 PD(3,1) = -0.3D0 PD(3,2) = -0.3D0 PD(3,3) = -0.3D0 PD(3,4) = -0.3D0 PD(3,5) = 0.D0 RETURN END deSolve/inst/doc/dynload/Forcing_lv.R0000644000176000001440000001001713136461015017271 0ustar ripleyusers############################################################################### # Implements the lv test model, as given in Forcing_lv.c # A model in C-code and comprising a forcing function # before trying this code, c program has to be compiled # this can be done in R: # system("R CMD SHLIB Forcing_lv.c") # do make sure that these files are in the working directory... # (if not, use setwd() ) ############################################################################### library(deSolve) dyn.load(paste("Forcing_lv", .Platform$dynlib.ext, sep = "")) #=============================================================================== # The R-code #=============================================================================== SPCmod <- function(t, x, parms) { with(as.list(c(parms, x)), { import <- sigimp(t) dS <- import - b*S*P + g*C # substrate dP <- c*S*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dS, dP, dC) list(res,signal=import) }) } ## define states, time steps and parameters init <- c(S = 1, P = 1, C = 1) # initial conditions times <- seq(0, 100, by=0.1) # output times parms <- c(b = 0.1, c = 0.1, d = 0.1, e = 0.1, f = 0.1, g = 0.0) ## external input signal with rectangle impulse signal <- as.data.frame(list(times = times, import = rep(0, length(times)))) signal$import[signal$times >= 10 & signal$times <= 11] <- 0.2 signal$import <- ifelse((trunc(signal$times) %% 2 == 0), 0, 1) ftime <- seq(0, 900, 0.1) sigimp <- approxfun(signal$times, signal$import, rule = 2) Sigimp <- approx(signal$times, signal$import, xout=ftime ,rule = 2)$y forcings <- cbind(ftime, Sigimp) ## Start values for steady state xstart <- y <- c(S = 1, P = 1, C = 1) ## solve R version of the model print(system.time( Out <- ode(xstart, times, SPCmod, parms)) ) ## ============================================================================= ## solve C version of the model ## ============================================================================= print(system.time( out <- ode(y = y, times, func = "derivsc", parms = parms, dllname = "Forcing_lv", initforc="forcc", forcings = forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum", "signal")) )) ## Plotting plot(out, which = c("S","P","C"), type = "l") plot(out[,"P"], out[,"C"], type = "l", xlab = "producer", ylab = "consumer") #points(Out$P,Out$C) tail(out) ## ============================================================================= ## now including an event - as a data.frame ## ============================================================================= eventdata <- data.frame(var = rep("C", 10), time = seq(10, 100, 10), value = rep(0.5, 10), method = rep("multiply", 10)) eventdata ## solve C version of the model print(system.time( out2 <- ode(y = y, times, func = "derivsc", parms = parms, dllname = "Forcing_lv", initforc="forcc", forcings = forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum", "signal"), events=list(data=eventdata)) )) ## Plotting plot(out2, which = c("S", "P", "C"), type = "l") plot(out2[,"P"], out2[,"C"], type = "l", xlab = "producer", ylab = "consumer") ## ============================================================================= ## an event as a function ## ============================================================================= ## solve C version of the model print(system.time( out3 <- ode(y = y, times, func = "derivsc", parms = parms, dllname = "Forcing_lv", initforc="forcc", forcings = forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum", "signal"), events = list(func = "event", time = seq(10, 90, 10))) )) dyn.unload(paste("Forcing_lv", .Platform$dynlib.ext, sep = "")) plot(out3, which = c("S", "P", "C"), type = "l") plot(out3[,"P"], out3[,"C"], type = "l", xlab = "producer", ylab = "consumer") points(out2[,"P"],out2[,"C"]) deSolve/inst/doc/dynload/ChemicalDAE.f0000644000176000001440000000402613136461015017247 0ustar ripleyusersc---------------------------------------------------------------- c The chemical model example of daspk but with the c production rate a forcing function rather than c a parameter... c---------------------------------------------------------------- c -------- ChemicalDAE.f -> ChemicalDAE.dll ------ c compile in R with: system("g77 -shared -o ChemicalDAE.dll ChemicalDAE.f") c or with system("R CMD SHLIB ChemicalDAE.f") c---------------------------------------------------------------- c Initialiser for parameter common block c---------------------------------------------------------------- subroutine initparms(daspkparms) external daspkparms double precision parms(3) common /myparms/parms call daspkparms(3, parms) return end c---------------------------------------------------------------- c Initialiser for forcing common block c---------------------------------------------------------------- subroutine initforcs(daspkforcs) external daspkforcs double precision forcs(1) common /myforcs/forcs call daspkforcs(1, forcs) return end c---------------------------------------------------------------- c residual of rate of change and 1 output variable c---------------------------------------------------------------- subroutine chemres (t, y, ydot, cj, delta, ires, out, ipar) integer :: ires, ipar(*) integer, parameter :: neq = 3 double precision :: t, y(neq), ydot(neq), delta(neq), out(*) double precision :: K, ka, r, prod, ra, rb common / myparms / K, ka, r common / myforcs / prod if(IPar(1) < 2) call rexit("nout should be at least 2") ra = ka* y(3) ! forward rate rb = ka/K *y(1) * y(2) ! backward rate ! residuals of rates of changes delta(3) = -ydot(3) - ra + rb + prod delta(1) = -ydot(1) + ra - rb delta(2) = -ydot(2) + ra - rb - r*y(2) out(1) = y(1) + y(2) + y(3) out(2) = prod return end deSolve/inst/doc/dynload/AquaphyEvent.R0000644000176000001440000000560013136461015017615 0ustar ripleyusers#--------------------------------------------------------------------------- # A phytoplankton model with uncoupled carbon and nitrogen assimilation # as a function of light and Dissolved Inorganic Nitrogen (DIN) concentration # # The example demonstrates how to use forcing functions in compiled code # # before trying this code, the FORTRAN program has to be compiled # this can be done in R: # system("R CMD SHLIB AquaphyForcing.f") # do make sure that this file is in the working directory... # (if not, use setwd() ) #--------------------------------------------------------------------------- library(deSolve) ##============================================================================== ## Running the aquaphy model with light and dilution as forcing functions... ##============================================================================== parameters <- c(maxPhotoSynt = 0.125, # mol C/mol C/hr rMortPHY = 0.001, # /hr alpha = -0.125/150, # uEinst/m2/s/hr pExudation = 0.0, # - maxProteinSynt = 0.136, # mol C/mol C/hr ksDIN = 1.0, # mmol N/m3 minpLMW = 0.05, # mol C/mol C maxpLMW = 0.15, # mol C/mol C minQuotum = 0.075, # mol C/mol C maxStorage = 0.23, # /h respirationRate= 0.0001, # /h pResp = 0.4, # - catabolismRate = 0.06, # /h dilutionRate = 0.01, # /h rNCProtein = 0.2, # mol N/mol C inputDIN = 10.0, # mmol N/m3 rChlN = 1, # g Chl/mol N parMean = 250., # umol Phot/m2/s dayLength = 24. # hours - 24 hrs light ) ## ======================= ## The initial conditions ## ======================= times <- seq(10, 24*20, 1) state <- c(DIN = 6.0, # mmol N/m3 PROTEIN = 20.0, # mmol C/m3 RESERVE = 5.0, # mmol C/m3 LMW = 1.0) # mmol C/m3 ## ================== ## The events ## ================== tevent <- seq(0,24*20, by=24) le <- length(tevent) eventdat <- data.frame(var="DIN",time = tevent, value=6, method="replace") ## ================== ## Running the model ## ================== out <- aquaphy(times, state, parameters, events=list(data=eventdat)) ## ====================== ## Plotting model output ## ====================== par(oma = c(0, 0, 3, 0)) plot(out, which=c("PAR","Chlorophyll","DIN","NCratio"), xlab = "time, hours", ylab = c("uEinst/m2/s","ug/l","mmolN/m3","molN/molC"), type="l", lwd=2) mtext(outer = TRUE, side = 3, "AQUAPHY", cex = 1.5) ## ===================== ## Summary model output ## ===================== t(summary(out)) deSolve/inst/doc/dynload/satres.f0000644000176000001440000000310113136461015016522 0ustar ripleyusersC file satres.f C Initializer for parameter common block subroutine initmod(odeparms) external odeparms double precision parms(16) common /myparms/parms call odeparms(16, parms) return end C Initializer for forcing common block subroutine initforc(odeforcs) external odeforcs double precision forcs(1) common /myforcs/forcs call odeforcs(1, forcs) return end C Compartments are: C y(1) central compartment C y(2) second compartment C y(3) filtrate compartment C y(4) 'Gut' C y(5) Total eliminated C y(6) AUC central compartment C Derivatives and one output variable subroutine derivs(neq, t, y, ydot, out, ip) integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*) double precision Vc, Vt, kd, ka, Tm, KT, Kfil, Vfil, free, BW, $ Dose, DoseInt, Qd, Qfil, MaxTime, TDose, TDoseRt common /myparms/Vc, Vt, kd, ka, Tm, KT, Kfil, Vfil, free, BW, $ Dose, DoseInt, Qd, Qfil, MaxTime, TDose common /myforcs/TDoseRt if (ip(1) < 1) call rexit("nout should be at least 1") ydot(1) = (ka * y(4) - Qd * free * y(1) + Qd * y(2) - $ Qfil * y(1) * free) / Vc + Tm * y(3) / (KT + y(3)) ydot(2) = (free * Qd * y(1) - Qd * y(2)) / Vt ydot(3) = (Vc * kfil * y(1) * free - Vc * Tm * y(3) / (KT + y(3))- $ Vc * kfil * y(3)) / Vfil ydot(4) = -ka * y(4) + TDoseRt ydot(5) = Vc * kfil * y(3) ydot(6) = y(1) out(1) = y(1) * Vc + y(2) * Vt + y(3) * Vfil + y(4) + y(5) return end deSolve/inst/doc/compiledCode.R0000644000176000001440000002627713576731626016175 0ustar ripleyusers### R code from vignette source 'compiledCode.Rnw' ################################################### ### code chunk number 1: preliminaries ################################################### library("deSolve") options(prompt = "R> ") options(width=70) ################################################### ### code chunk number 2: the_Rmodel ################################################### model <- function(t, Y, parameters) { with (as.list(parameters),{ dy1 = -k1*Y[1] + k2*Y[2]*Y[3] dy3 = k3*Y[2]*Y[2] dy2 = -dy1 - dy3 list(c(dy1, dy2, dy3)) }) } ################################################### ### code chunk number 3: Jacobian_in_R ################################################### jac <- function (t, Y, parameters) { with (as.list(parameters),{ PD[1,1] <- -k1 PD[1,2] <- k2*Y[3] PD[1,3] <- k2*Y[2] PD[2,1] <- k1 PD[2,3] <- -PD[1,3] PD[3,2] <- k3*Y[2] PD[2,2] <- -PD[1,2] - PD[3,2] return(PD) }) } ################################################### ### code chunk number 4: Run_Rmodel ################################################### parms <- c(k1 = 0.04, k2 = 1e4, k3=3e7) Y <- c(1.0, 0.0, 0.0) times <- c(0, 0.4*10^(0:11)) PD <- matrix(nrow = 3, ncol = 3, data = 0) out <- ode(Y, times, model, parms = parms, jacfunc = jac) ################################################### ### code chunk number 5: compile_DLLmodel_F (eval = FALSE) ################################################### ## system("R CMD SHLIB mymod.f") ################################################### ### code chunk number 6: compile_DLLmodel_C (eval = FALSE) ################################################### ## system("R CMD SHLIB mymod.c") ################################################### ### code chunk number 7: compiledCode.Rnw:725-767 ################################################### caraxisfun <- function(t, y, parms) { with(as.list(c(y, parms)), { yb <- r * sin(w * t) xb <- sqrt(L * L - yb * yb) Ll <- sqrt(xl^2 + yl^2) Lr <- sqrt((xr - xb)^2 + (yr - yb)^2) dxl <- ul; dyl <- vl; dxr <- ur; dyr <- vr dul <- (L0-Ll) * xl/Ll + 2 * lam2 * (xl-xr) + lam1*xb dvl <- (L0-Ll) * yl/Ll + 2 * lam2 * (yl-yr) + lam1*yb - k * g dur <- (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr) dvr <- (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k * g c1 <- xb * xl + yb * yl c2 <- (xl - xr)^2 + (yl - yr)^2 - L * L list(c(dxl, dyl, dxr, dyr, dul, dvl, dur, dvr, c1, c2)) }) } eps <- 0.01; M <- 10; k <- M * eps^2/2; L <- 1; L0 <- 0.5; r <- 0.1; w <- 10; g <- 1 parameter <- c(eps = eps, M = M, k = k, L = L, L0 = L0, r = r, w = w, g = g) yini <- c(xl = 0, yl = L0, xr = L, yr = L0, ul = -L0/L, vl = 0, ur = -L0/L, vr = 0, lam1 = 0, lam2 = 0) # the mass matrix Mass <- diag(nrow = 10, 1) Mass[5,5] <- Mass[6,6] <- Mass[7,7] <- Mass[8,8] <- M * eps * eps/2 Mass[9,9] <- Mass[10,10] <- 0 Mass # index of the variables: 4 of index 1, 4 of index 2, 2 of index 3 index <- c(4, 4, 2) times <- seq(0, 3, by = 0.01) out <- radau(y = yini, mass = Mass, times = times, func = caraxisfun, parms = parameter, nind = index) ################################################### ### code chunk number 8: caraxis ################################################### plot(out, which = 1:4, type = "l", lwd = 2) ################################################### ### code chunk number 9: figcaraxis ################################################### plot(out, which = 1:4, type = "l", lwd = 2) ################################################### ### code chunk number 10: compiledCode.Rnw:950-979 ################################################### ## the model, 5 state variables f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } ## the Jacobian, written in banded form bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } ## initial conditions and output times yini <- 1:5 times <- 1:20 ## stiff method, user-generated banded Jacobian out <- lsode(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) ################################################### ### code chunk number 11: compiledCode.Rnw:1062-1073 ################################################### ## Parameter values and initial conditions Parms <- c(0.182, 4.0, 4.0, 0.08, 0.04, 0.74, 0.05, 0.15, 0.32, 16.17, 281.48, 13.3, 16.17, 5.487, 153.8, 0.04321671, 0.4027255, 1000, 0.02, 1.0, 3.8) yini <- c( AI=21, AAM=0, AT=0, AF=0, AL=0, CLT=0, AM=0 ) ## the rate of change DLLfunc(y = yini, dllname = "deSolve", func = "derivsccl4", initfunc = "initccl4", parms = Parms, times = 1, nout = 3, outnames = c("DOSE", "MASS", "CP") ) ################################################### ### code chunk number 12: compiledCode.Rnw:1084-1100 ################################################### pars <- c(K = 1, ka = 1e6, r = 1) ## Initial conc; D is in equilibrium with A,B y <- c(A = 2, B = 3, D = 2*3/pars["K"]) ## Initial rate of change dy <- c(dA = 0, dB = 0, dD = 0) ## production increases with time prod <- matrix(nc=2,data=c(seq(0,100,by=10),seq(0.1,0.5,len=11))) DLLres(y=y,dy=dy,times=5,res="chemres", dllname="deSolve", initfunc="initparms", initforc="initforcs", parms=pars, forcings=prod, nout=2, outnames=c("CONC","Prod")) ################################################### ### code chunk number 13: compiledCode.Rnw:1268-1276 ################################################### Flux <- matrix(ncol=2,byrow=TRUE,data=c( 1, 0.654, 11, 0.167, 21, 0.060, 41, 0.070, 73,0.277, 83,0.186, 93,0.140,103, 0.255, 113, 0.231,123, 0.309,133,1.127,143,1.923, 153,1.091,163,1.001, 173, 1.691,183, 1.404,194,1.226,204,0.767, 214, 0.893,224,0.737, 234,0.772,244, 0.726,254,0.624,264,0.439, 274,0.168,284 ,0.280, 294,0.202,304, 0.193,315,0.286,325,0.599, 335, 1.889,345, 0.996,355,0.681,365,1.135)) head(Flux) ################################################### ### code chunk number 14: compiledCode.Rnw:1281-1282 ################################################### parms <- 0.01 ################################################### ### code chunk number 15: compiledCode.Rnw:1288-1290 ################################################### meanDepo <- mean(approx(Flux[,1],Flux[,2], xout=seq(1,365,by=1))$y) Yini <- c(y=meanDepo/parms) ################################################### ### code chunk number 16: compiledCode.Rnw:1306-1313 ################################################### times <- 1:365 out <- ode(y=Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc="scocforc", forcings=Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation","Depo")) head(out) ################################################### ### code chunk number 17: compiledCode.Rnw:1319-1325 ################################################### fcontrol <- list(method="constant") out2 <- ode(y=Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc="scocforc", forcings=Flux, fcontrol=fcontrol, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation","Depo")) ################################################### ### code chunk number 18: scoc ################################################### par (mfrow=c(1,2)) plot(out, which = "Depo", col="red", xlab="days", ylab="mmol C/m2/ d", main="method='linear'") lines(out[,"time"], out[,"Mineralisation"], lwd=2, col="blue") legend("topleft",lwd=1:2,col=c("red","blue"), c("Flux","Mineralisation")) plot(out, which = "Depo", col="red", xlab="days", ylab="mmol C/m2/ d", main="method='constant'") lines(out2[,"time"], out2[,"Mineralisation"], lwd=2, col="blue") ################################################### ### code chunk number 19: figscoc ################################################### par (mfrow=c(1,2)) plot(out, which = "Depo", col="red", xlab="days", ylab="mmol C/m2/ d", main="method='linear'") lines(out[,"time"], out[,"Mineralisation"], lwd=2, col="blue") legend("topleft",lwd=1:2,col=c("red","blue"), c("Flux","Mineralisation")) plot(out, which = "Depo", col="red", xlab="days", ylab="mmol C/m2/ d", main="method='constant'") lines(out2[,"time"], out2[,"Mineralisation"], lwd=2, col="blue") ################################################### ### code chunk number 20: compiledCode.Rnw:1360-1392 ################################################### SPCmod <- function(t, x, parms, input) { with(as.list(c(parms, x)), { import <- input(t) dS <- import - b*S*P + g*C # substrate dP <- c*S*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dS, dP, dC) list(res, signal = import) }) } ## The parameters parms <- c(b = 0.1, c = 0.1, d = 0.1, e = 0.1, f = 0.1, g = 0.0) ## vector of timesteps times <- seq(0, 100, by=0.1) ## external signal with several rectangle impulses signal <- as.data.frame(list(times = times, import = rep(0, length(times)))) signal$import <- ifelse((trunc(signal$times) %% 2 == 0), 0, 1) sigimp <- approxfun(signal$times, signal$import, rule = 2) ## Start values for steady state xstart <- c(S = 1, P = 1, C = 1) ## Solve model print (system.time( out <- ode(y = xstart,times = times, func = SPCmod, parms, input = sigimp) )) ################################################### ### code chunk number 21: lv ################################################### plot(out) ################################################### ### code chunk number 22: figlv ################################################### plot(out) ################################################### ### code chunk number 23: compiledCode.Rnw:1511-1514 ################################################### eventdata <- data.frame(var=rep("C",10),time=seq(10,100,10),value=rep(0.5,10), method=rep("multiply",10)) eventdata ################################################### ### code chunk number 24: compiledCode.Rnw:1601-1619 ################################################### derivs <- function(t, y, parms) { with(as.list(c(y, parms)), { if (t < tau) ytau <- c(1, 1) else ytau <- lagvalue(t - tau, c(1, 2)) dN <- f * N - g * N * P dP <- e * g * ytau[1] * ytau[2] - m * P list(c(dN, dP), tau=ytau[1], tau=ytau[2]) }) } yinit <- c(N = 1, P = 1) times <- seq(0, 500) parms <- c(f = 0.1, g = 0.2, e = 0.1, m = 0.1, tau = .2) yout <- dede(y = yinit, times = times, func = derivs, parms = parms) head(yout) deSolve/inst/doc/compiledCode.pdf0000644000176000001440000101540213576731647016535 0ustar ripleyusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 4808 /Filter /FlateDecode /N 88 /First 740 >> stream x\w۶~߿o7=mHs'NRlj#;M>(mF]J>߾ EM#$H f,a)`mXx38X, 1.%a\ k*mp q_1!RJLH*LhK,2&L)fʨ 3- RLk^h,LLepL&T0ɩ+Sz)3藊YfVg8Z4& ˒T2iY @E>&ԒS2OEl:a`2q  <$S0 G"K,Ã\&:/.zѲ4Ag3GeM<‰"D5U rIx5u4u', >hYk:Ģ Xft. ZNB-Nr*AA)$pBz`q]&A Z6et3$sb@Ν,Z jIBt8 *e+2Z %jHV9{G *$G]jx`_],l˧U1kɗ|6ʛbq2`hಜ # `hG/F9z~=.|4+n+E}z*4OmyB8A|^5Jx+"rBdBqkz rkK.}rIƣFTt^4 l|CېzbSan}IO e|6e_aj`Yx[0~a< ƿVu M^m/j'Q 6 -##(K31 W+[PG-E `kpRQ󫕣U1\duC}LszbcVy]}Ʉ 3_Sxk/?8SC [-t1udYk)`,i0&EՈvAz18AT&\Ή-^OBUˤ#$Ծ(A$>j?1u&>}ry<Ͽx^|y\}-E%1agC1ewoɵaևٚdf 댫O. Ti6 A} \CU{S+34J-uTXNa9E]3kWͬ]HN ςhp5Mh kmx}rqx/h؆(mlMO]А0I2]ӗ ]+³D"m2ƹUtn]'e*;`w[䉋5y#Z(\w]$[uYckDnDUL_`?\ GsęU}>szݎ|ϋycx8)4o&OfkX֞ #y ,/*ZuWt%M_=J]$hrf6Co3w=:ޣ0wY ƿњr6u-6@fJweW i$)R.B`gQl&Ċ׌5A>삅zѓnؖEf:J=EH.RL4zP]HȇtL/ez]q93;¼n⪭9vrp[wG%!RRwΛgy7(DN4tMZv)u3>TV'}nT>'[uSD%Qv)'i4J\8RrW zF<;v=>޶s? !xLqGϭr߁n8`p hs87("Xu(/6jۨψUfhC&V-.wp51zwҬ{=XS;N 0N;Yzhu6v/|7T;ѓ@Z/: C1҉e藬~ְ/}KҨnNV3u Gx2>bqquj,d+&U:tPez7}w8 feMp ZJhׂ4I7jJL[ ]]OOXjg~r&W'GB}'7iMZonϖo3Ԛ$Vl` Cm ·qVѓi^K8njR 6x7i{xl;tKMi60ekwwu'H}(ΕR@}\$U)͇GF'q /?r8X~A@2:܉=YǗsxm:+iH`)DRc~yr)Ei$G䠥{Kpۀ6μ {{3mVMAThSR.K?doaSۨۢ^a40*+9`)T N]{{:KKbK;#Ω&ʼ7(˳(s ]Di$Ii7)l_jBLEd@%1_i(s yyê/REnD|* Jو9 TQ4݉h~w_Ӣ3bt鄒PODidAflˆ!1\B+%prY%rGt~_x4a,_b".> stream GPL Ghostscript 9.16 differential equation solvers, compiled code, performance, FORTRAN, C 2019-12-19T18:30:14+01:00 2019-12-19T18:30:14+01:00 LaTeX with hyperref R Package deSolve, Writing Code in Compiled LanguagesKarline Soetaert, Thomas Petzoldt, R. Woodrow Setzer endstream endobj 91 0 obj << /Type /ObjStm /Length 2413 /Filter /FlateDecode /N 88 /First 782 >> stream xZko8g0(I`0@NbJ"cMϹ%K#~hv$(>=RAń,h, 3O Ypkςg"Ux LO)JkFRdzQL PLjaKH-SS*XLj  ==5 H鈢jI\$eJ%) ~z%|"nS.RTؿ3'd>cKxQ+!eoa?<]08+ ):El6y~},2;68|:9/_P~7xhO6 5l[l-%SuR'K-6f*dI6rUSܪ!¦ҴSlosU*ŦQ6yeR-n폓m#{=:ϲ؝zӟd< Mot6~۟b3fi~?Lc`[WЪegyE9}1p~K4.e?қ~?>WE"%!VzZ1J誾@e0UuJ"Ѫ4_s fC{*onG_w%}`rwCk~~s;>~i>d 44??2N'$FfOKZw}.^La%o^|p2eh P5yv(U#Y%￝./L#'YXRa* ŮuSYSl ַ6+۬mZ~o.?V*U6lv,&yׇdi(%Ԏ:̆A^0S-:Zܮ5 n7&w&&թ{+L_a^oW#gZek1nD. }rQ3!R ,እCFPt" ?{\6W%c_1M0ohl[{Ml݆i`@lQ;V52v9x _ 'TUCWt2f:QLW>@X4,¸?! OL̸ChD-/+M$]fV I@s'Dኬoc8etՑFu$7d<*|Ǖ RINjJj)( J\6Iwk )j% &:Ҳ $ ʕڐ HH(3 :uڄ}qauA!?̮;IzX3E(Oǟ24wHr@ݐ`+?^^]}";72Ǫ\.RꖋF+.rr51n-uהm/h'k^x4j/-ny>#N-WskcGv3=vKQɖF-ɻ?N6ơfkN֨ 4뼇`LD4#  y,Ӎ{,}=>{w{Y Э$^+z0tVdYɏ :9HWiu)Z@6&؀IH#^+_6X2pݶ;!=IUKblOn xC_h;"Hv# o\=Jӕ 9XkMW1/޼O%fv mQS.c ʩ_Hz/(͹ם88ͼEⶠ-77zו/'k0c[I$pɸl2Gߒm]n`,K$}w²^f+wՈklewV~R|8w?f|}> stream xZks6"L3~8iVnF2Rs!R"Aq9x >pPx2&dh*&ǯf*XfesǼ_2j&DQUrx7Иҡ^pAW!3K}I%*s%L 3\x u%Pf)-˔V4chjxSҥȘ, pA2-Ŵ,4BǴm),RLFxC}"P2cF5p)qbƓfLf)֬gV^2UkU$ XOBQHweȸp)aIMsJ.&`Z0g]g(p#{E&ȁkFF'7(j{!W[p4K:Im|25! F@"dIi3Ho { țbA[zYdeX1&\ _MNjžlrZ,W?#l4CNT,- Q~y2ŇUx2o ]5-sr(WGlY^]Skw+VVlJ p 'M$z!$@VN;{8izzbDL`8x`7UUVl`EPI.hxBh,ahp{.Ūh*~[??Y} ^M~U՜U_7vT'HW 1#;=ūzJxW[\_͊85 RĿ{R?५wfѥ{ː6M:NB[QSz @bb{<|vn }s_@!wz6zP}h2M_-^jmܻ<(G^z7M'$33Zn'!zh~+eu?p'Ϗ߼QdpjV|hsYUr{#ϛx@|̚N흭{ STk?{[6iKퟌY|}{GG,n''Ey &I1YLrru4b|;[K%Bq".E@hJȯ,쨺\;y^ol hYWoQzȜi]@aWy`rΙoendstream endobj 267 0 obj << /Filter /FlateDecode /Length 6280 >> stream x\[su~G#q<1QI2 ǕyXHR)zk~vΥ{t VUr}|FF/nET34uSsqs7:ns T:X6Jzs~{^bɦ:=kw;qNTV1贽YPk.Qv^h W39gj^!%hab.o_cy=oM yD'luge{P=Nh7L2azJXg in+w. i[^~}C ݈W8*nfO#Uzs:.J#'Ӟ_4N/C,$of-}6L=EO;̂~@ycaۯha~GX|~Dhc*'Ҭ2T 9`qGta-vpݴð(gI#7/I1+\)Yrs}lĢ<m5(ӑG䘁X< 4vOrչ@vfe_i~W5x]f_9]BbY;"6yc|7ot;#MDsvsJ2aA, y蝍|\&Jh Wħ'cIy+e;`xǀ`>9/:AIZ6@g㠬o/?,PYP%-h T7dbNŶ{x z3Ђvq(8&n̂P[:Xќ@s1&!gڳ?oë^hd ې:`NpY'7oIw R@9n;ʋEToz ~i{(NMq෪ ğ\ߎD2IP\8hKrE竸 kX %]}aIDt3HWG64')K7AnY3\2$*LLF|pgX#k#^NhA+N-dM5G6, ypu[k.,wnw.U$P2iwC `PVd@[Y8 &P%A;C`k9Z̮ a[Ui+|$7K)6 `@_)Z OO61U- )Ґ".k/XNg/#@d7x-hi#}мP+>hp;b:.<z@`X_.I<6fjL(WB !JCrSrȈ?Ɋȋ#M` j,JW`c,ހwA)kfEQfu=-Q(0!W ~kD;5{qk Ld B(MI!)W]y XK% ,[T"ʑ:`YK3I*TYMTpw.:0`8성: M o8_$59JۓPŠ4-q&b˛D(D0cKDdD@SnJ&C#U>(F)!cmЋȇW`T O@F2e2nt  ` Uanm:Fdߍf019 *QAaJ- 8U ~9hM{Sv@2洇#l\|Fwƌ @:ǫfEA׉@$Ddacl?6/tn6z(bp"7r' .{\'?.0ApFk/#3[r*wnN(ܚMqTџZ23DUR=(z V#RDd|4`(SaUd Npq[R |&J=Xz=N]ŗ B|<Ԣ MOP μLJ` x *[Ιq9#6ոJ3'~ nSQM 2jw$a>01{Ngg' .'M1&'C u9;bpɯZlhVEF x}ThG@ܣ+٧=Pkr^3޴< efJf葨8s_ºq?+ϿhTF$L=  +=.EƨLAdߵ)G7)Z!d {Z%V?ME^dC&B[.L#ӵ*9du{_ieІ~̣0.%Uے(i7.yZaq[m6'9v]%9Ct?|Hh!]ӁN4B_" 5"o"J(Ի+5VWo.RIχRM ~ewSMjI^:p\+)M[ՌWTڵK XGY`}!"2oS\/X3`SʹVnV*`x-Vx1BhsE W[<~.mb 6dȌh{2 6,}/z[&v4 >qU8{ ']XWyn* s=!ܐuMy-7:)z<˼2Q{";u6>YF2:O‹zJ 0_-/#iUxf{WIyPxBb؋J n]oVďxQ>J6MT9q5Zh|L Z%zfe<%jOGjJs$i?k q q ![x~C\Oj Gԕ-\DϹ0o=tض!ELj:oeP90B]do C)~ϛ]yEb`l&2ԇ@rtDjG+ ̡e/y po{ef{Q0)i80bGDŲTgz+UA%3 f':޶Kg>",xx)-uQ1i)296G#{NG~9WDQ¥~bY9jo=(,[)d-+\nN4k.v72D %'agQf1؆Sq"VZ)Q e}\`VB'/:(K^ }cSX0)UmD$pwz:] 2o$#`Q/Ni%;QnMرΩ`! O:z\;'lşغ@:w[״!!BUQ ]4kI\(Rd#uJ3z."4 V\ʪgtigL !PΎ%v}yԚ]Ĉ4M Y"*LVթ_x[|RE&3E^ib~fuu97-8ŝ]eM޼{-bM c^ oKB LNE\^WK1nd.}E_`˽J_5"Yg9Ӱ\'+RByc)tyEezQ_"v'&!a71<XJ0K&p\ױn3ӝDcZJy`i@eU&zPrs=ؠ;Yŧ׿jZI=\slj.YÊ{i ^EHOĥrI5(Ғnq!,z!5$(>Jldn htK0B,,b'Ox^{dl;`ƒw+\9boSwvCPA|萀'HڔRtvV1HVN=AC08ڪƞ}淚>G;>nk@-+?G6*ciBǫHNu!n84kW>%C1|ݖd)&]=8&x ;QBs>gsP i5O]Ce]֍wg` Yn57>=OK>ء s=?L!֨'#c.MlF,e%2iy>?X!;Tg&r?tqs_]J")]3^]x  `sx`#]@`(^VX F?+BCT^lwd4_[>3 r<Ř~&Qul,jx(W2}Χj/\:b/O[J!^-o鳀>p#+Nij1ʻGDW<CE>0/r 7""Z>4q2}vP, ʽcr]DNؚ mNRMW (7l)<_wfwQ3Oz5}7.[:DVh82,/wЛbslR/Jr* V]].R PDjWI~A[5vӉ+d p0endstream endobj 268 0 obj << /Filter /FlateDecode /Length 5105 >> stream x\[od7rN^=pl'A`C['Q `օ,e< ' 4C_]Y쟎V+Gu|q{:H_)г*WG>N8=`,c&3?=?vz9Qۤ ѶYmCzN86&l}2nz~k %Nٕ鼜i7j鉾JEЯN9M*c6jl~XY3lsb$YgJ4uvɹݦRý4]Xsf,/6CzOEJ k_h)pG_>rvӵ)攀uK2>);妋;1 ̯R4vm_3Rw`':ح1nB@>Nf\ TsF '\eLvvK2Qu*CQ&#2TxOե`;l.Kv:gw7N$+N?a/w4g8%SNEggfqMif #P -̴ &郠]!MI )ie|5f.v =!F\WX@와)ۛ̈-=/>#ZF(kK׬(A+ͫdw#NazaS.MB`PHp60,le q7s*7H{-(Fd[!Či'V!ř l<OZ?1!wr똜gfadė#  gOR&Y#aGl uJJ瘥wΞUPFi`nj[YT3@ttL7 .m4]7UE^g8ҁذ<6Ac!)fH [ 9#` " æC@jN6)(A)p7ai jOmiDYQJS?jdV 4H`I5'!t^vJa7>it^m,*:|! & H/؂>Q,%ahr`LUaB,9XMlHtÇ Ձ{@wٌXy K` dQ[5z}Iӊ%XQ_H2wM^nBɮǾiAI\ T& fR%of0 8|2$ww ˌy +^9EbV5,O'Nùc: oX]1`3d*l!p7 u'8mؐp dwN$lly ƒwT>ťf"/؎eCr=6628bpw nj@+"4Ri"){ .`wF0YS `+ w]Z`ڈ4歳ޅ^[K~pVfF2Owpf@eDhqg {i7u|XVv'XX@@8Y)&ESхeM-ua!Z3Dؕ✃>v1zېbT)slA.JvlO ,x(.6GExv 6SZh=G{Џlpz.kM&P8A У+Cpu]%OD,%D$Rh{) -kԧܲ*[ e#3* %É*>FXNqhn@an۴P|&9ٞ*&@@_ԒՏr`bӗM&%7Yq5T3d5,S>%bZ3b/3p8%)d*ޛ(>gh^wM ="|:^A\GP/عum:4,3;7vJY3;B]z$pE 0$CN}و:A7+P`;9O}SIjŲg"VJN7] 3)7oӷ $ԏZ e|r7 `WhD D2c?\?o49 NciK9XLn:_~#ήvxvш6eO҉ƌ'` 2䖻$QRs*Ry zZ~%R`C(':xb5 U]kޱղI\9~IW{LVK-`š 4ǿl%7;[PP`5I88Mk~ٚo= CwCR@w o"hJWd%7>a.$7l :?HQޏV<*v=m d@4ː|@./G_{zG$L=G/V1 [5dzBK'A9ִ?v7:^y!~cFz@Q%boX" T}v?xf%s#SUz ~3#Ysgk$_'xAzbV.dPsχ+W(vS}M dž j@,X{])n}?!~YoQiC4B(J|#vT~iKϯPC W>^yH? 6& >>qXUaR+!8Tָ.ۼ ~vQ .mEٽ [-S^7 ûrс=Fc$ma !(䜙3Y$(]׀%[ gӱSڻZtnLF U,ԘASzD ]AD= !1|q܌ǐ8Ttr Zv\S+&mdu:``&Sy)K&ST/I xf J }A+$ʀY6k2.kŜ}M|43\*۲gR@\$W3iA$0Jup% 1T|1Cȿj5D\ PC$C9g(9q:5< SuBCa'x]]5wwe}}Y+Ag Hb>_OAG\6{ x@)`m -tZ@ vP@D]w!Po|2v}u/^@`5z^2M|B Q^-SX>4_ї<g>]Rˎ藟—h Z@s|u7|2]Qr]H)>u1 qJcxlPA>>oϯcY7ޅXRD:]_/cx&&.{|eEﶀT=kaDFcɼ+mi4mp.}ŒX 6Tz^ 6DUGGkGLX8MQjj;_%g{Z8Ez3&to =<2@>A5luXh'ZóBКe Ok W0e] aʵ0NG/}Z%s &B)w K׻jr 6k=%0[a,][iu]OҶOpP~ Jh|Y~|smrLua{sB8Z $t|"Ees!tPտ!/H䕊k p<,Z=iiEi Ծ>wzhL|w>(wWy;ȄA9 m9iӓ-T}3||\_O1󥒝=\M,{4Y?W4Bp>/6wn]?iȱik5]}voͦ5?mMo~ϬlƕKvKodzH<ÝWl#7a:"jendstream endobj 269 0 obj << /Filter /FlateDecode /Length 3595 >> stream x[[o\~#CϦc/nii& p\`/+-;3!gRd( cjHsfxz!F'9?zȋ#.?ŧ5QD8~vʅta.cvq|~x֎.a} FE9-Wb1D;QEPH#a8]?9|KN8+G!D1u5pVh6fM082wp 2F MqXW]=|T$9l V~ {Ͱ;+>A HC`0Ac3K F)`!cjxT*כ,;-YH.eԓ/89G`Es1rv oMњ_V08@!"F&*y]Jo'|WIYI(;:!&^"u%X64/TZ/0UrRYB%%+6%MSfA -P,wI0$Zpx,^p8z!,+r2 .WYݒEs06D)UKmt9 m,}n4G2 Oiw !05huIy1̶EWl:A!dF-VQk1qʏ՗<&C]gunTaqV?с^u%/)7.]W|I>Pui^u}T3b ; }U|)Ea[՞U{gQ}$p7()bUɯ+gugzoXX?f/KT l Ռ4L4lF?7}:CvBF=| ZPgZr89egJv(!RǼS4ۥh) P DJmL-zlta.ޒ" NIT]pq@8C 6dAupTzj[qM%{umW(!n};kD,]>(,ryLΏ%# 2᫯h8+䨙xGs\ΑZ( on"FX~ejP}Zy1hĚIWy*݈p 4v1Y tq4ZN-ש؅6j7j͛-`e ʿ;ξA3c&e+F']EHu J`ϼ4IyV)#=a#x E&%$1ḇx昧B6zhP9+<6w~I#=2ïf۲Ib 2}JP?1gK1 t Atq)eÂؒ~t<=^1} b">2z*=`K^T!)svB˴^`YjFT0άwYĊ#V$R,?BaiN*.K6wz}Lnϻ;m=7]C)Q;_+ˊ+WdK} ؈S29ܩL3Kfێ8#wy _Mr kr>ƽ(%^΢fqLKC&^snͳZxR n-:`x>a_B K|O.2/w|FcQ@15L 62>NWLvqM8Ia[).H8(5) LbFݮ<ٽxnLYk}º&e4 os4rΧ3~0 7%P9}ÿgO +/CH:yhŢziՖd6?e]&Vl4kÄSgTw)"OE^@+p'eޕR~dU>On +//~9k(/ٷue%t pQWBV|媊p]|tPv~όI{7[BW(o1endstream endobj 270 0 obj << /Filter /FlateDecode /Length 6423 >> stream x]Ys$~GtSv+#AC4H6njǿ~3( Q*r(ˆ#4`5 G"/o(7}uuؼ;?&j_#jx2FYzUn v?oaTѨ(N>hwTzp M#aN8;G!b1h{!SZ h1-M" C +^ &9v1J-A9 Cp.uA*+89L F!Fgz6=Jox*Ԏ;!b0~ CH˷͚|\"m0JAXd V  0t1N.DC2?!sx~ ~8og; t6lvڎ9ALcn=nL N0J ۼF+Uva8^Wb0Go`"M7.7ok]m~ͻmwEihC$& \k-5zO<3 u{'xD{Dȡ qȡS^t~Z erdЇ>wq8Cbk2aAy^I gkcam;иz8Fh.h /.`nh|2`!0N(xM$a:28FAi(I t4ct~z&6{. > gH豊%!aFhEoNèNcW`({~kvԼbz-Ucm>ڼ_~O_t SPPڼތ׌0fyg>u;{S?ncWL""}Ǥ T5z)'muWl͹V ԲZlB/Aɠ8MxPdp4"ؘs<*0c*GI /jR2Bf`}$,jfrl’inF3'ype(ֈNt!I{>rFz=mk/قaLYE$i*+$;2>7!= w7*,L9Oo"64[| ׁYosH`qE3tmQ*]#pl#Fҹx}q>։=RmxMÌ]%` :T#qL\ASgLWM l.KO&AZ@i6B <4'THHc1o5"7P..S[̿_qe<89_lj6nbP{:v0M5XG "]NoOOߝʹLo,ؗ-n*fLs䌊@ԸwY% loG+IZ E㐶.8p%Nwn1\|8+Cu ,@8P1ds|2aGY(#?dH ,k2󦾖ԙs˶jaqQ_so>=s> qrz:ե!3]ㅡ-SΆY%wk*2T}aD1@S XM׎. vw`Ï|j:!v 89Goݒa(̰ŹFWV*YT/[Th9)F雂Y<>[- Dv $̛!JrEG1"-*Yț锅g$[ml\SMshP~n $'@xvIB"2Bf2@NL\ {B V)}JET&H$ ,@9&؉owߠM_j$8y*Խ9rڠ:_0uz?{Og֟ޠiQ2}y(?z=v0dq\iѢd)BY\R"yo醡-(E&njHAjMd;?ϛT Oa9f疌,?c$ƱINd\wgt%PUbYWf'[JɑbZYclnb-xS$\tQkqCQ١4+#:KڒMDpCc]3+Ѵ*i>6LrRqxZ mu::l]c (šo$ RU>bNr ]$lgo7-ZG9t.K ߦmS NЉ;' P+D3#ݒVMƄ ^S,xr'P D8s4LrzKyrA I^V 0c2Xvi?}-E2p 7q,f5]3u,}HT ӞE^{|$`8~ј't:,G:3mPs Е//Ǩ|=~ɗ )bPahkN 5ERs:p.(f5FĠ^-KCG3; X&;n6s?MmlpA4Ft#.&|gS@5%h/48z^fQ6Mih"݆m_c KbT,KLO\_!&+L&hyunu-&~QOjl}wvO 00tl'tWeHDMi Ǯqo;)B7F徸c:_^ T@%l+ b7%h{%5MX86|< D aUg Xv~im5EF-ҍ{1:0+j}WSmSpj^A>SR?Gt|lݒa{#BC "ku =F锚!zhf.S1S47F>GrձގQ>n)I& &<:ޢG2";9Ta,8`0$ vS.+0 >5,*|FK;+5D3̅>Z+iG>_u57z#u`ai`> PhAx8Xzv~>iR/Tz)'Wj=S .Uɗn"Du:'ހUC"@L|ggz3wdt>c}THmV?+G ݄Qr<?M ^ި;A+`1vU'!}OB+Z4>ŭ`>H@tgRYop}uZ.$ OO`q566$n1h<[n|Q(״ c`o"m/dg[J'/I%%Lh8[RKzPDL|ٺ_,fzf%6-^T6 K |[dz J<2w^WFS-m>,J$H ~Zl({@G' crR`^ 39CGYȟ3铟]E%P@ p؝pN^đ$3oxEdDP9hjG30HkI泌ާ۩w=F^B cjD^G`=dWį vzLiʺt$ <9@L~{d 9̲>-ܷ%bBIaG_޻5.u`89s10w+"a ~gFzJ`okU TB'F,L7ۉZzMc-jSuAMl@<&<ƚ8|^ep%-Sox%1y- 3r_J-=dT~J`XO5Jä135  I?lӵC7 \"ri>c"gGօ2ޘ@6j~cEԅ8m>v+kܴ(ZƬ o)6'AM8'DshH(hW䑨 }>m׋UM("_xi'l96 K v- ŠZ c$^X\?霳 IcUų'0~` $ PJ5t"7!0`fN[oяϞ>AyQ`OY=ƻL(>Q}4VGu=!Ih =2qQO%(6_ kPKOO.T:]X@a3k󎫡$h8pxBJOR䣺v Pyp֞lg+~ ~QBvOhH:. $%{{8ZXmӥU0;=iiuS]'ڼm,a|KF.E)$C$Ejgfj{'oͤۋUK@].#`X#˘]*-8:6Jowͅ׭Db}./U>_FF K];6RVP3ǧI%Ewdӥ]1sTtꀂE1l|#gNendstream endobj 271 0 obj << /Filter /FlateDecode /Length 4767 >> stream x<ێDZ?b4O 0.O&/C+[<ř ,/Aaa 5b -h?.M(\I 1[^@F6}B ]qe0櫍@M]QN^ٔ.{ϓI|!E=G%E?xWd 9}rj}C@_`k Υ  W n\1x o"2xe{?1xshi1?1\픊R ^5'c [ofM>0i. vͳܤ8 y*G)WƢ6t796IGaY H8 (zY@Y$aĵwj@7w ŔG7i^GYž!B 6Z l+`֧m26n} aPW .GX!JRȠv\rsQNLxIm'"fJdP}κ*> r ׅD95~T΃"bMJdVۛހSg|2"&4u|$y{D?0 6x'^(Y}G_t}?ROz$@,Uh )%!uo![ \aϛb|[…i)/Mzݏ+'Q٫ܰƎ,@$bP~3}B6˞-[/l0TZba<Ж0AC:~>q7'{l2K!^A6U#eҠlo4o)qՠE\<R9 jѹY=)PzMte;FJfn_ )Ix4'0 0L"wA(lw~'m6V=6dRǒ2k[3LAlM{VX=&j񲳳3'$Žz1 Wnx ~NE m}Ŵɀ8Ju{0AbՆm^p՚p:ZG91`sG)aJ;2\R9 `ܨq? MCuF;cO N%.-Aâ"P+f*#S:t]r!8,ө3'iG] uŕKqOg*1?Ldv/%+AEmɽ$ ^$&]m4#"@xhCUȬ:NsVYvG NkSފ1x1BmC?0x];7y\&H$}`)&m4""K|DV]⡹mvZ3:<ͫFŷn^ 1tI!K̩I"RoD5"Yy䕝["mƙZ0{FH i*3&bb5J0$*rgKkLۑŒv15?5-xAQ@ uw;0",Q5G:+Ir`Ec0t4 :`2Xʰ?.wpݪɻ ApՆ i>?˴Ⱦ2\KE [ϊlz)(ȧ(>]kna ^;]_Q9--ʞ|Z?8LxS # @/3.l"s>gU֘rgb #hENl-)?sf% LɉHtt]0U-u.BT$㳕<(cL0bP[>^eZ3B#+cKSię%EBTP끐rBҦWDleԋV YT.Qqu%<:9-L2L %7O4$,9 lUVnʑWY!w?9 ǜpW V8ymՈ^?^- + ]2Ѻ 1Զ-s4`8i;!؝tQUAVAi3˨4&N& ۺy'uonGuaBg MU̻ݰ FĽNiT"p-J5,-zёӻ"7:+YOJO0'4={뷙oUV̡^Äuc]/Xn0SsTj_ 3uB8Y;530T f SΛص}(:iu({jc¾:#*Ue[u] gʺSa&I,!)I񥙽ʍ-:e1]'aN+ QS=f c}!LùomrTfa*(++Y{( @**-.R)I|[+4RKnΩyC%8Vb"*Zj]Ib0r{'yߕU^h}ť"43$dmm4Jc˲+p q2dƉjfLE?!|W]Lk'Bt$1O4f +LUh|_iU_I3 kp4I6v"/΅_J}6G"ENџ>;ryʿs%Vta=gb,0-@m^y߻%"%W+VCgXo)fG[cI˺kb%uŅH~Db{2^prEt<v"™SmY12NȡF÷\FkvyT m6\60#&S/ LAl_=JzQ\Up^=qމ$z~C4\B@]asY[DU7N &%K]ɩ:3@uĵKa@Ǧ=!r#m>-o 'fr[L쌷2 M|ߥ~Zy,]|'ą2Q:H[Q ;1Rg'JVLlRJ!Y/PjKzvkI7E`A[ o5a3ȱ;E; wɲنwQixGxu g&IKqTxz.t\ Ys?2x)n 7NkC;fod@^+Y8_ $\٬iS]LJ \ lV1U$ի&S݉^ R 90+9SRw;{gK$AƟW[dg ~soA!#/EPi>o_1 qcol%`lbbV[&=W&~WM|䁟^L 8%xt>(j7A7A8nls8!8Fg RO^˙g9p™?,[q&:22 4A#Ÿw,Q:jk;1~C),XW\8#WT>iܨ)f'㻕LMzgڤ\Mɛ(eѰYc6:԰7wLQˋ1D4ҥ8- XK9oPȻ cSlެ7 w)"e@dz؎cQqh?5ow̵GP="y#_|@ۡU#|۝ˤ!HU&_4٨@lxj@?RٶjwgO=?endstream endobj 272 0 obj << /Filter /FlateDecode /Length 5039 >> stream x\]s7v}V7L'iCO^{e+Qv%vFE9I+j\ \4{(*,܃ ZQW=:=w@߮?G?R'cQW*ȕ~ڮOև3:QZ4uУ4„9Ucu]M~ 1zLcqaӚdhX"RI|]|gX4_ p!;b|\0A%"^ F]SA[GSmž :D#̴K啋,VqQ.ҭ6ڎ95"/* OSZWT^9({/VƼ*W)Fi!)W:mw4[.zcI S7)N''!Gh% 8&YBҌ44}C2fx!~~^_u,sQՂe5 uۤ>]hMU1w3Ǎ!j#hmEri+KZRGCdr"F"I.~( 8.Dbtgfi࡮jx60h &53u.>6Y2m?<0) *tI_G-E%$5)\ՏЊ-k.Zm_)]1K iW@=^h#Qj X97μz0waIS<<䕰~(VΫ1ZOxY2@r5﮳ h(j {'sMXNyٚ&:aõ! 6d-yeNjpwQɁ/y7 8x |[t{x<5}?x1e>*]/eQոhᱟzO #_i/9EAhϱ6OGRvo`^\%^+%T3M|w;HJLP TH^GZ 387}DUA,6! Um٦ yJX"Wڗ̹d$㺅lДIqr?ˁ"ް`>F#~C  J?PH#ok2 5!ca @~ith3ҩL X30%0w } 4T;$HĢ jF19jlպzoS]J+S \ iƈɀt{fTX^)8]{ߝG"Y9IYYqƴq}#I%OV_/ZJ65#h60 3w+a@"h>h8Kp,U8i ;-(Kf۽W{#P1.]¨.Tr\ #VDʒjcy!{Φ1n]yFqڡD|\YYh*8XFu$'\_Eؗ!v>7h.#vdg"dK=+$$В $ɂsDL~2'-I}z0iW_K » ț ?ߜ\6:9:*!kX%J K=>#F` ,EuӍ6=G55f`J j$ ;@sEDl%ЌzP.D_X||~C%J"+vOaD;9VMB6TъVV*nD3XrgxSeԩ2<&:' Dna1C[;8 n+/@ 32 ]̮"l l_y.+^NAt&:~וX guv7- eD'9S -z+ӯeW`DlťEV=O%[rm}hxY+a*v˚nG_P\JQ (ů-f_,c2.5̫O5Z]>ص_{qV!@-|Ͻqtr7ݳEQ&ټۚwR!|?mk^8bXNw!!bE y|<⌴=;/ġd!vr 6 Z;nY19lR'p9a'?t,XPO+7JwJ0.nmvR$rxDbB^6-ɺK` NMGy_?＼Q%{9+;R&K>#3\2s t,>2'|r|8Oͣ&{575Y^ds㞾 2Pun7G5v]`y[:`3jU~5/v8_T6.S?Vi[b8k`S[Ţ[OvrWϱ8I$6y(h#ӫVXZV:حdg:ASx0sua%XF*)u5]}M Bt;/z~o9|s&ŧ=wf 8'HHUH-`]۵=ŰG'(fHPXv¯j vQ_Q=\&^OezȖ䕩K`=E/N|{ʥ,ף9U3/9j̉endstream endobj 273 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1031 >> stream xLu?_AiovD p%B_C&8xqpȏy3##DVX΅l+TR+W>Utٞg}z"# 'ЅħQ'>Â7K *'иaʪ-UVS&P!"<[_u \9Cyy9)'iO7Zhk>t&Yj9?>20X26wįurTn>U8f$Ԩ0#4\ϊ ܃rC1#O쉃Y@0D|~O{ +T3+[mM5?m J]ҲWPs!ˊXȝ>|4>4j)uWۇV膎fWùfg4@8j2/+\g܄Zj_2 V߃<+kޥQJ@@־it F 6zinȊwD53 vJI3ywjm/;Z:!f/C顨lE!w,S,N~x]o'uWGWNw+n1m,ң @[S&_j endstream endobj 274 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5714 >> stream xx TvLb}WF%.( &;o3ŀ0  511.7\I4hL5yw799iv^y]0kVXXLgߠNni==0/ti{3{Y v4wscf2{WXZ]6e]>vzxn۳{< 4 0bfcˌg62MDƎlf0[=3q`3әm%3ά`+fc͘1+*f53Ye20y όdMf3 e1Ù7!1 `3L,DQoZ~/#'[+=[ɋ%l;{ߡ(Xr`ˠa6|fȜ!C M ;pOp|&OG1ȂǙL3YL5z:4Ӊk%SX:JN i?'F?505BPj.@uR?p wK& 0 %b&7hB4Pc:%H9"#F]2ЉZ JQN(giKPc?9Y SMAZ+*58D[̭3U-H_F]4XoIw-畯Q,Z~A9 _{soB> W/*or$d ё%qZ絀 #3Q|S+ǁb-8j32GFgl4 DC6d`;~YR|{K=@8 F]gbth_k*E'cĴViW\\ Cv'WU/@f d7q)d Y4BÒ8U+tφ50gY@/~'& d&>MBEpV(yIʤQ2򚐶 蟿Ɖ(|HF:y*Ndougk?vLq>%dZ݇VSx.Ej/ 7d %q0U_GSއ^\ʶs՞~q+[ug4¸wX2<4n>uZAa6zpk7t(/[:JU'Ek\J^LG̰S$e;˗9Ol8kϵ0N eLn$홗/_ 'E7 Y8 cAWS-i?y?".ICP\":aba: p&bug'ٻFO q _YQI*RRcSwgzK1'+jIܻf갮TN\(+ˆCbQ˅ey~`rmXWܵy$C@iUFHwWѶ]MۖrɏJCxvrdɓS=I=;Nmngվ~>JO𕸞qvKSj %ֿcNs qYL$qhZ`KPH tr$p$Ph(FshshGG" U} 8R ly[[ur'#:yʊF1a9*0)lMN9/cQth.WQOo䁪Mi:*tdz3vz'71s*}<<w.|zuMgg׻xt_l)n)ƒbCX{#Y`G$"9!?M*!=3FKҢK-JP]T;blQ{,t_ͩ2>mqPm2g!ZA!ȆʊxدXP9~yv#S߸X*z xG`c7P|C`o*Z}0S݆ 'Ӕ&LǦX:Ht' ԌdH1!m|CGa [ @\a)B]{@G=dʎzEI ^U$'RR)Nd-}6hF69)fb|0Q4 zHx聬4HV;a%>32:]\'ZGRWgJgN]6l@̿x^߲dVX'T8,Ⱦo/U߷iNmM?Mm_^fѦ{Br~P'ok+HԤ·&NT굣n Fb*ľ 'c!.RIEGuHթJV*"55: 9#j* 6s B%o}7 'z@8%B*9yL,y,Y*kg~WنRI}7KO4 ˁrA /2gy˜;2 83A~=^8RΚ>vbJ=&g˴,ZN"K$ݏxt2!?2IQ3 Z-B3Ev1]y|\:-@Q": %B.X)|#$`VhP_: *9Qˊ Ť 2m*fjJ&7b?,ZԺ45ph!&5]+HKE 2p͝ Vz!2oFL_4ޫ(HTF')֬u8Ꜣ@ӒvhRD!=t vU7X/8V9tiʬ&:ӊ 8υN;zq_HEǹ˗Hzcw_,mV6TǴبփG9-l7璅 #֋W|˞z7/wz )tA|FCplib%GR+SA!ס|2BHuYlE[V/Sqr{`ŶS2nl"YոpCUu)C9Dq'&RH{-m{tZZNSPSs~hZgɫW<"pV4|HcΣ17{7z{6x77744 dUO%P EJZǴ'N1 ˋk ﵻߜ~! 4Ue:IF0AI=dR~KG/իyn <>z:ꧾa?|%0:GԄ*J2Q&*?Zb~-/*,A8+ T(Uk>Pj% 6mzJz,UK]?DW*cOh.~pP| Ky7%TÝhsY&Tt}K FyOޓ,;]](a}_}]YŸ\t6FnȞO@FVŝ1HFI;A7%\x֎SVnLtO􇽜GmpAmI׏ƒdbR Hơ_1j: (!AJ~-܂9 N +B4/^i'|N.#JnD Sh3Ty\Y%y9_Er*DG.~6lVu@vMaAVPPL76hpfoC-pKZVF~ B?L"$Hi@b0c0@?! "&0ӅϮeUB\*4c7,lo\Z'%t](.Sl-+GLfs]IJUU-Ѭ)hѤC'9&hMt{J MKH\ QT̒75_Ey(x¡TȦUUUXqէ'Ch>q&mK-otQ*/ aOqpѻFkK6zWwy4qN00ӏ8*t9Etdչ89zW~~*;2VxPEiy(m#-;QwdG)d}}SvU2+@宊QSTI)ܾL/_4Tze2y:#0BQ1yڽAcDN$=Gs*^D|N7q(2=0'_FiXI>+-e߃*Ǩi ;#QtQIդq\ e!2Xd ?R)hl 'bܯq|dcyyy)#a C2у PL]_od?J|NOEV'f a"2# c)3=u\+vM7)d> stream xe}PwwFAV6QKUh]Gm Z(BxH Dޒ' @Q xz,k3u:k{`Zgs?6nvfg3}~)iEӴ<^Y $I H:B"Ԇux}q!?7ϨZVuvi Y::Ә-4BU>+_kTٞg4FFVTTl,*ݨ7rzUE1OTk(fvuFURfV׶Z5( ޡߙPZݗZHQT2^PjEES(5"KIj =0'9+](-~!A"4{ebXs*7Ch}QXa5B5(4̻v\[>͠r3mN M߿SxDwԝ:Ҫi7SwfJ{ } } Bv l9g(x` Pv1TufDʟGll"(| ^rzT9BQD!lc1ՃΦ/!g"7ilk]= Ck,<cf@?P| n'--+}u_LuCl>n,Ŕ۴[Tx  9̤qF֐}%;# &xF] }:䀮iy#g=pFbל:uc,Iuc]\1!*f\A}D=WR%.ù_;# +"f#*  brU$pHShT{d/|X8m>ɻ?x&7/'Blŗ}#+",Ob{6r 4"#'S'̲3r\I6,bDZn?X"Pl28۝֙".E 1Dܝ1p̔֏״Xou G*v$AVi;e?ONӫ0cvOf2'^ֻ[MM1}quYmV:ŀ?6) fx$"{4̐cB5bM6Ln?%'i.TrtKW<+(`/]zendstream endobj 276 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7809 >> stream xyta X22%@%ދ&mȖt$"˖llcc: @脄 1/ﻒlo嵴,if=WkJ .[=~~@=+־%XAO!kg6Ҿ7Z߇ ! s#wxz: s0~&7a{WgeΡ^~Ρ䍯Úfx~8vlXXg1#a{{Nw7˝̛c~( uvXOQԪs6 . e_ҿ^>q\κn`P0h S[sq{2F|%ʬ|iKI%mIV.QISO<("]8ȡ>S/< %ا%U滱w\{ruS^N_z*es!oMe&uTVZ,a5qzA]TsW o3DPBbaGv;8gxKaVl1`^}5E,HOD4$6'9 tꭖII ]|ڈv Ѐh4h B4UQ !) cBOH;R~3Eb@2x$>+Brm!0QZwk'꾭:}ˢ.4pd?hI}PSp=i1|S (rkk}sssav$̃FtZL sm~ iz ҂{QGzӣ ^T;=;)B#s$`k)%6uC(zV>Ne6zΜypNJ&"$؎4h@S\y`>jr%޵nΙ,;կb}%mS'da D򳹡)RRU.MgpWa@T"~PT%: 5&P/Sxۊ{O3vFDZ"*v}NzNf@Cu(^DJgCX4؈"t?)[\MO.W]>ϝ ^K1qQ~ֈv8h} _Mu(R&#>/sTMcq+?*ԛBlljuZ^B͜dhH410ih<_4#MrAjVj6AET uw{PW4}c7Y/_<ܚ]tG+rҵ:,W{YIr$y"oX/BM[|ĘWo KJ’?lӄ[jP#{9(c,a6%WeRM#k6*C;jBevlLےkUrw49MnM 3}"?]dEU"7nZRY8'&H >ǑE.撃LGݱmKZ!?ʢhvf汣F:HC a t*= *>>1 _v!҈!z.MOȊ8{?7"86+zݡu3oidFQ˫ű5w.06)8hEOD^kE23dv3N0t{((ҙP-RFNpTZ| Ԫ+an4eJN+4FuTCܢڤ<(}uݙj)ˋ"KH4 Ȇ&UMgjL.ӃȣSE׋E:tPڟh:3 #>ZвjN6f "X+d %)l:Yf9쇆r jp m;}ݽ6,i$M dX.v񜅋5 dd>΢3zEqnDIJ"r㥄 m+U6GR0x29BOV.hRȷ5 h%xck/d VlLC!S^&yܞ'9k~%`u &qd!Mr,ʳsQ *|5cw,pNlkZ3;;AJ8`{da}Pŗ"yp6A c7ZGA <:8ܩ/J ߠ]b^s@TmE]ըUƷ/LwjT;,JYߖm&Wڣ8IatR(Zr">#rUB6MUBV @*P)*gKEtZZ*G?ˊS2ɇ /BT 5^P@I,ڂ9R4GoC|r…`3躢46 g̋lMvVBuOI1c~/G` K5 Jy2aք6 @.VMBh;IbƓ uc84-F#Dّ(<gbԱktLhҽLu;!eC>m$pq)̄UV=:e@3|o!!ؠ=@_QȢ"Q4{z/FbDH#O4\`2Խ2e6UaМkNlſP0*յIfnYU30@Ot$1.4qc!ʊtM{%-qn0?b=<_ SN}hZBw_Xu5(S92HHRI"a3$y{.溵%Dט2ګO/؊O,v0E3MrBGiZ$fkK|A cLVm\͉IB_x;c\VvN_:~HmKrtKߒT$k_˞ Ŀ N8؜q"ʤ*ҠlP̼MsJ;[u\q^ՠNEu4 &'V[w̸2 uEwHJN _=bΊ֗/a(S^g4-aP RuPTD"‚68yGdZR_R]]^^MR4Q`@PA6m:ێDs|4blei !18W_/p=fL҃ i:@y@w>l>4K"xuAMhV5+hϮlY)*RUՖ<@ ǰ-SiӉJ|:;MI{+b!e(Qe b[`k3[h#n@9_^4LO tyڢ^E<37B0}ڶ}[ouLcoim"l"lwG&(UUDRB%;^#7;`0'm;¤ Qtk4E&--ū|ho-֌nvζ7ߜu%ůCܛd~J_3_t$#]$>VL'fT='r=aIlQ>~y<,v)jAIFlhUX5oQGs>i" c7҇hрFsPo7!)ZyXۈa!̙9g4}q60 FQ-H Y@'<%EeIa'Dgyy$M+$;"!326,@ݛ(kG=mMKR xf!?E\~gq-CIXp1eF(u:(7sO [\b+bK k>_2{  8,'K봥L.%f=ǵӅٜFcVb,wrdW)f<޼7')/&.iOv )|AXf4؛7fUBBA]$.=\&%=קYh)A*j=WѤlS| d)RlZ;c'x[!͑M35%IWpoI%"_i/JO֚Y\f4Ewvt[ɷnqz39A.c|'τ{fJ)CŴp + ?NcÅ%ǵ,ak`,%tlI~̣Ѹ4iU!:[Pnْ/#j` xENuF#/#:=mQ} D%\Oh?4c2 ^e{KU9Vd$ED[eDlwY2Q)za+ڋ^w*O]"3f6G!3̞Ϥ㔫$~[v(Ue$Tψe (4.wI^dv3 :qO!~, w\jI0gI^'FI&ݾOd HWfe!]~BK͑g[(iC[YcsLmɡ N^TKRKiI*Bɒa f8&j$D>%FIa:34T.mḧBlbįY"?Jp]<㕴uDb~My3ALeFc̼l޲UXKqwB~SH(=8tp5xZ=%o\(l_EV;-_ 5#a&g*WW&q ik[s"K_u:U׳>gϋ(@{endstream endobj 277 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1512 >> stream xUR}LSgNSe 1EߩE8WJ QU@mυ ~QiW U7}lٗı#qsX̹!{u{c׺Q8}#B kvf0s8}+hrF0Y4t+m31d =|t0은Vks^Y1FVh?'<gN47 x10noٱm,G}iSbt*jQZ^ܲ >>aYyL!-(GI&*YySEpzyvPhe9٩+9Zmok;7ak#` 0))+q&<ivÎ?ʎpl-h w|B6wm]^n ǁ׭h6IZ9 [ 3{p&^,Gￄ.m=ki-1VC]XO WF앆Wޙ 6ilu*˫2.aj `KioQW Pp4Î8#$ ,Lřrj{]ۄiD֮&4aDL/ ^v+]ݖ |5NgIVXd> Wf͙u^wOeH))ϒdν.xp :훋37~+{.N&-%!7|ޛ8/uti.ΓbR4K( |}n3cn2mź- v`뱃t ުu>r7ݮzp0d(.)Q 9y;ttvB3Xݩ3,*jp轟9 ͷIQ_;oxStx**qS#_PM TVMTj/endstream endobj 278 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1108 >> stream x5}LSg߷X0rUk9K*L t jEƲ(/h4q`'\D҄2Y ~jQ8;mk:kV*v4[ar486T樵 !mݼe[ۄ, [rK6lCr'|Bi2]IhJZRuKvȇh!9/@991jy͚??ZIí#󉉧kڼnm8U] q+p h;Yg['AQ(V/u^}9I-8R1坭w0oo}Rpp{>RZ\6 5!{Bi! /6ewto8sYBc3`몿Y}Uu0Wd^{mmLc1Xq{;:?@81)nGvkp$v`.$E\zIu7FPDkuj\-Z ̆Xu+"&,dRP5Q%XC {ps ̵q6{>.4ࡸADX,t-F-EELP^U|6NaPiI?ifH{ Bp~ PYgy ňg.y[ ؇}/x[7`]~#[ʞS=<3 ꂀ~F^>O$?3.endstream endobj 279 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6097 >> stream xY TTٞqpM I${F4FT=2 ;lvg7veXAF뒤IM5Mk,.^z͠msz.,\C8\.7d[V,|eLb~Xdʃ͡MC_>L9<.7;_>[T,NMN _(|ի\|uDqj|lVؼ;S(ߑ(p8+eem(ݔ`ka춢;w&E$ٛ/cf䚅,]G8y|.Ӝݜ=}ŜHγ9K8Q ers6qVp6spr^"gg Kٜ)9rB9q8Üqq9q=ܶIOOCW'o|o 9J,&OGdS_z}!imxl? l]؇OiOÌy[xyִYff}pά9 :&?:g6sG塽h '1`(Ad}v >e: TFJcL6rghLTwk&cr(^st3V*DЩ5 " D~(32K\% V=ͻЄV\G+@|sr@ScKD~?Z<2UN0ejN5cx@;t`1<ʕ =6TSG{ISY<Eyz,J>].U׀DM >y ~XH6J.x][lrPc:qܱͿ⡵T& $ I'TS>څTZgV@: %4uR.?o|Έbw upؗfvmT(m )c~,lLSe)Rޚ&,}].xq`}ݾ*]122mڡxnvM=V^ FhJ1it``vI\YPA`utrǶv~#>Œ)[C8U26]"RJUY lnBDA'@Cm(_(28:u'ӔAѹAk( < JD6f @8/QBà*3ZWJ;&:)['\~=*"Y𠫟Ta.CnԇЏZ^AKȜEZѳ[i?Mʗs% Ѳ+iRG>P_ twYH3V8qQ'(.~c8=~6I}mKvr[&u*( W~| vJܳd]x풴%|?f(5\'pCCg-2  1HdPpCW@zEfvL^y"KV 7_(Mp_qӏVʙMvL6E0} h}=wx/ůqc䗁zߍZ*VĪ+ 0'O~_r^N'0#9Udkw!j;T[vFъQbf L6̄[UUR~m1d¢@DmVB1Y.L@Ti!/p\H@lY Y:}5u *mO0EpC)ڞ D4Wߪ`f"x  6U < 7x bq3G3^f)vx*LePT/3A{QA`T^VG+N%3U%gdvMM6ӱfb-l>`pIk{V'pX~1k2c^##s|c:q c©1($.?2=g@DI91ųmZa;aHfӰ(yD>]qw5=0uT ?^^>A)>>'Ǫ.8:*6uR>!c\6]c+w`J& T24-p28H:g01 =C4χ']OTU]/t,3J첹nᚐ&FLǚb-ߋ#>7vJr]&Wư<`pll/3^FuxSc5bbf&<w?2f$|PNN,uΈ`1Ɗ^O'RK-yTs:{pd˯ѓ*ʭ JnJ] C_NQG. vcWwh»& (΂%$?UQ~=̰ޫp=hP0rtA𰖫rjI*[ FPWv2osG 3#؃vcAJX|x ^sthAY tο=Gi SMAr݊ iB|wͯ?Gu$2[-U XN@ґa_JE-1هv!;œ +/'.JA4Uƫ >ՆxNRMN*ߏѭ?LN؅ z%BSQ6v42q_gr"e:C3pgJ(J0ѐmZ{l|FO^A4gn%5h)&d5(''unS9c췲!;P WbRVlllxgG BFCZ;ƧH$)%yI0f(CXsCP}Hˍ5LH3 :i'\:w$SWU+Yff:+|){;?Zۭ^??;>]Son0IxT1 q8VLm! I:STAtU^WV4l,z(gl..M3|抠r05ީ sADȜ<UmhTc#S™!rdӉ )&qSQ[ BU7j۫7FM? rO@ R:K_Un{ kߧԛm:|8T]p0-g%zpw!ﮂ,X}2Z"yCbhmS5N VCL`mI3>]27TFeUc*LXb6`44qY.aBw^';=-3-h#Fo_ $٩yՅ-v5{%<Ȫ&kߧ[p М&QLeш3ڄa@-^ڨwUaXo5c1Q){xP|9fX F`:+s/F`Dj6F*5&F!7м$^Ks=Cr|=X%(}-jۡx9f<YmEG#R_z8%+A驯v[ϐF;uX/&͋2(l$ =dz(pyZ2Xknм,/3^TEGȭnCSxh/}En~@!{]ZhS[%hMnJ\im!@}'E/Oja-͍ܸJ )7qiÁW:2^wO:Jy3dCCbIv$83@ Yo .8}uGnL*" 8(߁68A2[RU e {9^q(Q޻Zee:P+L@ޕC8tk#GRd"WU&q RZ`:Q^~aI>/tj5D{nkXw+?~sT5endstream endobj 280 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 192 >> stream xcd`ab`dd v 544qH3a#ew[ς 0012:)槤)& 2000v00tgcQFBըqVн_pON@[{W4_N\;~*{r\y8;yCendstream endobj 281 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 328 >> stream xcd`ab`ddp 44U~H3a!3k7s7ﻄ'~%XP_PYQ`hii`d``ZXX('gT*hdX뗗%i(gd(((%*@s JKR|SRYBt^}ω33G[7]z}r[~kb}vEly~_d}{O!lYwVWG g/d4mn9.<'yx.x:endstream endobj 282 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3589 >> stream xWitTUE !h Su4 ƁyL ` JR2W搤{52OL0m#šIՠM?;E^[VUa}>#F$ɘ7-8]*%>%?B'')'#&7'RR$-۸2-=?Sq`fĂKώx~STqI8-N;Vi#fD&i͝57-3񕙳#rڤ(U*3G&-U%.E1ܑi)ZUfxUf*EQOLfmt ^-1)JF&eFzޠbNj5CvS5jZHmQ/Pj 5@) :hKBK|J/2'd@k) oR1M ; Y.L4G M-m^[seNlopC"T:{LB Wqܱ0շU\ռfn"eȖ^uB.938 3X14)gi=(J4*p9}c^ t`5`*i=zC谡МQwCޡ rf)95s\pxȟ`t^j 4ޏ7"E/\`]hQ0sJcJU[* {-*@/}&2|y("9A'X vMʃl8/3?XIgzZ<);@VXE~Z-ZnɛvVt Nͥ٠Xk@XaJ bUi1!]&%-x . ߉|AqD)\`j ks$l߅IP-Xɯ 7v )#Ajr%(oy6s(*vV'<烹 `w9+xQ~#Zꕼsq.KѳrK1R򊋀6z=e M/}mn.dښ|Y2}w3XX9x +urʭ\s\v Rp;ߦ2ܜb֨ ޗzT4yu$CǥAqЫ^ 4 l!b 6pO?Tb01?>vIkxX y{Ӎ=ƜEY85's%@nÇÒV%٦b&87ӎVyJXS5uŀ }1^ !"l([ҡT.ϔi0uëA j+d_ (:'`?*{NǗr:ZJ=~A~[*,NAGo?reezO#)g2j6\Iypmׁ޵Qh.rIm]_|+i7JXq]f @/e>Q12|w80*JШDSh+TXf,#Z7N6s('RdIiNɺq8q=xmD_ r6Mž7_CT`z51شD+eFLiD+wo PzjI=+TB^Oџ.o4=$s."KӁ~k]ڝݤFy7ZxM-@轀DW)D!G/47T W#w 3@!q9CZ,Y4IRoBQԄb?TtsbBn&JEt1u'+HQ+uusгyUuzMc0Vۿb DwЌ#cTFR?Chon5{zAwTq\s񑯗vuն;QQoYgDHH>w[ߩή&>;bˢg ςQt r[ؠzo9䅋/ߢڟ['\GЊ8~r#ױ9;^s^OaK*?>ܡ9T+uAj9-!wX f0n"c3@!䁛*AKXeZ ^5>/;ϟԐgTʱDև퍂(v@X×ELj'9ߓ5?JQTTДXhk (%qj_0jyކ^zsiaRzJ3\RFēb(cr:%8qָL 4s#'P@G?{3HVi eR\*8b&[yW۷GP'CқZ:4]p>p&~ :0T~[C]' uD`)x.b3e #Y&|F7r$ps2[4*GHF8Q68hU ^r2>1{VU>GUrj/w_='@x "fkSTU/;e37Ĭ:I/ P{TUgvo8tPB2d"\6+Aݏ'6$tJ):< xb1pU:J}orsg/̅EN~q_UOٍCO~ʓd7bgla@H/ѳF E, =hQ n2$v51rj' :_BPde /$yLgǣïyU|3j gA6~cly?҄=8vOrrO,nfg=PTiS*2k.ex$[U9m-ܥ +kQj++~2N9vǼe?O$endstream endobj 283 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 925 >> stream x}mL[eǟKiw݋6 {oˆdYfK^32 KA_v{vli;yvml٨.l~D?M4,krNAEij4/WwRrQ 6voԪQ{X؆-m+RQYOQ8P•Up6^v\Y6naEEKKnls%*Z |'Wܫf=r؜="/pN^#4N:tEET8m8u3ǒ uI~*C}y̨x\w|A>O)pn qww7R8/έ~4w?POw?:YDhpZޚ{2B<[ la9'b2cÃa,)'xNf, AX ~c…$B,u _fF+zr5 S NbAaw妑@J% )&,F^8*3ᚨrtDXpN8S*O>M&~q]s'}V T`gKfP'? ;rhHzeV=oS ]!Va/Sx8HeyW#z!0=Q\IRDaJ_+Br̓K6vɜ}s;.#5 xD 0 g)@<8!5/ 4n\rҬCVq?O8eW j|&ya%t5R $8nO'nLaSwm&0Cݲ|endstream endobj 284 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7494 >> stream xZ @֞L]If{ZjXE-5a ɦuW\qKkjkX'!@A37w=;uJ MbXpqD?Rqqߟ.6h`]?b}( PVApx(q7Ξ$iSv\%! A^(s}$ߖJ=&9Q+q\%,8H#ld!/k./qEQm\iqȒХeaK>wpz,\5zJw^w1kQN޼\0aIr)cߙAQ#(jDVSc5Xj-5rS7j5H-&Q[fj 5B-ަQS4ʙNPP˩ j&J({@YQ(kj8eCA )⩾#ՏzOͥPy j>5Z@ R[)[JDSQ)z@I~/ۧjU]lS#BǬe>kշ߸~MgJ~6hŠS_5!s =f;hk^Nc[ڱvvgg8 w0 7L?4b?%?OV1#1*kX1XpOg=Vq@@AH^x`^$(YbT=˪P}yLrV29]Z SpΪ`·'D521YLȺ b$RZta.a=yoC?xd.'t>( ݭ(| Hl*bgBQ ?JT/cXm%jo[5a&gW C1|I"ஷ1- Fxx~4 fU=0VV&Q CN^rw [;θ"~]Ƀ^p+7'N[cP,a>?3؅w|wOL`!A$ "&]˺W8^~ f%*,4ݮ"h/ba5oYI Mnsqi˖Nbmڍa,0삗 Ma(^!AAJ>M0OL;L7~6">#:]V&Ӛzx[7!ANP^x틋ޙe{>ߞXCGO?O-Q:eK8O8{yeF`fpg4} 0ޙ'XG!ش$2j<[NU8rT냢:Ϛ5gc&asxs{Ec%eͳg/ti{c93avcig-yzovn#.4[!aP`'D}{u[a;t$ g wKؐud`}o 졝a%a +V#B[GwxQ+xK>,W,#(*z[#`>Բ0~#2^aPGvzEvTqV)ge_>bj~(04SGG7tA 4eGX3LW#ס2ܢK;.>݉/)S碽T >#hʼn"Cy͵KLU,ITSzͣL;zA1ʸĥsZ6\KcpǦ=Aj9J @c^pL$wl1~dz-&B%LUV, _֧}gSJ/(1[L֑PW:*S -&|FE;u5-%OKډT)7i2ȞP=gJ2b"(#L_(QYqĂ2TQFIfzJ0aVT@LmWAHH!@xs;KM-E4+'xB ȋoaL޷ZA$porRt {r(w׷q怘Jg1={愃#ΰ6wI教U:MDZA@AhO7v=±tbAxarQo`p;lܭȽgJNlzTB ѯ,=:4EVsCD3 %xQMַ $2^{iɘn8 "T( E7Yhz>#CcQI*:\K* IկNF?3R<;V歌Q!uV*d!Qv<=\ev+nA(Y&qɱ["fNւ>B ^S.BL(|GLG^/hkj#F6[Dr4t(PjHP#!Gtm~7ycZvˌ͑ze%i P!*)| #~F]*WZbC%OVUgRf_8/1я&Q5.qKT|+P9gLWh3- WF'@wS7zc-j,1 &vG~'8mE1oD}ּ%lz۵n>i5Oٸ1!yW4Ğj1XMÊBU r/85žo..427@q\XQ3Ư5BVT9t$ŝ; RC}t5) 'DhIP`(Z$aJA'軟z.5wW$3o;q= _۫WYj.ٺB\Rp֣'O>BKzy/e@(Ȳw,Hbab˰˰mHNODă0j_RѲ{st;@ :ĞJ} VT$M88ns}w|1jG.ɶ!%lyh(VQ(2EEq-ԇVp5s|`:`+?R̽FȖcgAKESHM~|tՖipg?n.ףC7~^~]QcpE G!jIOOzOTF^E9J.Nֽt \1c=^bQi]^\^[[QQusPri&%E0v9sNcOaUTU^aBSԘ ˮkއ yσ!1gNe^M間7_[.#&`4j@&C4' ],eCWի|6ggY>? T`{)vtްa˙?8ޤ_5~ӧ`O^UgN0~z#m:ǰz)B:W]yțC'UEpX.f;/M? @]\̾2?Ĉ@yXxaBML:@wlo>TBQV&ַ֖x?;'zz/  zz;ÉІhwOtXEWjTAHȗ:SFW.p^3uf@a!aȯ4˂fx /iQc?KL/ =]nNt7yj׍Wس gz,v;D=ա5D[G9ϩϩdGg@Gmzۣ7A'(v3'{aˆ5__9ւ.0gw:9PN낈 d: tB77[ W{|aekg܃Q`/(56oN,鈃3ꘌZTԥ }y3@3aC;%[16yoD@ꈒ̬, UQP4:пl fHVIj,i@t!drOJ%|_F*%JA)2`֭/lm0R+h2n2w&xg ڜ\@Pj*.ʫ8ӄ O(9KwI=B0m{^~NO:#h#uy<d,k<+bNk2rP%SV*Uxnuq0nSkG%! *? jC-1{]½%SP,C]UAn~y\sg @b%}bG QS07i^~?:N6f|zAA[`+S)oFXUg/%b}gK6s#{nzR&Aۘ'vP$ƋɽH MSGnu\Qkϫf ƜQE9Ś}(7ؚ͖I*ve)JvN!{=' N餀 mnVFWx%Iw %@x[Lq~N3)/v I\ɵ01?!^418I$AO|R%q%"Sf #̺t\EIQxȃm==< $?;t9) \ԦMEwV!&Kw5~/'Q,:Qr麒:ti?$zkbtڂ W]{"#Z9zhw`m1MK,s\f`ܿvˏau2C8>zp6%D+ޗMjP0|c ++&>vt&G>E'Wa՛ZF{,N?p 4wc, F[XV\Tuɾ 0Z&!k:\)s( 9Hcb" L0*.)6IRQA| U9 ۻͭS}$=|@"i$?M>{I2Q=HmDA #-Qtj!Qxa$E!&23W:w5q2׭Ԅ$砏~GwJ{5^.KN(<|8h6s&[R$@NFi5S9$&h&)Ͽ*S.~"E: REf\6oMuiLmȤh,ݟqlv*)'&eI2BQڊBMO&8eHL':+ǀu4^A~ ÀYþB*xk78<{=2}wRh9eMoBF"HZӣyU2ڄBbe1T$KTy| i$DLa)B ub#2l``Ur?\]W]f9A` Z׻丸kHL$8u8MZZL t&͙;Pg"HLNArtc3`j#9/ΑW[_C_20`<;{R3'*'#ۦ/ݼU>$tWmR"1Ѥ-O% $~c0b#ʭ(˄Kc$6>A{Wk)T</_|R]eI}:S>.~0!&ll s{'X,ݲ̯Z5(9/-khizr㔷{`OH8*Vz+פ Ĉ~5ewW]1e|VVi{@Mi5v_?~B)s&c pn~}mt6~ƖĔSP%؂B`$ZN$Y$_kkJPQj#=T[\WʺNH(VPV*bЌ_nRYruD'@ݵރޤ_.C)X)t0, ~.tr0Co{}TI rʋ+ċ˅QHXi> stream xuVypSu!%f3zPZ !;\APhqc;w )4x;v+{ZK!%:RPvsI!=_Ni*iOt7jl((p.Q)t@K>:>~˹@m('-&,mvy;`njVS~C\x62jۜC39hz\LfJBZ4lr~NDћNȀ7B -]d3)IzXĢx*;ud7|f:07-l$e)g;('0لg4/r˗ho}N7|DpE>UaR=%osr Aϡ9:+1{fU a23u]3A?./у\~x7 ~vܧJk5SDŚbc~ a&ߠ":*t:j.^mڣgq BЂ-1{ {hzp`poR#6֑ssa'>X-_/٩. xZ1a7 5[ Xl&y^'^ch:q  Y+&"TTd!>}Mp+| n { _Y/HT2m ] @(~I]'|\WcbH AEw1V]t.}p7mPaA%^Wtz#C'7yr5!'|f+o{dë}6W-\AQ!U]V;?IROq!Fkku:b7+%FIvnϪuo ?M6rq:0#xP&J yf؍rpWѰM8O* ͌}Bdd8rQå>x Ed>*(+zJכnNxJ#+ck3H]2G1ndw -nJQjzƘ{XU VMy^w0A vJ 6Mhs96W?`vM~Wcj4kz؍H|!8BEiD`wE^k 5)R*|wom;wX_{?퍷?5r=p ր2nEJ@= M{ *Ks!_&6=aV)pȦӏOEi,m;M`TX x9l.W z譭hCZcB`FV!JNpm66M;"L\R Lx!{]&WVmmm̅DYgSϰSGwsr 2RݿrM `+Oư5M+yERSh2GD큵PW76mD`7HpTiIq8$Uos%|0VOUTD1]䟒H "=mq4cj;#v" endstream endobj 286 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1102 >> stream xkPwwYl1Z]cYmq&UBuNUiIH5!bH(V\hbT:}(P[X,_|h`̝{{Xx !if>7 &9 &@~꿛H+Ai1 [ yV$QTO$lV4T wD_sVte!eX*4 ',"xcTlWN͌GK6c*W4|k=}ra坂+}ÍݞI,Ii!<耧pk#)& X_ܾ<7Ѧ AdG>PuyUJ H:r(i·4-vF$sz@G WF7NT5Xq䗎/My/bb>/ZN{?2Pu1ŚSY~?34q/o j4s%CCeB^Y. FN# T /endstream endobj 287 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 314 >> stream xcd`ab`dddw 441U~H3a!ann }O=\19(3=DA#YS\GR17(391O7$#57QOL-Tа())///K-/JQ(,PJ-N-*KMQp+QKMUMB9)槤100=(M|?~xw߫D?JFsW!DW/+.[\b+_[zfr\,bi> stream xy TS1P^"Tc<"󄈀a!D$ 3(8VVVQZ;<]}[rO'<};ubʕF 7(υЅfJOnA nNyL,aBfRLTtJ[FM4aX#'̈L O OFDd5%:%%a!q!¤iǤD,LLJ0W$<.2}!%KHML nL'"tFLY $MN mazm3#B/ ۱4*zẙ+w?abठo=pio aM7=jxqHARb2&H,' b%L&kZb&1XG"D1A%FQ|b1XH%x"XB!O%џ 7`D'31BFL#ӉnDwI"64ћXcߚRxޮ?o ٟw`: *8N:ＸsUA] zk@Wq׻Vw;=G Y^'__5|Eap~?طCߊ 7pe jvw@@@ jYѕsoNJ7V*͑Y D;%DSXJ'nHBo84 HQ_,O,u-{m(.LI?>^r|:aW|-'m5D f{fM!q5[҄;r`fJE}vS S\W}'esrcKn]q_l '? vl*'aB+S˞}b=;ug  D G;M'^ltDӮG=Pbw ; I&z?swW>-hfN kIk]rؠZو&Uv)h(~R̥2Gt6-ē ;{"ZN6E|9y_n5גU'g ,E~eBAMDbwݜf-^Rl͊wS` AZVIc/)3D#7OG:Vk'1=I.J(xӺ+RFaWY@PVr$sA>e T2n? 8AJvChj^gZn#J+0à hͅ{5Eǀ*/OIǸK_+yz8SQ@cH˗>,SeLH_ۑTѕO . M˕');9Z X VWbak իJr',@Q 5.A2H*G;P?y8C%\' ѢalQ Pe/3e zC+߹ iI?͇ 1xꚯZyUބGk$a\7dovQ]x tu伧!E $^_d&Ö.lYp)G(e^ N9ުW9/P؎R5U)EnuH_/֔԰u GhvYmz&E)W6`0g mj4Y$oWkr[8eg':fJ<\{CE:?l;>B:Az )u RE(!msQॏU^z E$'@ }]Fi9eYEqO>sBF;V-ϹOls [ถ}tj`9s2y)>{r=(S=0(d\W~n|;zv3ʋ UV/IZKuR (N-ޡR 0QVYe|VtӶ9UϼSO.Cÿ\%)U!ϖ1)[S7js17e1QkT@e胶B`,֕QcW"9 m*/,5RrxAW3n?gB{ ʼ^R h_ehJM*OmE " d*9 Wo{ 4.xq}bN]Z=.5D2Nr^] и a]P_y{>V]V:yI:9lݿV1/MQO3yƩ8MA"Hgjķ}c~Z`H2H#fN˰ sXl: n^( rm2:mOl95@=%@g__]^s~͆e!1LdP TLY~ia"pBOWӁF=p[G@}(p'DF,_8/>MLGRo+ [[ofѼ 5eKDW= {=n9Y q92U4N>aoڱ(?4ɸ#A$s|X(bqش`6Э N,g\|𔝧`BcmF!@tۇr:tC= (LҼ<% n#h1GDb 6#EwrlMI2Rsn/}q_`74Dq-GΟ9<{eaKxֺz@ݿ,>jUW' y@rtfgAOǥ>Dxu8E]Yq c^'77f y4@5Wړ/FmN,__g64kX}RD!߻clWɯ׆Z>{~7's tuC"LJ640hS-zqKA{}f|EJӗ& @5PZWѥðCT +ZIQ Z6kL:~j ȸF], JS7`E] 2 $8%Mdbrm9~r&hgcsk=8Bc>L{+] ٙW*74 ɥY9sp42WR48]Qy~@Yd{V )g6ag;ƝKA/ Q&Q7 8>Z!ZAk9!{;yٔ@bo@o_[~O;k!_g%5gzQks{D-@ѨO鏺{MP椓_nuS54a)Ps -(ZY82 ^ZU5!Pl.!1J@MHQԥgWUuU4ǻQINϠkB= jD^ )T5Q[zܺݳ@Ԡ7;?+"*lUr\$ :J A)A䐶Z\z3tpUw5mn SPߑhtb@Z&5m: ΅abSUEY m e2S%ɏ͒+),pLhuMNޕ6x3,ޡo8שs.v!oO~ӨbYS#? 7:5H.sL/o޲eU1+||֥.[?Zx n?᜴F5USU.U3hJ,Pͦg` Wytb`˰-z;?xX Na1 f\JajtKi 8V4`^#P# އeN0(z[?MPI𬩖 gќ==6Xɻ9No $R |}!lC[5,=Q*Q0;z0D`fϑ(XnrW*_%y9e5F{}_`6~"؝Y{>\'1.:&&.2Αq?&ڝ89''0>כ@ޘZ)eYp\~y3ŌAWGWKPf%*TV/u uH6,Dv$[ huZKނY]jK[F)bRPfiyҤab]%lW[| fW"a'GϗP6@M`UŮ!+8nO;QY҂< rJ3!yv:!ٲWRrs0<NCz Dr.p [z~^7nBY7=7qz*QjZMF8{HpRM@iu(P/KR Vorde+ĩH.09 `6۴3EG@1ؓUPv]mMW/X-%OL-2kZVT`DIf̒i*GI j;O t:EgӅ5݃f+t[hH}u~UNA$Uf9U5rT<>t;PY8jO'@9(EOũ`A%oQvVuu,)W2j(JFy9YXUǩbH)&߁(i4 [aug?n*l1}而(|KGt QN֥<]9GDV^,4wƴAYc$zŌ6ݚd0'?/<yAנ:ꈆ6)\`fos sǧmgw$ĩbTKb53Ϥ@88CTgILd*Lt)ᗛS  ,yXAs\~$Dpw;X]ֺL5La o%lQn`JKY&8Dj#QL. ܻendstream endobj 289 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 891 >> stream xpCMMI8%`_  pgansCopyright (c) 1997, 2009 American Mathematical Society (), with Reserved Font Name CMMI8.CMMI8Computer Modernpartialdifftyd@UZEx%fBq"~z0"{zip^l+x~x}Orh}Oi!|w[YDNv`紧 wtq~gvO`:BZzŭ_](b!ⶮtvtyb!zX\)qƺ}Sde[jbcq^zewyvuhzZ\c e,ltSuy}jwZWnN (#O¾Fωŋr}TxWdt@YFWvk]tȼ̞Br)q~\`v8٥߰}}e0,O_[b&4M ,(6&.]ls~c͘ETV}Xꟲ߯KE>Ee/vCp`  7 > stream x]O y[%]21&bA B:t8K结r#(n H0lY h> stream xcd`ab`ddds 4T~H3a!ì<<, / ={ #c^qSs~AeQfzFFcnjQfrbobIFjnb ZRaQRR`_^^[_nPYZZTWvt-(-I-ROI-+(Me```4``b`bddqӂO|܏,IzuOX4+>]֎vɪ=SL+^~ os_ļ lhendstream endobj 292 0 obj << /Filter /FlateDecode /Length 2503 >> stream xnG)zyhAѤauQEI{ffwϙ+Rݢ`Μma>gx5{e }yjepx|y6KWնRϗYO 8iy2{[P/Xcƿ[~eF5xcQ\ت=iֺL=? cګrb wRyUUsιZ׼a#K$]גZI~`Rz[v&P)W]_Si)窫VT灘\6Hw&b\pOg ћ܂+@1N9kB$zh& l7wHS!BV/1Ƙd}R>O< G; AZ`<3r<Wn| C]t`i|lO+˧\%iQ=_C\rz[<%2^Iu',8S!]A5Fs( x(AF+ =\$^#"x ?@ ^ >S"#/%lunkPҔ/_V-/xMrԲKI>2Ϩs !e"3fә ,}QrnP}Bኺc@ v[̎ a("קr(NbS..@8(b?ʢL7S3DUYtTH ue%~Ұl}% ؕEcJƪ0yd@ҹkHOBd;c\1h;h]vlIk$ O Sm[ǥj)^E5P(wi%/ "d pKF}, λ=ⵃ ) Y~VAlGjYv|JK.O}Xn/Ky@~ ˩*{!(h(bO z\6ig]ʓ?&IQ)R4gw&}U(R1>t~$3IBn.A2J\N˧N1f%X1 Ȋ*c}o](n"TZut4;x:5g~V<<| < ;eb܃ _1(߭%sԣg4ģl i*LQ+A97_H/˓$y j ű4=ƛB7\0 ߞ Ƅ(Xåoe8"ΥdgW^Y%k' 8Ry+ 帾J&?&[ IGmp.]4fS2d{Lvq d m1xjgdoI֓8\yY t SD!=nBq-Prn ùs]%oqT: W dUM.he&Jrf@O-=T=lڛKIy礫ZIfL7*:W2^d11_U>J۸csIc.1#z>"PI]%YDy°$qs91%A>lÕj̗D\:A3/%+ ggC3'UrBv"%mw84^rKD ]7ZՂἆQQ`MnedǤ&ʚCVnQ R{!D7gON'3l5H=eS*dbbM^u M2ɍ0]74B:^+3&7!ŨJEƹ ĕD\|! /Qm)LVBx]\#5wJa)!NٱE]Q?67^5zH-pDH }Gd:ŭ代6ʸ(B+QyhxH_ M%&R넑DIab OJxHG%Z:Q`&-X7*ϫ;HC}jb{b|6h  5u] m!Y>dN_́ 4 tvC7[Ouk[o\!)H H;'Vm0 Ё.mPjӣI'k oibiy: ]"C{Jx2E̩%&8<1SI+hrmRH'y)i/1`f^u$n]|wY>a s0 <+"a(i@`6 ٲET>gGt}! 2v}FD'zkes4GF”8=jqJS|}?M;f_endstream endobj 293 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 993 >> stream x%}LSgދv"sۻ 67 lM& pHG (-m)AD(k# ƁEXΌ 0if1#~ ]$.5يIN9PQ%KJ\"MD,8X%!>8/ I)J_՘j0֚t%>h mKkM"u%jjKp E:~b1ĪXdFg)峴fɪiJ ke+-ՠ7V[&>àњ*B֡E": A}6C-IvHn5"< ^/5=bN-/M|= C}P\uL@}\d#1d;:<k |@L?vCn}G+,y­wa #Hk% GnI1yƺFA 0z..Ñ\F~c.k'/ t$*WNc$P?a{~-5~ޜ}rot)0vNdWOܚMsɯN89 Ṃ͝ ;RtJb#z鄊{@1^L=:祖 X*gMLVeX:Qg*3$_vspu(HhBNr52:0vpgB70Ss҇Ҭu[lt!0q (-J9 $T̤Thhȃ'2 ٠*5rW {sg%>$̒p4j)N&'n{.A樭p+ϭ@NwAf};tq'=`pW5ϔBHߵv njZ+_ގ#fñ> stream x[Yo~'#Fva|q+^M\2S3]=%i9@@lQWU]Br!_yϽXo࿃d"8~FD =}Q.S.Vڅ.^zsGMFE].Ec^EPFzCwzZo{z.T^ǠaNiխNmtWi!LH#2)ά`q:(nc[miP9؉aW03 1:no6Op8z}<">0hBZ~l& M`UH$ܥȼ4hbPF/(^[QC@:dU8di\,s8ep7Ȯt\l|6!m6RLw^X7-W$:t !>%œ:hqU 4s/e uλׇZBx3&TNҊZYbM7iZ`wqQ@A41q% \l1Vn>;8z%hJP}@o! 1&i kdhCZrFD,(ص\9Ԡdli\Mm4Gw΂nT-T&]^-P+p٭DѯO +yC%(FG>\>ԠtTw.b<߆e2p[wS'ٗaKF aXf̷PA+`%g*8bHšɻ!x zcZan ?sHqlQ4gG^<>F-J+^XT4g5 V&q:r85 8u2V ^ӠԽ5!_+'&iHdG ӉEWkJ'n"FX֯,ȭN|lv\N+r ox9ۋ';c07hVrF7W+ WgK&9~8?SSyDQO[m0fu$l >eig ;qΪ׮$eVRԊKrya 4.;eSVM՚_f6c9T56e`{۬2_CIocG KG>Ơ- KJYUist!n&?mcrXXK+n(Uc5ОE{t9x#n9aO&JE,`0vĹ5qa⺹Eij#JinsMai2B:ZL\;tR0Qg|?|g!縒P2F']d؊F`!XKVrz.})11R xCpMUi^&Sm Pzf?,?,M4ϬהُETSdS@MSd4?l0)@"(C#>}DcG)4I[NGM).v1dצI[蘤9К_;MAif(1-S-T,))3?C6\M1hBbŚ nt+1cdF7M,nCɇRKb*Ng3ZIwOy_\C WyHUyڱS3 )wO]y+zcJ;d<|J4:YGT2'edž@*.%cȥ yJ y_M37dwt-3,-=c>.EoNmx%嫦\LJCiS%dB}$9JI wZ@ scUl2;)z+h[xAb>J`|[i (j{ ’R:wLvbh<}tuHvf޴ab%`5r&Q+O>6!ۘA;7ؠ({/hL[bʢ)-^$b-bB ߗ<pwn3<[.yxz7y6X"FJ7bF}!j$?DK$L/#0dboyP}č*G^ X6Y),y%p ='E'N N bdġI}p(87,7onFyG1;oip0' :j{\ue2NԜvMthM@U;n NkBdq[oO%CLu?9Z;aɔ=krڣ-'^6)0WxR^ @M V{0 h |0wV@ZQ8%YK5sUo\6T!J'SOCcJ^/Kתz{I;׵S\1W(8ϕT=Q }RpcW#NkIZ \O1uFO!+k rj ṠYl#G{ڙ#+zSJ`ws_MR}pc5.ԯKw3?Gx@۪Węɷu]` >ڃ/lg4֑u#{ e,Ek cy !9VV( Ιd { X&]҇0̧P@ T'8+>ёT)Ai" ׻2EejAk` QokR `j4הMR`ù;_m|2J0B RJjCqtuQ1OR qKEd^]ϟSUyb@ .$v7H" WO)rW;cG}G 2$GW}ߗG!?endstream endobj 295 0 obj << /Filter /FlateDecode /Length 7212 >> stream x][u~#&K8F@ h͌FJIϹCg6<<ܨo/A_(Wo.n{3M(soYe}3H"x_<lca!yag}T +Bߛxpjo'v?ex{9|ve:/s3u:lsvzGJEv)i Ƙݛ6jlAg/֚Cqd:kR.^wvɹ}] 9hv8ťݗ{z/DJ koOS}#- %v$KbN Q'! ؜Iaؔrb<%_hs֥t7!0pb8<~&` 흍D(Ȫr)^%|:g!on1J8W5qawu,~ԦFFO'2&#HQN<:ϼS;!L,%ThH: [v 4%+)2#*NLjfJ?7. 97\,uO;4q u% I6<)(_lBO51x0 Dhm[ E>o} sz"_Kfl0Uo*'{Y*:%8`J;& emY~"ƥV@ v(hc9" zxqE hvM EwMEFW|gsKmEA@@h;ϙSNOiqC{p@d'pXhfS;&w1'u[$8n4;^ Q`%[F E `KlS4PUg㟙wHgM1[LoyCSf9X0[I;ژFlO,d# PZxト  Opn*,!c Yz_`a_&I(GhzLvi#c{|#=~?]:?WL& ,o}2}޾c0no36tqq.As _oJ(TAGCh"w*mV>h*F\-T'P=jpK ʖaLPhf52">.CFuuE}ZEgJ^ )wP)*_sG_ Si˚D0rD3b{b Ns8\'_eyzC|[n,$¡ afԖ ٫`H8C>LgLwR".qB bYبudVfCh g·/-u&`i~Egi4t# /^J,R*䑵 ;MӇ-ΐnT=SOfy&d+{PTH[kӄIѥ%4Wǯ ȣ\#{P:8L&`n#L +NTi:GU[,lD4n*&߅{CnTB!+"oNIڰ&DG*2d?udH ؁JKjWs"P,c Ds,y$)ݥ\ X Y;ѩK@gݾe&434 0Ƭb^Vt' \U APW(%kE9ʽp1|6ˈ UF}_ 4EJ"8îZЁ"6+#qCAm0a& P,@v$YߋK: S ~<H}gzmbgSv|QgQ%,uӶADLXGx?XY$xiXČ:Dgb=ec&W܇(p=՟[&h"_4sv-AAbE8bO]SEy0cy?.>S c"4ʱ mBfVdvW``ؙ4Cَ^0Qا{e=.D{Q>7|T4\yY(q- 4:i<bC /"".xl_2a5)cfmq-sD7=PtrQKdg_n'~ GB537P6jB3 ڜ cg?-O _t]j,d$'𻃡]Ai'QEP^.e iGSjYǥxei&RBf*g[NT{}{|E< ޫwqn(hj"O) /+KmJUV9YKKX4\r#-ץK$jG5v&U"6쿕_c_}%%!{Oϸ__nk-g[9TY7{Ϟ0(ȭp0&lnD~rkErΙ(ubeY鲔Oxϵv?a{sK6fSI P0!:,b%tB#%~6@?4NTX^Cbru;g*s*:QҸxնc6J"bWNu6{kZVB+qRs tNQ]-{djɢ_'8Hz ^$l)*א/갺w]f)Bݞxn'?o2Ed~a9tFk ס4:}LǕҴb!ZMzLɬP.jvi*k_-oFڵR0n0\.;\_}w}}cHs1$wgw\b!eCh2ުgOƭ S"5f$XVdZaYKO/Z glqd*ZGQ!I.!)Jeݨ5Co!_ 8%KA v˰ocwE?[}D$ G`@ZXyT+ן^S2r1P/ؓu1ZV']J_|g#?4s9D{3>~UQoksw=}K,|qI(Pa-~/=n׭OciUf zz+;xBT6pL+Dj}johoՒ/ټou!}$=]U\b f_iMk?-TzD"6HSdԽI@x~T%i,]ʲ5%7/HØWKST*KH QDrV93M lr9 ,S@O}BsS6n Sa/g~JV,4ҘeOb9qxe~p$8KFg>h;<99Bpe!ju>uie,U ?XM V4`xYclX0ĬU@v 5~XTNŴ$Lϥd#lYGw7 WX jo}iIL"h2>ƌ ۶[n۽"Oh bK2;Tf4Ql2ezG`d#'ծfq  7BGT& \FGP|=*xJҐgsTOsZ?rdҚiހ(IH;`riO3\9cp)[pHn )AzKVa,cPZo:c xib}z> ;k003m5r@-C|srXFNԁ7O I?%);D?Y7&Pg`_ SoQ)fF;րc"I:oMV{.";7w{nTX2]XYrs kbōm?LE@ʘ0:is`v|Ⳉ0s35mF ,@tFf}\ϭV {6aOnz0&WBSG]78os*:࿘ϵ9Nfo!V_? T (J?Gs QіjΊf`]VWOkh T_3ċ-9(. yEيp`s4 _"\q+&;2uM2ᶾ|k)-I'7;wǂZJujGT{F $69i]6[MEswV֋`W`W ^Ӳ].K ^l_iY^[ݳBɛG0uA HiJD`ӟFܙi%!d#^M&?QT}c/F鷈aegvpJ:"Zmi"p6ʢr s@HӮ.KOS ncewxw\]Y]{ w:epionLqq)(vY[513=Npf$m.??]~?%ï3}G,RT(9oOvWendstream endobj 296 0 obj << /Filter /FlateDecode /Length 3353 >> stream x[[T~_1!9C1Ǻ_ \aRqee{Ʈg[9:Y2I0ZVEǹ\'g2v^:8QHEYTΥ v ]4 H,1D۽QEP+ ڇhZO{F.B*Dcu0CDG@1YZD ) ,N1JXA9XU!n}렻G @"1z3L1:_Ұt͸C1ΆQiv\8C`|ח,m3M F)B`USVpWo:F#tbPFktM-(X0p{j9_jpwa)P11#r[ɶ¢Kt.07Z2Jb=Ӧ#028'-G>OȿɤK2߶?i:;=%we=rrb{L~ =&5Ǥ]fML nd4I6amǭՓ&P0Ư1woS=hz#DƑD R"b"|J1D<#s"oY0ٿEeAE_B T~t "ODqO[fA9WqF?kF_>D~܈栜rIJoD~Ad~_53MfYs"/Fį g4 >wnV1kFox2ovLvihAF򳪂SӮ YXp+Ӧ|Pۖ' ax9}"?'a?۲`oBerZ6BHh=ܛ@ԐC~4SV?%^(?=# і^ 7dO ɚ^ 9ٴ4ׄv[?KS6iX98SR}rT"Ui|Cn$^4}YZ vP:u. ZaC{~[TM54'q73k7i&fH{376bm~#6:#ٓ}ډХO 9R6#l6}Κ_2@O:aFrRK֒9Qv&-^wҎBJs ptUFm'X3 }:v[C=XqJ|􁲧VGd r=J~ıBϚx ~p TjnA /w ` P*Vt̡qMpf.L;P;_7]I@MyUn54`&2>όmqS(yO6p"T<2ÁVO k;@Ձyxd|XhʝR|s·Be$?͌BhA柲[JP wK ,T!f 9J&č]0z;\p텶02ޒ=ηu ~barL6!^Z-kW4aLxm}r=<#<&#R04N@nJfpہl;N04c%xľsqÔ/3e*tl^2wNJpZNX%%haSRef,\3\%K{#_/Qtw.-~H^ʦ2,E;Րb;`I`XBI.KC Ӣjolɦ?^SIy+UMH_h̰1(/ۑ] l%byWՐ9%ƘF[)t5 YȪ[Vak4)r,ȋXd0Gh4>a(M0{4#W&v8ə= +)1{|AGn@ 荝:QRSkSC/ Li*Y4zŚAe֪e5d0((HD\@*'8r& }9 u }U1ȝ3-0?k3 &?TJK6e),!¸ yW} @P+JcGn^aO̾Zվ|nnDOOM{Z r5lK}`AW:Y2E^iUΉصp'B9Px .%L0@'ԇ\9]a*^ Q)|dLj#vTx9J񠙽}RA:ݟXJk4k^]9ȕ>([of١uendstream endobj 297 0 obj << /Filter /FlateDecode /Length 3304 >> stream xZ[s\N^7m,*?6[^* BdV ec|=3LY$r::=\r._y ~yq_(Nfy9Qj=X~` bVOgORAw/hsQ,T;Y9 yHH%:8!^ ;j GcksiDL c)!cђatݽÉC4 Z*S.2*hR Km\SBO |bC/P^& i9ɤf_&Gbl.5+}F!9!`ɱʞ*~>o{9Gm139R࿃KN,JE{5ƀI^UrSɧ<$\٪}y@HQ?.ZF]$29tzBd3:Bvۢݣ( + vdńR;DeK{ A]&Fg} {+¸ѳ3&d1h X-Q%2NH/*$㘏^r a'9(r:}H_ߓ]LBN-#>#IcƑ8DkC!@:"'iTù,KLwV3 2'a`@%hoBöA*38ٔFh F+9Qdlr[#to\+ Dw6;I *H {'˔$h3(y֑~0 QU$ Xla[ʢ bRT*9MR Y,. G|نt#?fAIrXD-c;=RAJmKoتJ9,Ph,b+M"7RGy!C(TW}R#xSTZ㠯3ŤU:a S±dvJ"Fܮ%] q L49Lö&]nz&͔^CvdZ9_ϔW$lhocK>x3>\1%ѩ hِ4sT蒉o]Rc;yISCy4?rQjWj{xz@l6cd#w~= K`s̑{K=m20=HoaVL %b(v׋-w&7NEH2:21JbcET+3.$1@ t*X@gSm'D )5q rE=ӽd' 7$:PgV/8>gQ}5k~R8gs)sONhtr5P豑io52ieAs56[}TKU1W;E0=MӄvsC59!f 7Q!R3izBjޭ7:HU!"a8aah) cY\6moN0m^>&Vf̦ITWݓzy%8t93RM&ʕ0пǕy^pVys[m@%.Ӟs8鎤ljҀcV2 ەdFoZhikVTo*NS*)+7Ƕ9u;*C9Wm05Z>EwsVzu(}g#;!TC(]ȵ'e6nL1(ƑWRG^.F%S jrK>e޷?c$q| Ư,?vͥ(_f+yTɓJ^V~ac{Oߡi,us40eX{{ 1A%?A%y`; XP~ri;(}6ͲY ԿtAz$u/ LY~rՅbn1;䌺7^c}*=\i5}t䧋0Ȭa8B*DLUe^܀Nt>FiuK*I}.ȏ":4N]%_Q}S=e: EBDBHO3+˩~ɷ`#]~:!v-rdӍBc+ae~P%+Q &3MtL E04B(W孃rP'jt! *@RtrCY1Xor :_UNGZpJ65Unh]P?.+^8Cag~}%endstream endobj 298 0 obj << /Filter /FlateDecode /Length 5391 >> stream x\[s\~g#Xz:Ҝ~nGڍ:tmRrFP8Cn38CnU c1c?p8>}h ^5\AH}ޮZkK^lJ1u-)[h1 -" 4B +  1JX0B`حb ][);8, f!Fg3u{Ͱ,>e4J#G?a iYK F)DB% '>tFd|Š"sx~ rv4H:yьYZ18C_zqSm~Z[G!}YiͿCm6&}^6 ?VHCO^|o|^ ^uNwl_7;CjPPњ~) A6u_L'Ba뿿͓6oi.%d靵6Z1NyCmewd4` &# `xJ~G0u~(C"0Xn)).JohIl2nt2J8Ý` t,aO{[Cz\>Yڕ2m N(!nzzhzX 6'D,^*3  Դ?Vܼ>[In (-e욻-#1.ɐ&-d2ɚΧl~yMʭ#KN)~tDJ?mYOY!Sqئt"JO E-sQATaF؂b]k:Iy.R$ݯ^O(+TY`M,  (`A;g+(6jY6Ym\)v{/qc<;lwy[ CrͻڼӮaG{Wok]28Vm,A лuwx/#) U Ȩ `Zp `ыnwS~#i+Y08f%v[3=  ?)-&0|fZT#U=u_=ajeC'*hŽ.ޒxmӇ﫤2mrZj6 PZVE бq;'J,KmXp cIش9yM!㌝82nu 4[R?F+IjkV i{YľuLWg ئ5KQca`7iA["8xq|Ֆ]+WWq:'Z݄外1Ca!d V,hA'z5;= vj3c!#/jddsBR n+/h$-`YH@doѠ͓!It^+70VF!Α&XW%Tngtis}*M4Rmcv))i=P`b4x@Y@Ytb!u^, Ҝ HUԯCƒvKr):ɿ{64&xA6p}ˮ-Dܻ9% d-\p (D` my *=娼.)Fbpل>J8EzC)HErñaʀ:QCـ}/P Kv 7o*&]@f #2>|M4m9)N.4(.YI6a~a"a+uuyF̟_@x ~n֝f >7`K,[$qQ/89 {%1(>5A4Gn.*sᕐ`6ڴұ%ybIa҃u%>FuQms9O U_qFfJxjT$ɌBwIn.>Mqtl_~$ BKT #*ȦwzH :d7>ilXfdd4L=gAy-m6o'Z"1m7&-CpX gԷs7h7} fQs̜3E9dW žrn,sԊ= E-['Ft*!~B~r I6x.EFȬd0w>Wٺ\|0Iᥨ\+5yZ>pi[zrxWBs|@YEzϷ7/zw_"yZ)Lt{eC3 Ce < + /mRB6H6 Ey4{ eItͻ\E#\)#J 1e1B (oʴTg0I6c#a}Age9mHf>=0rl6/E%L-X6-!,z=l"f~j<3 EmyVaL//e)I!T,PdN1ps< &&6p!^*JO%@ 0[V9RJ"GSORRGbb r ''/);%d 0ަ_}#N_0 M[vi5%7[DS%bHQ0m^p(0\tUrγs`(~U)$y>M*=Oe,f)pE]'z<(op.b_,݂WiIYyi@[w2],+M9GIqm!HUID]oҿd*\M`B{׫Ȭ,Dea?VCGu~4A-d#G<sdsv8J%a3yݏTLa#-61?ѶbE2祼0{y@bW\E O|vڄhcm՛VSiZ!%V.sk-̠$ }L?\:1єj dv1]Kq{&t~ڔʦq׵)jo}Đ~=?5!TȎP2hٮ'A/r0f}BF|le* FF_W$ǗW`[YҀec_`P4Zkj=try J)tգi}͞UM[1KClZZG_8]9;S3͝m 5ܵF&C+~WVe{1RT_>Ń]-pЈªqQ6av]UPvz7%F u:'G՗s밖5fE؀HgISU)?EEӏ*M[y+Xt&e<&Qgs7yG|1(9)@ \.tsH& >`Wզu/q=*o MP)z61⟰7ջXib7-T.G"lGUV[r}tzgQ17%iۧDm% =Eca &zaaz]@ՁkzX@-v̰ThCҋa~,̇\[(}=4H?OIy3zzL*⎃<(6nVz=[X"®0vڈ@AYUqδ#ABϪiӹ,z8‰/!RL MEx& )Χ1 U*3cֻ&>TvƵ^7(endstream endobj 299 0 obj << /Filter /FlateDecode /Length 3035 >> stream xZYo~g#6O!( 2XJd@j)J6vIt|{\R€UjUuWg3?_<޷lvށ_gWoKX<|vz'n3n\Ym;/tƫ_)7'u;-sY5G\J Ϳê7g\؎qu;Ms!EJ5p c4wy' 6pNΙ_Gvd^r{k {m[XZd{#7rťG杲MVk: GpM&$=7)!͇BUMIOoQCP@R,v.ۃ_= R|6s ۏ.ИR><Kէ$d޽L LerѢ52~6ʋėTG՟ڪr *u&+-r b87;xs/,!ȧ^n}=BW%f/[j 9 ' y<}F9r^rWKڠ&-9,}'9_& ԭLyxf =<m^3$`TrHIE!Sf?x(^RJz LI38/|Vi5E; VE-čؙy\vLB6q>%g)]s.@p xn:   /|= C!nHv `!yU<M9I*VѵYTɁeats,j2M,uca#`bxhHi LpQeA u66 j\o"pR*GdLch\M,61'45IH΅JePIC$+yOWht@y@n~Oy\䎑L.2yɓLUL~+s 1{J e'bj{jEWۼ5 /r&5VQ"<9d1ŗ2nzVtJPF=`>%>FY{e},uc=~8n=nrS"&oD.`ոΙ@ Һ(B!br/ {b;,>p2k~('B] x\uBb$76&PA MG*9-X v(`[mxML`>ɝusP t6ͅ-L{10Ť-|Uރn? @M?_ Λh*C.Ihڸn sq=qN[mڢh))ff~~V0V(G",Ћ(_&^ 5kҀrp2Ii锫TklR}1 YJт: br#DR8+}34cP4Yᘘ  o2|#"y#l1&Hd.[,w£e$Aa&.=f^d᳐IJ=,1"3.(NΞm\w!GmI]\Aj;>3"Ͽ8r McT1XbT4׃cay.PU"6*w]S *~$=z2lGAqMRO8rS"XMpmK?4]%'mVPNq]+'ӯQƉO"۔bsLSN/mI\y֟62|6^St6n~n&7R/nOϴ>WzņZUͰݩ^`~g?-߸endstream endobj 300 0 obj << /Filter /FlateDecode /Length 3984 >> stream xr-[vfÎR%[r.ٖEV!ÊĘ\R 3T\eAn w؟梗s?.fbz3~Ca"錎yso}^:%ͰmRD8px8GD QN( \ $J\'а,ahDNz S$S(`Cwsy4=u"98/7xCmHa!>^' .F2bP$;;Z/勄[{|yYOUV$|i!QQUxQ4Niopr٠y g8/OYB@GR,[^&wjoJhP"?VVZ_MP@pmU/2" Bz8F#GcLt!Ox1=C! uϛio xYE˪6`LChlKZ,,f|<+?ب5U™`'(|p;;+G/uJW;aMݝ&+Rw%B;$\AcljCÁܟ$J@3Բy6ϣNO1^0Ixآ*nH3RUʩ@e )t%`BSd" <xSFB8`?ILEX:N~Ӕ727Ӝ>Ɖ%>-,nyNJqp^!9y7Q;|b`>e$D|~X*?we49PLQlX= +CPߣD$cWff}GG*!'U*e'{NLǖj7[İ{$ r1ǁiPsD[Cև;0JN _Uis{V$)Wߊ9]vN2ÉTMP =+PQJ( ׭ 7Tjٌ.jg5oUΌԚBikJ4cU»aNх/ebWBoSWwCy霁\D&CiPŒS*DJjty2 !?g$VuyJ@@ΓX|FWy*NZm~ix VŬ]BBە; p#1H?e;H7&KB케7M Cr5wpV yA iwD!kh mx. s견C, P0PQA̜L_@QG+ ;fq?[8F\8b 8pJ`lTeXb+IS y!3(˪nJ;vx*[6mc`nUe"g (=! jv?mLdm>R_N;g>nJ@6\>c;Î=DZB/<s{*D;%c ՛ 캹w]VOz* x>c؄+(?.쩥,};o'IѨledx*՛&G#gM60EV ͐|2 Nn-}]-%F1,T%,mv^.~2_DV'bYm?L?6 :~G1NU v!߼(jZ{-JUa-Fz^z08T~'2ҭ$DT-*WUr _Y] GfWǼtAvր3րl ;F U_K cb*`ꤚLoh5H CxKF)f&X ۽]49YN]`?m8.dpTMãEeE7mQjخif\H{+j(3uq顛OxcáE\t}Ys'X 3ш5`c'\U-fZhHi2Rڽ&3VFn!Mq/1P GQGPG~d'3|k9PV{ի< RN i􏦽L, +Uǒd~uzipԩL$$hހ>B ]Q6ꎉV=Quܶ_y 'pt[M"Dp[5S+#yj DhԿD"KH[ڋq5}Iu^&07q8tiSWG~ZG{b#<>嶩>wMԓChZ|j,?˿L%edmDXz&h+M=Tx2Dgn#g>aM1܎~W;mTvߚvGNĘkt2.OƐܓ>}Jìvdy&^riYUSڸSY;o*`Hɐ]oeE7Ͷ£~Ͽc1:endstream endobj 301 0 obj << /Filter /FlateDecode /Length 4954 >> stream x\[s$G~9=,`ر ivϑfdv̪꩖4ˆ#r*+/_^z?+y.۳/^yq=ξ?]*(/ҫ\Ҟ{WQ۳vt {hTb)V>hTz԰^0\-Zk?9|KOq/ʯT'A[7< jX_& ) fWV@8A(r@Cp렇oN"1z`ebtj3oʹ78̆H>^ *? a"hXBZ~l6kQ &&cj!P Yx7yBii<_j 茉oKJ?|9`ïi]7\֧uƋ:Tuasài sU:d+|Qwu:VYʒ?է:|[ݧ:w'}}z=d:ۛ.vu+b7ș49cKENtE֗>ѕM}Dq$]}m=:|J4 J-[KI’ӷu%}νJ*}\„>5]>ؗ>w_!3au5o⑻?Yt7$s_6Vͯ8=-wD-K sixSWuu(|$?cnU~J({y_O`+٫c #V`~뮺;{g|gL B4=ƧfULmw_kV,8A u_cWѿS=ؽ>vk{>RC托j]Gw=.{q]§ϝ ;R##ٽ2tdO {uy濬ÿF`zOy4t_8 /^&U"lGk?M^MJִR -ht/ zJ~[Dw0u:dOuN6\ōgW^:)g3`{_:˻ $NKk\ Y艬9J9ݢϥYieHfaqe, Rct ,fmK-6dPQz␉Vɐ?VpIo {||`ohg{ܱJrLb:0X&@ŤT!b*&Ƕ)&M{ pݎ ^N6h2ƔڋyK#/!-;PRhGa FR]^_]fT)ۖ2| #zG6%I:>;?t*+)). q9ۧSJ7Z0Z!﫝"0:Өq+ll3[jA=)[Uϓ6ZAN.#qϷ]2p2y@Ȏ^㒗pJq#I%Bd[v;i B˚BS_ܳl9+Pv7=C^2\-ePUXާ@'Sj0gH0HkTF# ]Z8 ҷ1Msux],݀*Fo h<1YpOM& ?k`8 V=01dԪj~ ާ݀㲺H^S[_cނg^iF 2H'#oOZ('?H"6c\wTԺQIRE>/! _XQATT(G/0O!=^xY_2w' P1F*XB%358K[3@"Qְ]Z5#<PC%0_Al,`JxHc,ƃx* 0*B $@A§ڮnW9I}6`øBqVo]!:r6̸O GhӖ_ &2m\-^$3%]dGXFB M]5Y]./~E06 /ݷTR:^>eG\Œ,KLcv$a6dyᩡb (>vR1!iVn%L Jh273de3Sfģ_ayS :MWpnʠ39@8ֲu4$\4 .aa#*J%FiCjmTgܤjdCﲼYn)( s'N@_x[IHFGx^ ~քkxhaS9Pc[[*Tt06$%K2`p8F?L[wp5HxH9t:8,10zK+ Ҋj>Ew#gly::ROw홤&-^tx0H?z=OkDtz@~Uw6-0-vH$tlz;9^0n暛CudΎ ֒hl67#9IȞr>Oa[ͦ$6*'0KUGg[g@Uȃ!E3vʌ lfZ*sS`Fh+'铁Uڜs=}6Ou~Y<0]'zȂ *9:b:[wo[a]c^1! l+ L [k&[–Hp;QL`@RuZ5=n pU/NI!nѵSW[lua]=3<S1؅YW2RsFHSc)qh$V>RB9Mje`9,ڬgǼƚI74`E7Mrℙ ʉV7U,UIS@KbKZZkY 8ri?*r cF!$ve"T+ lOˀ-sdGuY #xH;Lm7=LbT5Dekz2alW;o*l!X產ؤ/O*bĝzzܾNIZbgmWj>y֙4etK9̶ L_WMIŁv% Ĝ<$B[n]=vfGfꆬmcFgqnr\bok&˧jpE_E}B1-i5QC^mp+(zg_9xDehPX=qf[ G\xj~F<7VAtzfB:itcO4uHn%@"Z^Rk KR 5xMT Ԩ6s 4lտ%[,LMy,*&_PG-T Ԉ Q4ְe@u>[ڃgŬ3i-HVšb(¦vJKJ}Bm5bSS}Oў?NS|j~,P_M2zR|gs߮;OP7.*9d0#,{~HIC7= gR"5\$fDҘiû,%֘6$Kac"ܡUNC6L;cj˛Hwz ԣGVmz)qV ^&66֝`,.fa/kνZ?8(,'8&DZ3KN4?@E>i"IrHJR:jɂ} G*]Xq(5A33ϑ&S 6Z*;:V}%vbhJe\iЖO uLaQowPo3WkiX;_r`^NVG)h?Dbޙ #:Kty 4YD$['Wu Ltsn@ y%}TXO*qI. , #<~ xȵ\[AZӯ~Ă_Y +0`H1lS<[w߻jR0XY,6pƔI &:Rp\ ?fEf Ԑw#>$a~׫ EmS˲M^Cendstream endobj 302 0 obj << /Filter /FlateDecode /Length 6106 >> stream x\[s\7rN^fY/҃e%ڒ6SyaD"%%[F 0$7ڪ!h4\,\~gg=r#n 5678\d ?l9 EB* 56C8=\0A- ~LFӾ!@hYO)تVМN8w.9d`NTETp6PX?7P_oVµrLA(1ȕxލ͑|YLm a3_=>8jly{LJL'dt@cR%:%/` -Otс6sNfa:ub QsDWIVQ6ҦWczVGY;`. '):U:9%<3<aO\'J, j1hU:VdT:/I"t:WM;m"2|'bMTDT\P^7o_%V61X@JifB|2cx#`9>V<|3/k@%Awxbw0>hdHfne iNӭmXXNQ B7fT6u{;8 ڰoK3i&BM>1'S44  05;4֏ w?bȃe3YsAAPDn3hϕ5Iw> ;иeүzz\+oE:iX>=l;@ߕp[=d<Z  Yigo݀v6*(1_ƅ |h|8A,]9&MNAFeJ%XҐ;FKU*a{[} ٯ5y@}o @r#F:$xkM$5;ܑ~u1Jp 4dNb)ZZhDh-p# "*Uqɬ.Wrn#98KD⡽nqf7 0r}W5ueL$78U {B6eUN41-lɭ8s<-Psc+Zr~+ݴn^b f_|iDhA`z{bS)c<1_,ľ,ⸯckk`ڮGyܼ~^h@A+\4qgy=PӎfN@B]B(-:70#HCRƫ0+q@k`7~o OI'HpI;Ԛ4׽~pHT. kYys8#Y`ዖI/G1[aLn.+02n/'3,C81,lwFGtX^iҲXUIyUZ"K^^e-{*IR, ΢T+Ist-v%tzg A_k']E~v*o2gH43!e~[bo*iM U8_ە(>9uhϞ<8h_# ֪́o$kePrcj %$rGX^~$_ǫc_E!3=s2zaUy}+95I&I`m O@Y>&WT Ek!5<P@fϫ">clC- Iη.&v倘\fb,~&=&2)+‡CN [2K ߮)PȦMjO%eiQ %xGz[ژy9/d]'GG lӱ,b.>Z@-E~g/0_b_ɪll=P ]%6~x~XJ][#^?ڇ>ڱce,1XGYY8V`k0Ȟ}Kn)|S*H{! P0AT=q ѡM:C}dٺ1зuP{~Hޠļ6# BLr-v 9-bnI0~(- Rv;c.h ]TA”iL FǴ8Li8N&S)yw¥G96+v7n\2(d=ya!%~(Lyq@?]|9Ȍ 0KqK@4V m;}o3LX`͂-LghuS9ܕFrQaRP|aUqJpfӇH0 6>q\RJ|_lɞtzJ5ir"G^{ڟD>SMGĮئ3x/{s<;RNX';Mdq&z{+:CZw'+!bG$6@EE^0Rؑ!#{dp0uL)F\b_W<; fkg$1I.[f-2sRq]OE׭r`:M`d/m2Y' \Fk၊xÎ#b'52q5ߐ޼I+nQvѸtMQRX:u0̥G7N̓!MꠕK'*7jF aTS ŝMTiQjpÓeƷk"í"7msj,o6]3y`X/y2XB|R3|\fU5sU\Z&->|>ʝqwđ:ӕHn][` vup6`6V3f!赖wXU$zGByɨ呓P"Fؙ2"$+_DЉnIZ~9ó|g!scy<]w?j 91ny?}p*>Ûߟr6r1+PoXj-K;7߁3ylQd߯}e] NJGXdl~>Rӡ6)^ Y}i;:e+GYJyg_hn|3,}W^FzUyZT+pϠvss{X%5pVGkU*ݠ ےu3\2V@4S3| |D{A.z8 n5Qt[䩅,˯Nn^l5^پR CۈN4>8![8/%`*exYE,@~ezrʤ Ţڱ(oAZէ'RBERNfmϔ^1<.є\kkCߘM WsG!'aM)&[tUlR8M:| b]:|֮8}*Ş=({ }7?QnB0\onNr[ZІ74ށBlO++^Nt2/Jm漏I˴A.VU`$yTINI+^qjAx2:&34bgfl5nHed=Vi  yB{WZBˆ7gs7|7]D lY+#RHA`D8o~PWՙn exR8,"ep+GjX\'I V\c&eys;rbZH1c+|xp'>Y|⨝%,ֻh֮f@E+[MT<>tD er~ rzvRH&ێ$ˬ^d̰FxPoKAȹ_SسOLL#%y $FE.:kc$[#Daw"UE 2{[sG4Aa]IoU'tU3s=u(|݀ոd$Jo]smzTDɾD⎳SYy54h \;v`kY>6]]Mz(W̼6+/q;*;>>XgUua'.|0pM}p,[].>kǸžjpn)βƟ`o'\M0!1}x$WݓK|endstream endobj 303 0 obj << /Filter /FlateDecode /Length 3098 >> stream x[o G9|uViڸpmE|'j$;vϗ;=On<,j3 ѷ/-]l࿣x,X^t^H糓(qjxg'G_ +yu5Yc 2' Һl^K)7^Fh_絰 H687BjqvF*UIS.rpSՓ Y: {鄁Ið9S-6]:Y +aar{kHfѶOZj}{8:nK2p0<\Ϲ kmDbZXwZT) .n{ڣ014 %^%(G/5p'JɿLR|VK8ci pxe$ǖZ 0fg|T6#Q휯n (]!I;ˉB+>+\6Zy1;q5 ÖDdQBaD(8?VFH>V\:BH†ݒkrޱPߑ%~pF`^Qh;ƊFxl{(:1'l;<]=xc9sEEεrxrl"s rJO y0 @ $GAJfeM!M!e!I 8)t!*6LLA&>2QHG 1qdDOR)$ !$Bďl#-&' $i0پtCة)9;C.W#TxSCI^zhkdx詑ǐ\Xd4@wO(ޤ)RBQi$$0Fڄ,T6>FG(c+ ρǔ!&1F$tSQLW6' D͋ #d*`1 9\b ԒNNF6I =R 裢eO Mqv/N`yKk2Xq[ Xtloٸ\(fL-,4he) F\GTf-(H.oPuwtև tye(9#y;e.Wejr cBTlUgD | rɻ%o/pb2S" !b;~,BLgܒKu쳦p\\36t1U{ҧeG:e2C7Zg789J09!pm'A4{2|ř_FhًQ&nNS,m$UwKiwVGs?cc/NkGsLY{u4b󤐨Per{W2GBIwSttIn9v$¡SH9jd6Ak$Hސߊ| E1t^pk$C~K>&0C5FŽ3Hb=gy}_m1҉Aвg gvH:8Ipv{a%Ɗ;çCb:O>ҾNQ\ЋVNIG:{M :'h8/& M~(Cys1@d|nT=o Bw<#7'i9TzVH{qNJyuJI#ב)o^rH#14L4ޚNwv1煼, (]$lH-ɻ&'Ю9% \!|*hPYWCtc%Ě}rM5Qz놝CU ;?D-$]LdMkD߾ry]_x 2*bt X3. ÚLld`\b{_)C3Jj:y76VtxI "t [N#k+Ǩ&7Xgl(صk!xc q7F)%!ݼ;uז[|uP=5Bxv7kmmfZ`ʹ+! /hc@Y:Lr]ikBuĖnqsoJ=:ʒ^6@r`ҁq/ 7^Q= Wş~^7RvW"q:/]ڣk9vI$@d=5:'<OsAtGhét 7*i\C\vGujAmB%ui=y*l+Qf3|ZSrJڗI.ܲT5P-&[d6[S1!Wj7_>Gj Y8ڻ[ O|gYJo8wM(GoBJ5( (mÃ2Gciij#j[}ݫ(1UZ]&b>v"p?('wQ>A7KG׭Bn[.ߓ0 p0PZ6r=sӠЃwA-VwzPN0 #^CkGWDPuq!_/Y|S tUx +Akd:CB gc|bHjq =F-]@-1H~8885zLq>Gm_M[[=Н1=`j;r5pi+GzSkߐs /Mtltendstream endobj 304 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3952 >> stream xW TSך>1sEz i>j*z  & /MBAPADuU봵vN[lg zw^%5u ܂6:ǽ0{8zD}j 3јDaR|/Y JM˒''(,50p"KMc)ŊIXA$JYW%(ioR\,NN_*_`2Q*IJbץ(%γ-v&e($rͩy EQsRRd`EƆJqftVLvI\|Bhb؎pių(j+NRaj>NRR[.*MMޡ^Qzj ~OFm^6S[djI)YT8%O SWMt}$ӯҽ[L3}濧66g3i^o{z}˩= y֙hwڂj_xvo:RRzX߬; 'N{Fs}9h AЙګKvbؿ./ @*7)}P[[n *ypF[huD}7\&Jd{y߽{g烱`{SX(IGo(O4M/f.ʈB{^./zy!y=7Q>7=`^5$aK{ߛ5 OȽ/#8 YP&/N M 7\굡;Ȯ~p7Nס,߄!PKk9ΤfśB'i<7p<Ӎqh?qFI6![-PY%mQ?G?po`((@AP)**-Ie}T/kH6۲L0 o쫳BQ[]Lgst6VtMjS]U@J|Җ.J<_^VV3"f\/@i0P,p|7OX:jZ]T*X}?N~E|wo.jLK0cCWV]: vB, )nvEAh="FԍB|/k>_WFUwx;ЊޯW|t:\).OPȿƝ4zCqBKpz4>~=|$D]4aʚGLsh%tƠegK*BB@<Щ/9a㝩[!@Mn:fDУ5.xppL<ls!V~ hx6:^SR( +. y]~6rz9Vw^ jM50}L_HxWaz096k ohomq(@*HuzתNMc.ȠP)WUُΟB_mW:ƨ5p$1;j@ Ru+7rPw3F!I+Ek3b@ 2hq"TWj&Rg;[$[ +'ב&"[UPQh3T*aߟJPa42N*{Q^k{nW.}*qg 0O̟OA`W|cI޷w_ϩO\-$4Wϙ@G^k:|ls:\\BQ͚b"UYUoTbjML5b'W|zж1!۹!Ckk 0 tB7tk'S^n#dqttY6gb*OגEzn3\c 2`rV7@dY{&q%TԙzFfOwo$[S- Q k% hfv}RQ{EĒ.<״=m!6|)U+[ZUg:zhF+'YS>}2vC:!a:2򬜴6E6p+MM~:I-'ggHP\UQ߷.#wQ܋re0eGGkw.Ͻ䏽0{DhVD(5٥Bź0Y0OhjN vt|n.75CØ ![S+{MGT}Pc"(-UP؋3 Ern%"ܝ=(̌! c 5 W88pMRZd*>b˪μI {/,lj&F?DŽ~:5>RM,ckՐIJ'Za{Fg'<ND\ͽ*8,iGݐ I=R$-VҖ3dmUs$j<?}~<ȃBuIV8w&@Ms`D{5ŷ0:&S%[y?MGn#'FMQXXN25gYmMG%wmӫA@W=8چ6} xܫ= f9!`|HjO~x0B UMf{}9O֓((xUDW|CHIMHHleE^Bs3W3ߋz"TIPOδ4T u̽rv)f4ZD-XPWECx5ۍ+Ny{k΍5žY /?! _Hԝ-݃ 폂ף#?J8Vֱ9Zdl{)-M cKP$[m'VB7۝CB"orShoEkC!VXT^F⎖).1ݸ}&;֜k5u.tɪoGgtkrr<%ْH-܋*XQ)=/?SWWi0 zJ6$oEG2Ư܅h26.8vL2]8mgWgPIhendstream endobj 305 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2986 >> stream xV PS1抠>r/U렢R큸.{!a A*QQC-ni:>;㛾PB7fdr+ l\q<˿ ;A{½8e`gsaG(nv ,JT R::I&:N7o y`Wae 2bi111S}ã&:;+D(eJ5M]*P)r eER'>NN#Ob-@l$obp#K)VbXA$fY;1 B!=1p 468.(HA_ M6Km.DۤxXO,VleÐiCLvc$vWWsCj0&wf, |LJ0 ?f1(АZ(c㮝M1NJp4j-Bʼn2rjҀS$_ ]6 Ι/as,¢)N;PN)[U-7dL5:/zlZ Lk){j s j>V]{p傹)b2B3mU0PeG77Js^u q?r9vSkv&'\@ҪKE%|udYvm~$cxdP[kH4?,@(n˹d!à K4e RM/B %K|T&p=6iŠ 5zm)%y 6>j?Bq:$8kF*Ey;nKdqcv%ud/}`"dz[p1wA#PIPGC~,z%DKbw@:Pk[;^FZǐF4^JDZX&ʩ˿Izs緕D"<E2!А>%ػSȨYno W@ƀK{#m9I%+v-ͳJh]qvdc |D2qb`1&InSf!7kVi>TS rg0I'%a+4ZarpZ /Ժ3W;Wd^VIn~Qx8x"NW47aMQ׎K#Nob{=wP-!7pQ4;[ ٨dXs<=KG Wm{/ռ" ,8x9>IT{ɎJJw

3R󦰙7ف{44:K=ũH<ˋAí&nm+5`p@YyGDj@63l-~LFNI/^!)}5X%R}*b2DNj5ךCP^+J|{5IVٖ͔`,EbB[P7޼}Sy 9w.j#gd?HE/3]zB2929Gs~Q򟑋|O&~nUOh;UWET^}rκY3`,u̹c]X\-@ |%B4\N|O4UJBaj^ՆWvHo Kٛ4&/~O_Ugsr;~ز(M4[J?S(uJCAeQ.34[-)"qldkv_ _endstream endobj 306 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 627 >> stream xQHSa߳tmP*@[DF &3,höhlg0*+= I. #ꪰ#s0nfA|ߢ=JƘw^m?݉SjzQ9Ũ; TU8#ho,ʤBlFa)E'O F{BOe՚L&|xC48n'ɐ$).$?qF#2i%ZtDý Yw/"!l?BhEVԈd2!:F ѻ&Xeѕ{> stream xZYo7~##,ɗwH.gWגFfCrLK6Ol1z3_0R:xz2[زQtB#⵪J9ޓwńRݿ_=H֎5ܔqCYu,d^(Ur*4N8Ir8@oN8' ;Z3ƬdU'I4-)P ;(&B8C.(c\y RiLZ)MZW?KW9g '^,yS*;Qxfwyޣ7L $d8k!Pګjma%O\u:Ț0Jx"7Z8ΊuCN@sZJ `^M7,]"*G%Xʶmj5|چl?JjvFsT*5G#;:9Iy¼h R:%6\  =YO n__.ٷl;U[Qd2xޭ6A)af &M?\b٣=VQc%xȠ:ˀ.GYd:꼨TK䠰B:H=,^l췱/v|F4gK ^-ww0i1?5ZнUbC =i_1sRTM[Avu[ta|OspubOu4qQ|o><N}?]s㼸yVޏn_` G q|GΝ}x> 0y` |߉yΨ' 'sfw;s?UiKaߣ~Doč3aq)? $ݫdZeȴZXA 9n:V UHNQ4Nw>*zm%"I LIafǛkA4ĝq σeTEV[*z>58VqxR$RظZ,tfQ@y72jwW_KftCsͲJ)m΋Щv3ӳ!uZޖssTu[l9=k..:–i2\ϸυ afn jLP ^j8?9>endstream endobj 308 0 obj << /Filter /FlateDecode /Length 163 >> stream x]O0 PЅjqP(_Ct;,ֳ ":ր#MEY' ݕ`.=S*endstream endobj 309 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 305 >> stream xcd`ab`ddds T~H3a!}ُì<<,  ={ #c^qSs~AeQfzFFcnjQfrbobIFjnb ZRaQRR`_^^[_nPYZZTWvt-(-I-ROI-+(Me```4``b`bddq}˖? 3}< 3'uOX0?!].S;6vvuO4xOl妳ɽs.20Vmendstream endobj 310 0 obj << /Filter /FlateDecode /Length 2606 >> stream xr#6>Cb%' rsX.)c).icl.bd:*m4Ϙ]^|۳:xïj#J㳣wq+Y>u9gGW O HNr`u1fز":cъS\b i+Tsj &M8;cکDNcrrI:s7a'ggsέͪ\ϭ䀡$F*)^s)E׻wkeͭ3ls R]p?\{\\ߋml 1nWOx?9'W@9Ýr "naadRd Lݢb6HSҖuR$V5l.ug\5 i x\Hܻ^*G0ruͻ/3l"e]Ėe';-%IwAR8/$5 ~?\vZ9V3rUY}UV1–#yvqլ}wpt4r q;rUY}UVm A"^ '\Kҟo0K28ǫcguᝮaJ:J>6f, !Jɚ8xs~[pI4!dILº]/ߛ_Q[CpOSwG]Y -  GFyi ,\2)y;.ӶFYӜJI|"9'=@Ai%8ᄴD|T@SB< v &Qn&v;3Qzc{FiJG锼-½N"8(**Zf*gR}A uB-҂ L,aRFQݝ l=Y5zbX:ؗZI_9TKEظoɾb=Ϗ9l)~@'բ.YW N*6lU#1/{D2DiEVxgĉ 55R"Y"E 1yZkleUM7Kغkq> ""8`+0kEz$J?tX*QE8#C,Kⷪ*9I4VHmW)$l?jR?CtRWv"~R@Dd~d 9TχМ%ܥgэgzFJ͆ec_xd, Q Z0Xw)|Zt}1brDVLvuLu  T/ǩ5e9Qktke, m_FS0UY%ZdؑcM,Z`wQeƸ=;dxjcuD6=Q TNjȺ\V`h=1Qi96NXauv d|'D}锷A:]<>ݳ 1_>}ڇr6|'Rc{vDF^s~IxHJ)o; o}sw~7$+fendstream endobj 311 0 obj << /Filter /FlateDecode /Length 2282 >> stream x[[o~ ҇.#/I\-R.>8.@SHdR=眽,=*R`x29˹ ?Y,^FZ6>ٌFG-G|j[xdz(j2)!$y!9]v1ƌ?[-լ0Za Ņ拉0vBeg 'QbL{UXA?yY3fs]v9 2";D $0Nr)Ea=ql5XƔN]S*4)a~.{kEv08y10<@ĸav |\Zaɞw^Gu*<6yWR]01%wRh2)&[݆K'V(岜;]0+ǹԅ3D LpWx'4d@3Ⱦn>ɵ S @8u_פ5k|vȜdЯbmH$9|6r$YcX*ON:ױ5([R=iFs4Zv7xw6:?cBW+pZ(ρH@ȸnɜG^OAWvvaFŸRSV% j!V_mҲz kIIr mmޗ%\|+)j8-`"n)jud )W7n~H$3)ى@䙁T@䩁lh#`oQts05O#gYbt5^.|uaaվ]?kg_@~$ȟդs/{_eҏ=g]E<)L s8t ,r\YC7G;~~.k\lZ:0/{ D\]t.fly%0Fykzd( zmR@$l-m9 b4#`C~R&I.J7CQG$wKcr'Y(iP4kmdqa1,%ZϋgsSŰԗw%[<V^s8r2jP06W<5ɥl--.Pw4uLݒ;TWX*SH_3+@ۋHHχGb`Lx0.,QZ8q* lqe+ΌD߶WVҒY+ E;*+x ds)!ˋ8Qn:z˙8pM_R[*{yl K2*碘%IEG&NC`_N˘?+O&acdASz@1].k x6(G ˚(2'&7xp[[c 9)]؏y9ܐHI}oi&u~hŰXۓD:՛ nN2%)|J ("OghC h[*g'DQ97Ώs #)dyro2>lOSYH; GjBlnڧ;OVbklКu_Vh$,2qF>T/o谶K:b Ȭ=WLzR5E,t.C'n#RO[^6#?ß|Cendstream endobj 312 0 obj << /Filter /FlateDecode /Length 10939 >> stream xKdq+zY#xJ~ƀmؖ@  _8Dޛ5]dC0A::o|FFDp?zo>{f"|_ZMraƇ~GClZc}_g/_?[ݳr}L/>ǬA{},>.<sJ[ԯ!ȵ]>aOs-ry˗PKP(B^//Q 텿yf/y qsv3#_yj֒K=YVxj7Žry(q6i,1a/Wq󑭊Xnoz9dst0qsmge{a#/SѨ6/?~vx7/ VNC^C,XE6EFlaк1͍]`e#ca0 i*ذ^L@-eHZ R6>}`AIFUc/Eφ-_*))-}h'$tWS$6T%iT7̰OVwWuַ0H5evFtQ2-I-a1!kƇ \} eʹE5e*N훦ʡ J{5=5m8jZn|́wjal\;^N=R de T-AcubsCbE|@Ixv$l8IvVu7h-zj=pBPRqN;cv騼͟pRIXJI+)3HlP+1$RR9)tQ8&iR&j!AAmg20? eWb"$i)eKë}1⒁6cV, ,.$ 3_Tƶ$TICIGld@  0Ll&V)ʪ2fU,}3>hhrٚ8)el]PtcH$6W]W|S&,ef O#jfQ2)+vS2i4b0SVF zZ=al~4%x$PƢ#` M 9˪Af5gDA'&գVLɔ&lSn*d˝z GV1[U&T@QA#p& goFL)lSLy>il-ႥM.Lmi*$XuѩnEa؂ .GI a_8xD^{ e<fv[8xgEkG((PDzФd򦒂UvW%ZpHRC Ŝ.ef1e# تxT`6R,~ފz9gÎ>tB SGC7`l7a%!aG o0zdd?T`VD NQŒŒ0H:g|z}Htn Vj(+,:C^H qms/tO} LADܐ6}j<(l hy Zu?wt #7'd騞d?"V *'p-֩|O0ɔM~_w` {5z\bFc^vg͌$ʙժjtl. ]j,Me./:[eQ%5fE2 =j\Wn'}-y3bA+k v̨lkN$(TOO^dÊ+/ 6靛d@2YSpk3W ILn 7O*V4P"zUu k*0mI<3c4wz*Ml:{(%^H}[YvT~rM[шu{"IdM -I(w֠.!IY0kΜ|լN\'+34+-(֊l-<(4Z Tlg-T]5j3Vv,w %(3lB7(t[JĥaWI[`rg+$ViC ÐDk9[&jٝ4J\N8|>-+(zĕϗ!GeNy#qxVCr,tB˂> q>[!WTgC>ɀ9} oB߂ -g`\ !9S?[_[)$Ʋrmij$7s/咽3@=K-m)0R+~o7VX5ev\ /f?ʟacMܛcrٖ༲9{Kt|{3KD3o\k:~{34󆠉9Ks o ,3*N D8A"!Ah-A0 @4RHlT,B,p%CSN$cCSajpNdh*Nei;CSj YCS@p ME4 <Н__ eddBMs ܛxh8y jvPhbY󋢉26&vϸ>(8FMCJER꫅hRORۋE4hi{}a4 CT0 Cn"jم4^!IIјd8(MCipHI]MWLјį?G%+fs4 ! ptGuFٓ H/;#F;Hg]̎@{9H4kQp /4si,4pŴ-&Z,a|4H,48 Cq8gEt|DBm%2R'D(MPhȉrrE ME`s1"i(sOi8IS{HS Gc]ÆCqԤd F"@M@&h0@A^whx4?lM_M 0q%q!Zle%%X]il/ #HqtE BkؾE4]N4dfH4UN4Vc2tL|;J#`%4|JXە(MCFiI.ƫ1M 4 iH;Jc!*Q* i:Gih8O"NLGijq E(MJØr7y\Gi"#ߠ4L( 3d Gi4P.P"PܾPX=|4Q~߫cBi\)iw"D;QLJX6DiXQ-$i#l8i(pF4F(4g`< QhVId'iRd -V]ԭ!9K-szk!JQl\QmV^pz-g@MeJU܀[4YK{%Aelםqm^{n+佔KnJ%9[)ܖRRgQlښ ʩ0twqG iՓG}MC n]߼{$.koFo1PXMa7}爽aE i:xOǫ,΅ޠBz^Л4 ;ĹK0Z.F%.0IO9{ΈFXMj1 #SNoe 8{Qbop vQ\-_ 85Mj6{C>:3]{\ W-{CD7fYϺwqGGtAOձ.Jޜ}PiAFov<A76: Qq#z74 ?MEfpr}k/eq׵􈼡Yguɛ<ÃaKu- "E9Ёo)7':htQapPf74J87Ϥ4!7MC97MCF <7t\ێ0$tw]OޘboIY,fJT^Go d-E QI{u7WN8xsxx&s7k/:#&uH_ R oR*qNMl1ž4oyX<7h,0.S"{c?53>xR7v Q*NЏVp!Ao zJ ]7t\$oMEӅ m*UZ_G +`o o7]坽uV7ڝAsޮ#J_MZy*G-#*"9 U% ح[M7?M yLA!N _E8yxzgg7$븉\x\s"Z4_#OЛ[ %eGo nPs7 flS>wCEi_-^ Sb35nY $b[B_P zZnϣt9JyLxru7Q7ȇrh7w Հjx&2C#NC s4{Z NTF G[ gDic 5fe#&hD /~ŕiqk,솒)D؍$bXPH:vPnlŰ8vWsV`gis$37pʄ Ǚ,m7@-戸 c?7, iz@sS%m`q}vXq&-wa7gg!7TOwެ Gn4ƅ8rYGw^lRp!72*$ qCG'7H8rU/#7U`[o^\ %L|˛z_7ߏ d~ۃ#}yѼY/$d5[???nޞ?=?~x~QV-5?50m#앟={_r~Tl 6[g?9?]ҟҟz~G6oΏ_O{}|{ q>G oo7s F^+w~n K&Vuvg~g׼t?mkq>*=>~̂/2p@ez(D w3_>G_>GnT\{t7տ\嫑/Me[tAz(Mn*w̶nWhom}o۞ On'-/k OϏf |~WSҏϏoΏ+ |T٭s;fmӫ3ppm|i{{8x﷛?|tw~^ɓ[-ow]\& ʶg?;&tWw?{Jx{WǻC~K vzJ/pľzOOW[[HAKVfdnV4:n>@>?:NmG'u;i>v?-hټk)~ J=N%?=?no4ؾzھ[Ԗj۷<`=\V?gQ~M?כendstream endobj 313 0 obj << /Filter /FlateDecode /Length 1785 >> stream xZKoG n3Eshmi"ŒHkrfW"wEy#m13q8N>E!"{ޖ_=~ۯ/" ^{/mYmy/n00Yh)|0go(…?Fn- \s0Rl\a2_k %F(aY*HQC02K_J!Jw.gWYQ Egw-hg?(4Z rUQ2}u!"J(0>^%7&lV?]F^BY" `^b s!DB* !Ҭi|Q\\ނG yɮh`llJk$0t0>>a(՟,*UFnbϵ-sU 4 YHCtIOš={`%8J9r0jI.&A"x?"y7#§~]#>S7 o))#B+?GэST<{R7 y̒ }1K.vs;%JH0J:q-c/p6x\o)U7:#`%- E˛b2 p;ϐ< F?i)a#$lI˛ FrۡSI1H~ĜdC_i9屮(,? };;Ca^t¼cw,ظv&|~Wl:[>yK|h3 7\K0Iqccig\'6*ƝMv͵OX\v媉S6)##y%V5['ΘF%1tqF O\)+n71l5Ǭ;n\jPjͫԬyh@yn[:ŷ2{P6j?0>tjnUsuPc/u[ UUt@FN kA6R\hBKFP^"Y⤃f kF[l&mHBu77H~ ~ˢLzKVIri/XY#Kkdx^!ͣufm{&C?ž,Ch^,> stream x[onX},snD8 |" ~T͸ƻ6&篺g?LD-'"+;agÖLN~܉3rsʉ6uvsUI?yad`gU= !\x4=֢v.v˩jj#US+SZ[+]5?:6RvF;|*jtFViƥ>j19:Aէ0h64Z=δVuSk>FWǰS]L;i(Wgq iTuiW?Ms䝁TNd?NldG"#OKS&Qaet2% uq0ټ' h0ʒeVZ|k&-HL; 0oH6/ع;H>A93z]G!Nx]a}v|ЮE?S=Y7aNx?\ ɵ̶ٹfb C%Ft]f* XF2;ϔ mrFρ!]ms1$ b7+ԁ)`ѻ/RF &Q\Е_rx\D-D=Mz5Q(g9a$QHQ*YHl %N"sB Y]9AJc>4Ax%y4Yye¢Y'65|xԳ37+8uvPZROmjL5YOJMJRI{ = O=^oh%ɄߜzC !ψM4s[wOܔ\ ƤJh~;X& {wI΀^֍_kLAAMe3~d+lfHɄflVA,e͋a8%Qk{TS9RkaSts~"))e2q1qsH`M.^\Y}Ę{ % $<@ƒp>ιOR@ OQK`ۤ9!Y8ǔ!l兺. s!p}6ȿUd`c,p۞d-AjEWjz0[E/abmY!>Bd L1/@\Wi;YL\ZM=o %i. HC0 U$-2"?r.K'uE'12W(s'4 Vz)Uq'vcAE]2<ڹ%p"=**6Ip:8jkl&ӊu$!HDߑ:!֊LK̉ $Q~Fz@Ad=Fa/RS ;ƨ~G:@n3 d:CpZk!N= ~P-h0@>  @&DàS򪎑|G9ta6耙M ұPnOa/+\=z^D7 5Pj/n  (q lLmŇ=ye{S6;esRM./2`cU;U`"mLYYNFɕ d+ 4^JKg[[f*:vh/(!S.A 4#MaLY}>V%::Uz~@:=TnG\ enHnh05A{fG2=m/3&48/;mޣ/FlcqPN;$V ַ[_wprg]3m<WpU4ك`R2{W=gr~Bb(TKM{piXh[lQk> enۗPFdWE7Ϙ('jpKB:.izen;w)=o/㽹KsL_χ-1e$9.e$݆Сw ,o 4P'>ү>Gûk@4n=s҂ݾ Bkar 1no ~p~ؖTZY9FZo-j~]E' O b"Ist h$W d.i r/p]Ω!+<+$IǪ4d)Lt g\^:Rt)WTT`yi@KT5ĺ—4^T'',3<_s|kPovԎ|E]#ߌ颵њpn 7x $k$$ W@e Gyuړ޷1n7JtbyWNU̷$KߩMxݩM̍mnDɻ&.5ߩMx]gtr5 eW:J@>\F|K$?j'j9ÿg1k'~5:U󺾫(;MmyؿlAHT=\d%=1f_>uq'SSy@> stream x[Ys~gGTyXf?DQ8 T*<$K 0>=n.AUDs;|0S?.~w~}8I8<G0Fd<*'҅J;ַQ/S;h*eDcyFA5+ ڇb:Z_.:ecΔoT21VǠkCDj@1U" C +i fd:(B.Ӱ1,6]ݼ*$轂9oզY/u'FQ=N!4 SHKMH:o6m0J(UͧbB% 5tFVd%Š)8/=>ijnžqļg/8@rz3cg8cH{CpZUUm놝IxY+.{Wem+$1hh $? y]%.1ܰ Q 5; f+${ۼdm% $H}͎|nG5[BghPSfD8;v-¤C~xlK|9K(tζǏC7 X-1;6_!*ѵ_#wӅ]Cs>ݶZj_uڪ>>>j9  ;jyߴcycHPj;A?i{H|\>Tǃ<$y-Jõ|jS']\:7z b>!6Vd tRHڥ&2ΔXN#":% Yz4L)(3xhA)Ebr5h*[ 8DYu׉b'iFi ^O5OX:Ն dq2Qh!'KQY1ӹPG' pQgF8h"FE@/)'\/Bu{ی ]c MC刊`/i%j⼺6t~"XaCܑ(dmX3{@c%C8. ޛ*y=&mi OF5/)^KPMU:yS`A`|U, iAxfMZ:?&A 5Lެ;h$f vC F-hUtΚmTn\/I" SڔvYZrj EtjNfP2Hj "[OɁ NIhu%.+@02.w$%X. r}\J7ܹ$֓3|k?_I=F[!I%DX-Sg ;f7L5~.ul*b Q׬NH]U+V0HD}IU,s>BIӴ)f맰K W}ziPb%G5)3S}"aZF e%5ݡXJ=817,z?Z`agĆ=W #ly1koU/ 13f8J2ތJY|C>8aH=I{Hk{vlؔy\'夨g.{'"@r97HnB{\m".)ro5!щC" `1dK\5^1؇yk6.hh(&.) z;D^JI?!QşKRR?ϥ+5 PWa!\Qte.d핥21K[dI/5\~(S8Y`=~t4NʂѽAO7l J- nu6pYa0Rվ„䥼daۨt^s2zîGIMNg!5/|yG6C%?u2y=PtO\1}]xӻ^l`WOLp%(az{U#F(̭4dT&3 暦c̕6..z:%, B: Gk~vx[9$hf>(27'$ɗ@ɷ$ ķ-| J@\ 86c_8mSmh'C !j:XGa ۓ'@{ʮ :F-#oW؃"S?pZ,B2~1?;Yfendstream endobj 316 0 obj << /Filter /FlateDecode /Length 2058 >> stream xZYoG ~ׯJھ(дEA|ղXvr᮸;i 3HΊz3f5'={el;FoF<~:,?΀K8=|<;GWkVK=]_' 5+yLYm2'5[i]u2J)#}L<0Zz'ny#'@kgRuT˜r3͝jt€p,wTmbNV/'€%,(%[+@20;տjͪ{8Zn8Kx8wVu>us$H,7)!N] ` p7n{ųQf14 %aqꥆ9 -G?b SkgL`=!u}!o  .伐'-d͘%)5)vWIpZ+/ƳF'GЖ Ӛ"jbȇBcVkwQHĖ<`/ U y]NZOZ+L33Y0kV4yQBقvG|H(Ӈ$F*[u+8ϧRA#wizz0Ju ؗ?%|^1p^r]ȳ&Ļ!ssE2?.+oB:~KttB8m hSҫkA';='Ѓ;SU| N9i9E1<'l:#Ҽ˾BC唾\ §F12N5nWsT?^w]_~jOџb@1ƤBQa1 T}h>WL,2K&hxK֤}s\Eaeɟ »KӚ{7TؔQ6[LЗb 3op)4y^(;X%X-UXbwuEYyva_HF4wbcue'$ӮVciD(o'59'AaI9N a[o,oemf"G-a0З’q\|JVh 8ۅe$ϑ>UdĠh*b8pS҇`s e[we*\ix;DZA%ל<J>6ȼEr_['#-M0M St .K#|[xotFk4}mN3wTF괒 *HKAu:7R%$fUzyA@,%,ne$$cqxEeIt:%Щ4S)"T]?Lܪ$|U~S1tN/3\+ޣ"3azxS ˮcj˕~¤usnYdB,C0B#apI(tPB0mըjD)r%ȂѨ&dh~BAt> stream x\mo] nG\vjXt[;t50 i?8M$MHIGlвDR#xFr#O'^l.n௣_dsv)2F( 71j9:ٞ:C'9QKaÓşOuZE9VHVeln]@vFMag);#]|+FuFi‹0RðQ@5\6ûh:&y zQ9x!L^\%M0fxV_{5\ 3 ʅ[uN'`"!ٵ/d Jba Xn6Nj?=lLx1)UqBFVMTH`Eƺ[W a RR1/ kx=AM#^`g zxPD m-O[TI;'hn1;6Fg}qtV$#Ǽ O e٦}cB(&;aJ ^%W umk89Ϙ!RR`mƍ),h]t0wa\Z%y\7MiK=bL8Ni5ߌňkoi_tstRIӔM!C[\k2@3g0vN0b|Ll"%}>E 訲.^qVwL-U' ɒkwYuY"Tޔ_t>p[r݁zvpFa8%iSqiS?ͩj\Z @}q1x{g[1{x Gna_ܯOrpF|YJv&  'J)vz5ᎈ<-:+tc*.wy?MUڃh~TRQ3tO|r"=b3݈ IѤ8irLo׮W7\ݤ<)}u bY>*5^;WG0>+hОq z)Wu 8YCy"қa-&7 n;n8KS`^ط'h`w #ҋf,$ߢRy As4Cw[/Oݳ\Cxto]ɹ䁞֥g].bӁ:ܬ؋x ?F,AN$>$/l߮zVєv72hBcY%F'츧.B-씉fGntJ'^3ud_gǍ$t@Q1'qGD,7^ |̆Of 䉖l+؇J_o iz_Y=̒ _VmsRUbb68,m.VewrRjƘ]"[}rYij)\03H\I^k[}{'[9Wu|Zz׼F`!.(KЪvZg@-fe)}.CP?ȸ&Lv)[*_TUũ徱jjVչtTKث"ɇ9X '3l%&e>b]9ٳ:Vr4k9-$w^N9L)ɡ/gI xD̼Țayߜp?Ϡ?B>B6J#X ~ WaRp/BW3-YxP^фuEݍ\(S% d?bdL|λS~$_FZW56~&Z(0ǣ'г}qfJyITI I"tvt}}Aot,uG3mIlLwG?zke <] <~dp'd%YJ+έ[kUw tP윘\d&uihV 8.^ qۍ7Gn~![? 4uG\0t=€j&XpκzH{F^Q m)e#6=սILejeWiĒvF`i5.ˍc3K0Ea2:8-,KHM;~x9L﹫!aҙ+CRGZm}L$>P&S~! VnGgJԝ+ `E}H|=<'YӅ ?@^?J:ErBrb)rFCZǍX|r2}jǍd>,I [X~s̼3bFY Y;ET/>VQ5ͯpQxmHYp),ˣZl ѓfЯe/xV.G߆wΤSO!**@U~&Z-$["uyQR0\ )_[M/ GL]'Bc wLv)db>&L H{9͛W*2jƑ"ݨ/|/0xǩrxR>_"1@&22|*ꪮ߮;þ2uxSJgEMw5#_X*e [T 3V_ؙa2wh+m]985rخR.{X81Q*վ aendstream endobj 318 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 239 >> stream xcd`ab`dd v 144qT~H3ae<9 0012*9)槤)TeDsJRST000030d'gb&,|A~2www4ttŷǷŷIt5w6u7sTj-6N߃$z'N.`QR9@8Ӕ~Odϵ[y='Z;endstream endobj 319 0 obj << /Filter /FlateDecode /Length 8294 >> stream x͜kq gOy'ld1^)'ƚVF#kC{޷mivVR5l^Ū"ú>~^>{GNz<>S(,mm#};TgOʨ4Unn nmx:;_knWN^s/Njgg>/xYJ_C>^bsq]S\͍/em[ײȝs͙[VW7gF c{G1CKi\:e e]c=D6b~uSk 60z:L9*Zwݨ|=jKlTbĈzxm'b`URKv"IyɔتR((H_`6yPI%keHr]a"A_2沦%}J;Al9wY^1A6Rp(1qy WN(IJ Z$#I]bRITIŚh ڡS_6s*II%mYJJHٴտHJb-$W$C$\T[X%STVopQQ0iGA%mK*Qcj0U^ZnUI4[G2b!dP785 prp`zJ3#hInQI[[Nv&6IxM15g]$+ΰ*,~]F!(j))"YmF $H O& m|ERJH_$75.jM8 8`"pNlar!`Qk(M&6Oș " OkwDPu25u=} lV!aL܄xݞXkPAm9.<9+؛HRT]b9ѨDf˴( `bDP11 "%YhoY*ݫaUVyG5>UL^"[o{TDlUage)c'e̥2D'<m־2CTPһ"c}$;/O kIM,X8[HnEZNNf"7G=J`)ѥIi ;$+KTZvb$!:'syDiѠOU4MN!H I`(:2,A'Ts>c#=6BE&AH]6AM \= {\m̿4mH3G6jkaPSAreHmm l@ii r*/jxKB7dxn;9F{X$wu0S9@;LoUR%4EU `|k*I21 QGQKhH7?)z/QO@Iv52>8aX*5yb&TR%@RmW]Ѫu`LGSw#tŠsM(̡aG"t’JKLf+&Ehb3rS6IEH̒!6lxlWX!aRg]2DS;VhmݭzM&"GG- ҍR%LiZf "*Ar ]%&R4((EBuz@qb򥭺\ t)Q'0a.0 X%%D]H+01*K*ġdUWWQSK}M$s7IH F{3u F C!&.Q:!245vڤIЉF̞N0W]O*fI"h&HI"\37 CU#ueftԥ(-hd{"yX1F ^JT ې4 ұX >[FƢVix}aM{ϒex| iUdâ"a0ECUM0Jǵ'Ҋ%:** }DHfO 26~0Kvdf(8DY6XR̬HH#6$*>% 湪:M]L֮nI*D7 6Ik&XsDE >h@oQƚ̧Em3$Fo)# \02jgԴ QJY(%hAv@RIӄt/0H7BwḏBAJBQV />#~ ;ES{.QNɻl[U9bT%mG85:fv)CgPk$w*V0P'qRTp/jÈ r=p7? ~C ZI3#{JQ%܄X?Ue,-J"vZIj-{=Ivjk0JL]h*PiԊz gz8īZ/2]MH<݈d 8%4bEԓtRU"I6ZMY,UE:5bojڎ(Ŏ^BRpXUQNs\q+uC1ux[t?X;QD9Y;QeF>neΙWP[\YP'IIF}.#5h\ZSVI"m`E tV0;LԴ2O*&dH%06IuAj؈^LG,==EaF,HSgڡ3҃2F7ĸr7kh9q L%IQ!Z$'c`_s,Ct54!EgM!-UphS␌ErD;jElx:WktrjF"fR #/_R&9R,I.#Dy\rߩZN62P VT(t,J$ьTA%ĖNpꚑy G"`L0E\EA"G mWZUwqlO$*a2`g!@:ð6庄|֐::I~6j ɨՏ֐ZwG1kum=p"Ѩ$l~_+hᩲlm}ֳ <[@͘;ړZQR.k!-S%'pZ&9ejMΩ@2j(αQx$/ݏn Bޞֶ-EuI!gןdOۄ;&`@ ><6w_\~3 }W/__]ٙEքvӰ/w?ʃC.E|r/vx}}kpI]=dF96ڙp† 3v v^$QUFaq ֬|Ԋ:~Uk6`eՆ 2+m֎ < lPAcUܪrCa[ Π6(&UB[㯼w'7boq?㯼3(W_VetX_}z٠WIN+x ҆y|_=/S~)k Ov,稤__MH;}X.~ةMWzʞ2jg¯LSue:~UYtǯRd*1}PY`w,q!YrX+gB<,Fd2ڹXp`y|T,p%`z{5c}WtWC~J^=%IZWDWF Bzv߰Wv+%VrRrVkv˸X["u-ukֵٯX'ԝT'ʀWl@C+/TI::/|0f]%_]툾WX< n|-v>kFR 9mR _ǍܛLg  _3+^K0`WFEeߡigkq@Je7JWTbe5lmEtkJmX@q2sE_/_eZj4J[*0zWg+w_m *|Pw`-WzS}Wݵ2$`j2*aLdU⣵q֙aW ?2-ְFNyaxWfHQ n6ʛ s^y [W^~X3^w{ pǺ:{^;+L]^*UjoxOUU&:z uj5IG7j5$o޻CXCdEBMGPE6CGB2y`O'B,x%M:ᮁ!I٧qWe2]IsW׸+M9B6sD0kaKLѱ+)^wJh7ŝF!w+ZFUʅ0x%Ү2<e5S4չkĪmƸkLmܕMYc箔(۸ksஐD])955w w ITI箩.ؕf6ZO jG]:wVٹ+OFY&KwM$T;vM I:vMvtaWBAlǮ^AJ5;vM$vذkh}î# &{uî)9&swT)vMv!a vJKt욜 &}iP m5иk6CDrw])froì])p'ܕatr]]%;|!&ʅQkȕӺ{:rmّ+U֐+QeF\N:N\i&G'1X؈k$Si5:qe&ĕ~7q6jĕ9T#rԈ+@8!Oĕ@=G'/I27Tjĕ W{]ߎ\em\Cڑk0װN\ Ք:qE ĕ$P{ F\ q nm5j:n/trp+Q֠jH:o$2q)F`g4Xy&a 2iRy+ U㭼6tVgUYVƂo%S`y+Sj孡_lQh׆^2*Ch[̬|x+㗲[y#켕YpViq[ / vJ*U "1ӕpkXk -,l x5S:?r #>Mc{ r<ƍX.i_;Q˱ IΙEjN|&_֗6hƛ}wMԕ>/Aj0R+{֮xl\`A6R3gqQ%sfϦmG{r+7sWwv:6Ky&"Uuy<.N y~ܥtHūQ͐^]V|+ZgznS(|٤(abQaE'E nb+ۋ_:.gp-<p ?RzQ\Ge'C]yx&!{yMs5oFvũ>lc |4VLɈ0F-r=0y~_z׼U./_4_d9_M7ҷx1Fcow{;ףbnwjlbmaŅ_2՝nvc[]5޼{ܻ ka } Gd"7jz;}~}gj}?٤EV}AgJN \Swr[Of19iM71u8ދ&.v)l!y+l53^:4Nb6IZ8M[򢿻cduN(-_wSνqcNxodį 7B68Y;$Of7u'9i [lQ?vr?GtvRكOvb:sf7\<`>]NNc׻]uƾǴ},֧pzO#fֽhA|;]Z݌ ߝľmݫyv-f]_=|_yqu xR|3:rw`SMm*z~42S9yo@d[_Sh8&9dj_μw:?x]Lk?pliD(ֳs:ɝ7zQ Z[zM[u(eo5 !nWP))ABhEUHO՜)_G Nj] &6C}0~u)tcٛ]5٣N5W>]+䩠TNn(>ǣx5ߎ(^Q|np>nvp9UG'j(γ?mzWa!f%]\lH\s^slw%%F7=C9'u ԧ~Aho/7P~=6]-ZgUM;_EM?mmO@X K_xce6GߔyrךsZ$h|AV-j7~Xw!wae4&>RnoN*Hv^# ? $2C\  B~#FO! R<5'MP~1Tx3QůFףhߌnv*x@ףQ|9sJ= BoFbv+;hhTēQi>6\,\e#!nv00͸dMQѨ0M<6 Bendstream endobj 320 0 obj << /Filter /FlateDecode /Length 4408 >> stream xko5?^(Mm] Sg=l7ҝ|z >n EpfVoK/΋嫫ov!oG0#j飈rytr)]譴Ko}]],^t]6{U4*|! J/jd<:ec[T'^ǠaNimNic}D ) {l# ckrCp抦렻oV%7Mb^fbtwJjsq6J#t|3D w} ~4obm0J 2J|1iOC2GA\ڂ,:WG\˵}p_t?2 BHh#ITZFŕ 4@5)G!JBtd Dg 5 %{\c*sjI* ִ _~S'"&'5(p|v:nKب\%3FI4 A ~-Z0xhLnp+b:Z ;n^:1rwخPǴP}R/8Z/J*]60[s 'dJww Bf}AS|]ME.L8C8ぉ%z`J(͹c_㯥@}ԟ8iB0 psF-QG坬(+Z~!?ݳgef)]6΋_eTg7n)N\oEb>[Er|5#*kpo躌n/஀ CW2z^p[@t!&e.^W|2.QUm:I7'<)|7d΃9ܧd=ioRv$)'$5Kø<Į ]O aZg pH%=r2ۘ9vr;x(80Lt|^'̝OSL]`HfWͦ) 0q F\ӢLM=CqO7M_y/)gzQ0\ϛD\4>irCk})0yݔISL ~*>vB{Ro&wr'}Zg.]o=' ?dHwXbӃ,9h5 쩫RF\A%J]0h %yFspSTi605M&⬖` a*Qcʸ4#"6*%aҿ*gP|;JI`97]6`9.>w'R)?[%Ԩv ,B f0svT# " =M}uI@Rzb!l1U6|mbP~c _7j9GlMGArI'F5Pi7#n(ȹiVzH>=\mrƃY]|՘ѫESk? Xd,xW=.*+G}WJ.iRr{R%[Tti3qѰQ>zD$UK+cl$Եㅥz)MGR𿶏p5VV}$5(hKeC+'9Mx+{2.JgU`qE5]a=j\ɀvb1V oq]Pɺﷄ6DU`R{ O7; o\'YԭtkW5FP sR@}۝( @fW,f3QkuzQ 7sqT3]쌠{L]YBnSn7¹hɻ3-tC *Dҽ ׶%ޒ*k`-yh^ě"n.>bfff *dؤeBŸ5ېVp>}wc!*ҝL4p]v7H.zrm./4R )D2ufZ$Q8M?i8jRP9E2ܮޞ^#*c27[YT;^px'9dF8Ơ1{Z`G1h꽛 ?h&L6,ێ]!t*^1pc]mIiP"nZ47I=ӶU $p:C$矔z?%ed*:Ǒ, $r^L(OeQP,a"I(eB@y2n*w)KQxjB2(}䶷[1W.ӕLtuc}"F&w+˓g%R=Υ^ЦM,8bT=_1u]gDbx as$>/஀|˗"a 1 %mMgb{G89 3L)I)ȧ5ckb\Ÿ!e1>!N=B&W$3EF=^x]أ! Pm\ei]2qfF7 a#z>85o3Q|ģ3s)R_Kس0$xfQd+ 頻<{~9vZsb~ )ZvlX{ªq IMAOO)}vN 7axj\30S!Po<7 =f,)%Uʈ>vF 9}mzR^ !YwB?Ī{ݤL6MҊuG9ޔR鹬e{öގh^Аd LkKjbsY`i04bkme.Uh3Bsô#{cyJdɓq;fG~lh;,Gڪo6OaYQq\ǰ=m2lmĬ(k{ ۪9CW oW ^Lxvs ;MfMs5cW.]ϑ!Տ_zLt]1]v-k7ΙF9ofxsjN_;S%=ȕzm~ڏѢ6%%Uu$}"AS9$Nw\԰SӰ!JQMգqza$W?rFӤ<*mFhtMݣrITIJ$7<rؤ1>*eS5H0,& O "HJ^BY|K @^ Ptް>#W_YZ-C3Kx`ixCJ:[DB?۵d$}>Ko4I/) wcj)x x;!Y%c lVv7GEHbx!|)ǘEh7x8ѧ*J w"U'RweY>ptY :p0gPc2WF' Q+ouS&TȞ-(xX+_s0JM>;ՑjX(q~ʧTFѽOb_.E9g纥5.&BjGb.K:5L l_T㮰:(;K>x55A{rWr;E jO=+JGO".|ZA! z݇62 ?o%l|KiY%voIdendstream endobj 321 0 obj << /Filter /FlateDecode /Length 3763 >> stream xn[7Gy: S/f/nbڢPKԲ]!yG#NX $s_f3ʿˣObv=~9Ygu9gx飈rv|vY3o}_uZ̏aeBAٺA-zf=W7Rn+۠L^ )3Bh :K 'sыc4K+^K)C f.{sTnZ 2~h5|}?A2J]!/ 쫤 t< W9"@\ϑ9 .EB* OhH-Q,s(=`4[ `HS‎A[[&u/ 7@hn,fUf`+[ l/-sǸH ?%&)d[vir]bc1]^x׌GBQt[)e A~6Hb`lxn`;` 9aV#AN2 J^!ED*}%bxE6*`vzviV1ຂ}AR3}TpY ~UI_(*E<,i짤SIϑs2iq-$ܔ ! ᦲ榢/B uݟb ҃򼻫؞UN^#\T𲂧Vp:zSuWu ޝ]ݲ;$] WbeEe,7w0LioJarܰDX+#KΏx( > UpSAÊŐfTlާ *<ww귬ޫ!Tyb2ꆞ̵2 &vrx2yLn b ^OXt9N)P2S5uܒMf@*ީrY|4S]a|z|1{N2Ȳ%"7@o+Ṁlr46N0ҏ8}je&fF 'i,":Gb5*ʡup50YZ%]%j'Ώ0uR|:iy7վP%&4 X8 ܋AkN5Iv(DUY1%}IvHCzjY` J+~iհ]ۄ9 4·Q8ĀlrI Ѹ&mϙvXў] .b}HP+i;+'&9#NL ֽ>aCV3C[u fN;o+H.ؘc[+VAK`za/S''zQx+fM hڼ) V&LyO\/X-5x~}7(}J'dC;vQccWB[(Vͽcw{"[уr6؀$e։dGKS ~IVm=]FEbLclR7&ˋ1$֌KnUI2ARm2/KO7+ RY۞P0ZAy=lM4TFD5%5劸Jy`To+R{CL * ;w%i%$ i;c.~۲! V/Ysأz͔t5+Ldwp"~ldI 7$mra2 ߡÿjlI+nn|5}tY~bxo3ƴg'YY=׌ VZ@0|N -"BK6;zS K-9ќ?\?~Wendstream endobj 322 0 obj << /Filter /FlateDecode /Length 2088 >> stream xZYoF~#(Hâ$wM0QЇ$0IvXcZw8CyJa {gKkDE)GL/-%_Qn`%vUlm'ۙm;jE?Æ":;"qBԿuHo#UJ딉&J4] ;#dg);# "^{odBdE`]J鼋&LШ YGXK0nFJ2EN'KE WI㌉fqM hhYLr.z4ՠo\$` tym`V"KqDׄIPD:NwڦAdЧI6h0([[Ӫt`-:Dd6qiZ8r ܼO`pg9H[\W՗%KcvsU܊6#C6=F !s\##쳂`Ja5[]j;bcQI BJikfdCXr !"<@NZHXV2W,$C8UcMIȯ:p1=mO]HO TBq\T%@R&>dAJJA12RT"#l4>U:49?+vVyBz1 Rh3@ؼHBTBYdlH,D(CԖǹMi@u5A.h%92xgQ,pl}X\1^49C ]݃kX|7.37XԔ,1A^`JzwoT8;5 >LRP3 {adS.jc`0$Ou)VĝZAn!+C<^T EyAߓ10Fw ƇC5cPzI".:iZjg\DG(ZimʧTW"09n֐iv|m`6c&%+ec9ta*N3V„%A2Tp)k0AuP}ҽu\ lohx0Awܪ}^ItF9TiT!L?b{)ve,秢& q=aV`C}%$N\W`!쭯G>MX?fm .f2dx"|>j8C[f>Ԉ}O%7^FkwuGTWrug}a֍(Qu>QÕ,ռlt U֞`+HUBAڄ6ppCe . Uxg2;W)4 LrHcE:Ɍ 6D޿3vBuG܍Svۀ !l`oEL{.{,_x X]dA~kPIƒǭf=͂ %_C ?^m:ۺwWn4ďD|H?֨7\W>)>GxԵDB|G jj!=>"vT_ck^ԞG [33dIf-ILMߥZRoNyZaXCRTM/!$QtaOmG%M6w@dc?))Mf^7wL_/q6~m?>Toendstream endobj 323 0 obj << /Filter /FlateDecode /Length 3623 >> stream x]o]ɏ`>i"6-G@#%JQC(YqhICh<;;3|= _ӫ{1>_gNfEԀirv|~?3Bkyۨ֎.fy FE٬ m.+h>4Bk uf;_( $VǠknBDj+mpژ:m" B +i 61%lPlrhcY2vp"ps$F !Fg}kB{M]>CH8ϑB`|v̓%f _76.P E/7i1NdbPF8t,v~o4fo󳅶mpIO{*5U:o@I 43%)Ji#Eh[&즮~+aoXJkճl'2 N̄ d6vPrhSIXZMu5_n^}V}?z\5a|A;MUDqNkA>ol )L5Z ]JnbWSU=2Bh0W[%XVW)1* ߰LZ[٘qcz;DŽQ m ߎuӬ]4wR/'EueuWsY3AO2G&bQշ&H\ًD /w;*bvؐ!4X`=t CvXL-] +npI EvXAh<6d68G|](K w.\|D;z&RsCeQ$iH2ek.mjCcyC Nف06y43U2Lv8䰰8F(:'tUiUn$H/; lJKӬGHBigX-ZK=aR0h˦/i=ѲsTL슸Y7NPAp;,B[H' wVA7ye)O^@.Ehs$%%w;n8w}@>64r ;,2,κ\O|N /{~E7~M٘(** -1ɪWX9KUxW_&wa3?,ʝA4b3VyHXU8+6ՍY#ʦ,_f2TdU?{E3.Դ !556EGJ{PoުQ>%0nKp$pS2~XU3\UfR| 51ccu8Lg@SӽSf@UE:_ecWomlFsW|Y`z:G42S`񊥌U _1H!o+ٍwhS[ԘTG68FeC2k6UU U%v8A_ghToUXF;[]QL3J-X]RJmTIJ @ 劑\'%; &uwz΀7uXaC#[ԥ@ˑ&ɩ%&nVf7Бd[LWt.543Imq^E*#Vֲ.k78Э:fѦwJ}ׯB0(;ie4q̨SC  Բw( 6ؽEMc pnL켂j6uSsꙂdZAA?h >0*У(%Uz|ho??HzhYfrtնO;dRbnc$t_RycWZXVy671G,vz]*8mm݉蠊r1N!m➔ހʝm§*3 *T5oi=>RN z d16x6C5إ|(Cy+|:ff )(WT7×%O,RİȖ[Y NQ(w=ެy4OaE{5hGχFF|8 3C}ò`mwR7v(/ޢGݔ ubx%V_QE}%,|E/⻫2 ݰ%M)…SB%K C\Yr@Lw!21}jY g/(`u|[_.KL%M_UNq]}?)k[eW5*kI;|vu~Nmiu]ۖ6~}m3aٽ=VE6dO^քmW[VM1໣IWendstream endobj 324 0 obj << /Filter /FlateDecode /Length 2551 >> stream xZKsR.)`;q)/ǖYÄ\I ]KIt70,tT[`/>UkE˻^j¿VV]wo/#\飊xJ[a >zpC[_ܭtGۍHhuvUCt5 HZfkA3zbwl+@ 71GPkq X=%J۽5^>t1^9L/ec%Qt9^0h<C yypvY+☹q,/xM*;t}^ &<T[\6mZ# dB4L|da3c7}jՙasGų[Q &6)3DEG& +?B_59~.䡐>x!Άⷕ6[MlNe/d(.)s,r -h.AB>rWȱG@f ݿlAY*Iۄm_>.%'}7}'qғ-m7徕W9WlA rx,.rl&xbR sDqr'-ֶ lW&^ea-˲z#-2~}a& LkL>>>UVyDjEaoRrϢDEOMc&* }!]W_vuIC9Bqfof =؄BL%d}ɿUfqF|MUS-A]_`obH 뮉6pDmm] ⶫBo䮩P;^6^H/c!hkC 13ڇ bY'h˼\Eˆe$&a_LP58X]aÊm&iLNe-c wtO;s6ݞUQA3XR_YHA"6wb538O&N؞VGƎՐC›!ONVivr)4(4 D;8rOI4uM:8 Xu G1 :(-9짳!ǡ\݁UGIRL(i\3JxnY0%(c6Y1yF B' $=ĎHŠ&`d,qG)ߑ7;Pe&cf~9u@q="e|[iXhдire>n<<+cbdmMy*F{BhGaܙKH/ N hf2]L(MrHVĭοjN%6k#*<&:z&fJ#/[mC_.B+a25Y:^(!,Lcy-zL' `Ve;Ww9Sz/#c%qqn+0ʄ`U-<*MhE= 5Q }]8#ۓҁ5'J4&|r.ya`A P[#kؤR|XX|K8oDjčI@~ vJk/s rgJ7M.e*9=~~kZw79 .9æվvu&EQD8y9y/S(ٳyNxgb$1GfےQ~ܕsJPs<>uXVn hsX y {Rh mBB(ǚ%[q5gx@Q5<|_S@9/s\^<Ȕ6, L+ЮM'0UHTeˮg<%DZũpr"إeAp%j%(JP 8^ d DHf)fo`T$v9Ѳ;mq[;Ll*BIvQes 諫DB,XݫYr<]Hpûlh<Д3 Np| `Lej9ꖘen_B2'q+\tN&ypx=f'>)ub N) NR& xO9F1YKW`PۑpţL?}3U} ΋sz ^TÃ4-> stream x}I6q}~E#dd̈́u|SEÑHrςzzF IcugW$2$rWOGzo}7U6c߾j~}~Fo꫾c+c/A#xQ|K) =z1>RGYzx6{7HJuZߡ⁼VDG9֚[=^fy/wO>?[ϵzJ}W׸O\Ooj{?O5x0u?2n"o?؝\?j #xZ5l簯5 /ml{˯c|oO~9e?孥s~?{W㣷?n6l/^6h{PGtPGy}xJ|>92xƦݛ̽C/QQ?:;K=4}z^ePrZ{tH{7LًwǓ)#Mn͏o-nc/!̏}4ug-zH dYVPQbI5@lRELAM{`5>%2fa #(kYyKʹ}]״?o"̏~es@c{K㣭^Wzl 5LI䊾7aW& UoK7e~gz) kڻ^ ܔuSQ1n.~}aԹJz2? в1Z͑uAʠlvQ;~U#l~T`0V=N),,nooA'(SD1Pfwv6qPX^qV/w6UBsa,}$b-ФJٜ-۶ДJg E0݋oe7܉*JbsLlٲHyIKv5Qv^-Ӹ͖OL03mB 3E7F;]-3P.qנa$[[ 5EN1)HMG/6K ?j3T AJp7:U>SubM)/S<$۞ɯ' Wۡq,& 4zy[jNށC=r ;2R򹍥fFy,ٽ "\m)L1ϜN!lApM!Vmg7H-4q&y cjLq@O[Г]KiP1܂suIc-_ߋwؓ vRL!٥az"шz#Kd}7uJECk@K1bK#Baa8TJk=2"acMk@ v7O !lp; o;~[>R3)B>`z!jnIMV8A`=,!{MT(Yܫ6f2rQի6k3B,A+QJzvvߺPch]@l,ٛv b +&[n_ ,b?z"awHyۅ%ޅ8ޅg `?ۋ }Z !쾙"ny vgc-9|x{[B͉0z{!S{u,0-5;[M|INA2eP̍%ms/&@X0:p"=9a*dqT}GO1 ,uyhSX}|jTbH/$=Hg7E{4H0q2fo淑' xƞ8,r^3~#}G^ )jI~OO3,=7o8B({nѥ!=&ʞk(#baAmd 5S(D=R1ٔLX1p"#"I$ml=2 "&H^0i*\H&X^qa-RjBRY8ҩUV%`Sik@h !~4칱ЄVfIHt0өT֞kF#^{lf&Z18]K@RY{45Oo51ޡB i\B؇C GrlסPffڟX7<iՌ hYMk$~[2\9ؒfN iؐ:^. =sQ8!x 0_Fׂ]nW0Җ^\zrmeFk0)6R>~Mk$ix;Q{9s};k?,kҴLDYG/: ^c2&74O/ tDJN{ʾsds#躧Ž zښ~A)+ &CBL S|)6]wtbҴE2>|,&]E)B`.Jd4U]cFBX kvzʶl  LC!ze{ܦ\ԍf7'R*!,o6e`@\izSxWϮQA`]YsS^V(5tN/G6(AVAkpU_5DR;{JRCFd-Җ M!cӻFmAmWyԉ;#ѤV>JmJ͐S 9}M#Ba !\ }W)t q6x)q6^gSG3Ts}}fj[`NR7}0;cr+_癥ҙ%\Z!Mb EX,6J``5dr WCaz.^lDP=с"@5tZ!t2gJ@NQ(7EVN@<%b✅]"Zܔ"EZɂX[qD΂K05(aj 7l$2rS/M(TMTî5bu7ۭmxF`jEg2Uh: @ ]j+ylV/ Sƛ H}&QjH)'gM)"aMl=#0y 1,5X[6INmI=7bM1e)ӭzZ4LjNM{FM^r!!EpLdn+t Bӫ%i$L0?]z.HviM>5qJNnYx2o4|Kx:Drƽ}pQ<[;LM1ݩ9dEi+IdHmJ9vMKA}@I%2ӧfKqnmK{'t`C78>zl4^0+4f7ϚS4}fDN-a꘲gna=٘M1>o e-4"3z+djM֗JZrn ݦM" hqa`#( T_ aŀ+q̷L1ξA!65K5'’"i`IIVxD=ڌ"|mBw|IDUlؔE)]'+0aDdS̊)1Sx &,S6XVu;ԍJTA+&uS5ݨ:D70Q3PyQ e0㘡հzèz 7Q1*8_#@f}c1ΛbXZiX4ƹR&uY٥N浧E9zH_TA5!+箜A/bjJu_wӴ F3XYaS3Ӧu)-KvH:^`3p1W3@ c %ȪdYώ|f;a=gyh >Bp:jSs1/p,ERp)~WBkxkPswgQe?J~Ff:u\G6oټU;9BXE>-4aG,4asboh: BsI MFPSZ`OINhMok{WɦTؐҤOڱߏ&>ְ2Akأ8bvſ7+<(5-"Y/&@dMcIƙtF66B#cha M0v ?C" 9 ` Nr"Z晽X-?IKuf|M 'hPxZ­X☲:4T_j(E0)wB?f>p' _KR͆˞I@y\4j;g4y9~ \BXH!lFhNV ~e K$D  ԟ:|ti-Y-`\{b=%d= Y}m_/a Heֵq0FC%GC`ݪVa* P{j0q.0&F< uJ6!4T{Sx*Z3ղl\틓`F6w?bh. 8Dt~S{f#1 Dϗ2Q vX׌N+|4>/9<\={Q`C p5 z3 bqC8F;ZbPo,Z :vAj+/<к%!\GwBbh[p6O$;lJsttt+;%;C C eI2D JSB.+M*@q^s?sEu>#<'1O1Zaãlb%T56OM݀^b; 8)4ZdY7qv?)Gz2ȮXxހ#+:]Ś tKuBvt znC\qm$4 /esoI6vp>bvh9+`z^arС(נà 1; {CwќqnqBmvQ˷&z1ΆwΆ9؏g_z&ՆvG[Š˺.A{M%{S×k%I;< @/.4pi`D,{Th+ʴFNAV2dsH)isxcP 3tѐ'M9 ;5.;gޅ B^8ҫ\"أI: 0Tuۯq a=c2bs!je*֡&bs).u6BOC5OcٌjC|5E92طuS/8x{s Re}c irVЦHvN\,-gu;C6$[pRAq D焐n1y3F .M0K-uV]ޜZOCׄZ߼_Ox긓2Թ|uK3zȔS.M'{q;yҗ{{gϸ甾 3r昂΢P<7?2(Ly<5\)S+'5f>( >[Pp@7OXP6r%yǔV9"?CD"(҅x xQ@ O ?IY~ly[ʜ) /㙃(TI?VSšpM \ eևgS^plz*Mqu-ZΡpOHEa<ځ&TO1VΡpua<>wRF p.ɁᒪAa<2qr_}}];ET+g  Ш&sXp))`\29dX)JB_͙Dqį|Y4}Zqb 8V,A+K\ti cf,U[/jFk1x!Xjg31u›( #>!LX.U̙`ط0ri S86ژ"SԿJw-,dI{Ojӆl f=AkLiذUnk5ӫ6ho`QwʆƃCD [? >þJ;# [GoPx[j̬h<_6H pZf&Mt=DhSShSKMMSM? \[mbԙYPU~ n^Z MM@t[lfV-ШoAk "L&mwY!o/_H<v1bh9n"S %!tS%߯X{/۲ma־[/t}‘Gݜ 2|Ùԙΰ]i-g KW#d.{ ByZ0A*.{ufzE 3t W3 %lAJk\ЖM-eTiNhp9AUh76WtE enADtI(&T)&Y3_F b3Nv8 xYJLne>Z%+8BR ‘yf d{9\W/1d> H (:B恫kvza6gpt(@Z- WD!J5L;NKYȺy:'^]p2;ؼW3z/ d^z(3O4/OeZ`xͫ߃ 8 L1!kn|"d{d.Y]b5(0WeclSw1 afb'e|y Ya Y# KjA<}AJiP5hUBPP5l~dl] 1j*dB袷1XwA STFa5Ɨ77洫r?vBe|V&&Qg\Mj :,zP4NA]Ϗ刍)T}n *TW j%K=%L}Iy^lڏTؚ' ՆQ\-bXιXx3/ZÍ/1yFAN;͇yȊx}8U5E\jUr#׬BetV|)xΣUtmpY j bJZLN([;bv♂TTĕ@]ҫ`UXU!2ٟ*JSeha<5O24^J{:a1Upy^*ƒoe]%Uղ2O64O`} T{vuѕA:ݦMsg1 =qe|Ss7.> tm}b6oqu& WTY^ j~S.)RnYnaU) 9}n+TB&4!T}Q)K&hy#^RF޼SoU_D"d[ßSrޚ!kCLj9{j\52@`52i%CLRw5T #l~ş< e6ȃ} :+ )~I!E iKBإg¾vU8,\-š9R\XC&2U/-t_Y6;"0zTA >]tEq!yc4 Xv'^nU݋y8e~F&6ETg@L^|*̩p阎Z*"ҭ;Gꊍ!lA6nVVd[.4TTQU÷dD\2nw2JĆHDb. {[.Ԏg *~Smssg} p2kUDwoBZlPU ֳNU0۳]{U &mu҄Y^T\ )֙jHr 湿5Y wkpa2E.lj \C\yZ-Lӵp ۰ \atk`kVjw\C 2_g¢, Մ ǨA+Z: s [G?F3Ԑ^)p -M6U FFvmvUA|UQy4W5ԛb="z{{2z~zm8JD }O O83z>ܰ)BؠHy,l&mBYb<^G Хc5$YaOvA<UiBט=F9مytU;]iA1ti"t}]RM=3AX&]jnnl3='U n.feBUm܉4p$g]RTmqiV UOG,Fg R16),pjX <[K:*LtVl-CKB@:%Vqc,& lmy\+i=X8^+Yq4LwѼ,z'G2W`+J]`VͿ1TB0yez6[a<m"4G{bk:u?6טF?n_0 Ckj7,t Ʊ0j/tQg \ͳAΓ,-"--v o/97NtXm6^VjgQ3i>-#L,ʐyqygPswspQeL`>GgnvlyNO$OEs Lg*)@Ck q:u{KC+Mrm-5n &@URhvET"H1<8AAx^&ހRXu(27.Eؚ,Kq\1wC!kyqj* AއM27XwI - NtpVrVlyx*IC_*BuI:/W)^?.l3[3P^.l}܍*buHʹ[DhI97&).WӅdR}0G<ץXF!Xxa!t%&,ʷM .?pK>lSp ڧy&ŧkS:Uiu֠I>z-Ys:lNYC,aU}>}QR;e L2/`*KsڝE#A{aD|?R@A#t@k' &yEBׁ]Gf$3 ,xFLX-Lw3P0bsG& g!zVp?(>)e1T|@E 1OV::rFef|EyyOWwu:VQ sQUҔ,k딚7C]bQ shE 6م+sTIh4en~IaN9b?ҷ IA#p tck"Eu@(s܅"h|A54Np dN׸a[P Azܐ&2a6]-)CRݛa[CKRB3\6;HI#b-B­`(s]3!d!m %#{ Vؿr!dG5||5Gom;KAEeb]*`f[4KFgşI #hH"B8_"vŵ!X"ŦY~QT:. )g vG1:c^0{]mfQ[ nM%/\*J3E8e<@h%ǝT [, .! R$ _ ԯn+>.QÄ {^]~xtnX6לC w?sٺ Ǥi#0({f]0SV",EŠy2ʞNQӵ=;(V 1p7 9,~Lir] [PH)jA1Z¥vOZgY|9,WzD5?~Py`SܟZaBeKҙ"a S2nCژ'*5Ҿ`E+ Be%'um W%}kA+T# CX>~d aY2˩2np=d?6&Tƭ}֩['VKF0!JVq WHab1qkqUme\ov zxc?O \ln媬/n'YF+lH N3ɝ&@m3"j=NXy 6@>02k4[ Uqf)b{ȹuW( 4iRRh ։ 8սAVE+XGK3E]qA!f#a}ƭ}Fo3n+ ћ*~oђ˘d\U.)WoTpʀKa%*De C@QǟK($k0j[BB7 [z|nXX8p@Va=? +x(qfkP"39AV#=(fXx\ޛFGƛꌔpT_Ҭ&\kܥ26tPNakݯR⨏; CB@ڭ<ʗ|M- %>L]K Syc\@x/TA@ [A?pc\6K4 []Glvhoϙ > W:Wx:XSR@.pc$f旆h>vU-p2Mxyu)JLY6ԇ h2VBiV'-Mz(*3lvRȒq@!nf i6)b$p}GquxG8Wr$A~1H xBH8 {{:Q*)<;؀SvHЖ2cM 4#0FdC`,&r '7\qǽ= ET l9[BłM%Z"VЫv=6ru2FNPAROiL< om!f%nʞZn\gf\cõIӖ%FC'k \ȳٌl}̳9Xy6M1ڤ:3s@g;ǂI(]|!8<3.!SlB,b%&qX7_HR" >C11wR\>O k&x=c܌0,N6HOB= ]^K!{S7&tB,f17ʞ'bIh΢kD` ʰd_Cl;E d݌@6Fm)BL fVpsit#kn\<DžEUp!tUpͽ 7 hps;YłL0U"P+}cRf#'P' &פ`CEh"& 3mBvTl!l3BЎ&b+֩ m4xѿ1K.*C,Y昏ka,9Nx )ڬdNlsPc*mԿFG3ul3Wȷɿ;p!#&HIuҝ./9 2yӃ)% n%ozi]5кo]]W6ν%nhBj)Bt&֧s<{SsC&59@j 3PAp:99l2m^t(}lC>%)=6򂳫YFB#_wV.$²D:'3bP!$5ds@MkJ 6q*ҜevC|I_ֶ@oֶHR*$06 *⋄նSUfMJo]F[6`R & Դ_Rf-srnҀ=NY\h7NU&ݜ,"6~MKRuR5.)ԍ4_kFYø,fS՝:zq6kH+).NeMO꘢Po MX:5Ju_N Cnې$]; T]I]xp@IKV| mώ$e]^u6%E7 ap}"b7D9b\gD+q!E)ƼsnipHIg2N|S0&a3r,{H3תt j&`5*TYϭNT/U"f +uYyDVJAKUۚYj-akVt dm~z(PCdW06~Q@Ȼ0p I(-ak[!l ȻIp|U(@tH}+Ur\s &uVm &uvb`ͩ fh$fw Cr.nq*f>F7 E.Be)7 Fd r\5>ِ"+|e<o ֧PF !OoɒϙC<6?1/R{1r#pz3 zחFdsȹIx}i Gף"D*g0(TY,)~`bo+x2[^kP$ds'Ҟ9 E7ӛ| ae!l)4L9^)@ݬCg`\ +{PKKL95u<=g"+\I^r@t$⋗Bo4y7ƶC;XXEџ3hֆv8x ^H5:|*='4` ,Oֈeu[]bi<#x ',Rאˈ) =H1E{)iE$! ]f@ jڙhKm9D\<ػ/_s=)][CX0WgnS)K+`sRLib|bhy_J+AiB1nD1W=rTf}0 rkrgtVF_ܚ4k`4XX@n3[ EfN@vaۜa}~g4p@zMN(*LmK_5"Qqvk67=H+l͌KVٸ]8z~3mVA赎*ȯ פin8専wC[5X QcҸQj<864"^TP#tT@Fס 6Ӑ04NpUɟLIq?9!2!34>yyru@`NIJ™ɀYE^M c]% /]BS) ˤ%@MM!C}%6yS9s`T[ $as I!Ry8C }n 6 }EHa9q`旅+kNd A\Nl#VH9} RH5xݎ2l8􆾟|"jHw6Z>DR ލAC(F~M,]-_s"OlBH{^ %lDѵe_DX=kak0:L1>1a9Da9I(|ԌG>Sњ.9_jgϫ;:#.gzpOr׌v!딆~{ :1E'2췃(\ÒP8hS9ll2ƲSIpqD^I4Ĵq+L_Y%"Msh0Vl~Gt\=Xx*%f R\K(6QyT( x *u"S_iR7DZa+"p;ʺY$|lSgSS" DɑӊSe. O%''e Df&' $LN$a8CtYi&9>%((:0K 0KȺbDPQ\Gzy6t7\0eDLꁣnlk(P>ՌL78gDPWhw YՙCB` ubZ'`r _zm/Ui}k@"eXFLv :TH L ڐ\=AG/HFMz$c0. HV#J~0d>9203#|& nRč}2X3MAW@Cfɜ…ʺip x1noVhRDL2fnl _wm,_C1,|}f!zQҒO >. ,OInN C?eGSr{wnpCrxn#={ ʌRlo5(wAğٔ9^d^`D8^=Jz{=u(`=R)v7z{5MQE:Oz1{0p&m*yC)<O>oœOV@rojxf양lEBoVtrCH50Q겠֝%m>) jOʒȻB4I)OJ( -螄.zI"vN󢄔%PrB瓰|R 3]/+ړO^/!F<(%)K-`'|Z*^=F>?. ,o!0l;/GÌ|DW"z4ni:փҒ}bz\^(RW~k0"A ϵ*D~{ yzRӿ FWB/t(SJ4t\3X{SyzgO 7z^V*zR~;x'=׫!7?[.9*?(MF[*zrJJ{),x^oN:iV] AYF[*ħYuIeo>>'yɅti\AY&եbiTAzIP/RIO?]\eNi\A)1?ͨ7)x_Re<'oW"|J4zzāu/ۃR?ͨ=(R~ٝeT0AϵrE^/&փ[BOO|. -=(Ӕу|xB4.d⯷\9AiVjiR]AO,J4.8_ 7J|Z.xPڧYuaeNwJRZ/kxP,ħYuQ>/TAY>o9R>ͪ%/4J QdOPr;E7f|Z.'Fԉou }uSfyC=IԥԵԧN"K}?o~)fԡx. 33&j?7+Rv}ͨ^<1R"0i tXx )׷-'> stream xYio.G-q ! "-4(ٲXcnݢ;mgd $ y7pfK1Ot1xÓblvXX)=b8 Q1tbh-2b+?fD6{Q*= ^//_ݪ#UEBR idZȪ4Nj0\Ulrri΍׵8CiPQKZxRpncúyǖ(9 EB ء=j%}H)YZoS° r^)Ӛ֚ 9vﭕ$S`c!;q!xfϣ> ªqD?|^i'4 B!QhmP)SQI+8\7TYJdF™[5)SJ\4+=AHVBT=w AbPկ~>Ggx3\]FhN#`͊pIڈR$W:X: 1ʶN\Kvr#J\$c=;2:̥8*rl!=,ԢDL+P[qcen،(ZFEB)ȑ)`le%O5 FsjIt򵒪V eE@ &3IfB;iXx,FNXNrE!,Ne ZUsXJkJ q{zĦcު '6 ʎb-Db@vF%WfƬ*vEWݖD}I$']GHqdD!cǽ`-;m*$$yǽ9sS^!Aw}jY ^g-q5u2/pUvlZ6{]wxvFVTBNqvPF^:Ga=Dꓖڵ U1BBrYƾgr >v^>ڧ2gws\\inS8YÈ~p*2o!̩]Urg | 7_tW2X"$3%'$vGYkH7lTZ;zh|J5!wuu*y1F}B8+c[R~/HYJ6H |"$#Ӷe{zAH,;|HڊYh WnL7dB$E@ߛ,udn{J*}tt6~_z ?{W:O{PcDV csyd7#d%Rq ]L;~!wze1Fϳ{ LTuu}KTWugn<6}qG;s_Q^~6dLawL.̳9@Vԧ&8 [j0ܕ+- GOǃoϟendstream endobj 327 0 obj << /Filter /FlateDecode /Length 23118 >> stream xɲmIr6ϯxÛfʫj($3JU&H J@*Q$RW瞗U0d4w}|o~|˿g?o]#N<}_omƷ5?o?g񛿭q~\gנgo+?ef>~Eq>~O> <;m{왽-_<}sD{F“^>~V/;fg㜽oNsǟfs֊zr ̱>/߽15SxԽ?͏;m?ߟ˥=$񟵄%usz!\yv_}sQ?#ۏ?_s"lSw8'o|XcƷ\lj?Ϊy!??}({~-JY%jEey@a~>|v ad6*AܚIk?Z3"(_JIQ&dƥ99WD9(Aڭ6V(/J ({DE1>3?3R{u^v3NP_Ýų ZМFQ>)Jb_c=fOjIWآ=Tu, \=~%c~ KN1)|7V-9,Jɛ7k~8X baNOm",hkgP̦ Z3]BeNQohʽD.jzU2Sp1ů 5e Jsoה)%@6@yR>+Miy@rGʀCQT!0QRK<^ .9=%%%uu8zI G &,Y2RvqVQsK;A'eׯ%:zod]b^Y,yޕ(kyYQTPɌV%(^FZ +`Y A,A ]NVO"% ^j-z~/uS-zq/ζ}X$Kp8)5c%^jlx$N[}heV' Ε6n}?Qu0)I2nZz2|znAI0#̉;2"rL>l$ԬK$$ dhcJQÕ^( M503 2`/!/!FM˿!Ow7@) `tWk=@QeR )J{mk~~O3)` 7 k;0`o0S|) M$^^2O;mfGZ&O,s-AH% 1Aum{LQ,F/ې%Lڔ0#=<ڤ 8(Ti<2`/%&08D)0հzNj`A:558hx`%NGuL(i:zF(;4 >Ka}rJo/ql%eӄ;a2BTd#xJQ 1:Y$E vGxJnL`?R:I4Cj]1?NM63&b#^.8PP ԟ/96Kӊm]µgo# Bδ򘋾rҼ`#=.`LY1 Ppb%ǠY7J-0![N=?k4aAv{FKvMrt J;3Βa%Wj]۲yu)F~Άڛm k +T|ɐb^>CF3;a-rYjg2~ D&yu*;A\)Kfl.<-hǔ @NN*AбXlQs^Zo(x2UWJXOnȅ)ʤTi-T)%ƫO4ZZ5еA?F;gܽ rWJ|֯9q䰠_%9:ƌ.{| ziLp=LP sU JmM$ ԫ"y 9(j!Av$fB "'&#@ 3w%b o 2Pj$a-:<,n[,)^_xJHB:*e(U)`!)h|SjqqƲ̷I / PNN(rؿ4M'H |OB~[ k:9Q6Ǧ2$\nCQKwib+T 'B(;%%[fNe[Ȥ"LJ]+zD`n|@ cJ͐09Q3! NՙlMlŃPp4 RozšPף!KLEDjli/؏LeZRc2-#HFϭKj`C5aXz@5MuGJ4X#(ε"r~m  2R;}M%pNZ'oeZ B)IF6$GPbLHKA'e80bgx3r]p_$ ,֦W%3l_@p!(2y- 2e43EI8r*ri$ 4c%e:EIÿ t+֕daAXyKs@@tT' eXE2aw(ٍ-yteirɅ!30ܵF.JȺJIǏq2pbj6Yx6b7D 6*&_Cj)IVhH L**3ReR[Ǿ[+mYYvݖ_T{(&\( rR Q\7d&BU>!8S`:P2-DencQ[$u"Oz;^L>:.)]sҵ(C@ȌrjY#= B09H4,_Qi1t1MkmY([1C&vz4 ,jˁkl,Q:tLNtɊt(4نdLs2.9m˄^aBOK\tPdz2{AJoUPYkkR<dĩW''fkVJH-;C.G?%pذ(M[_TZ2T=B|3jYD@wNϾ_'7!W^8{)J%'F׺2BDHLqhZ6$gS0MI;qI(cDZ|,3P]s+@fXLZ.d*'Ԛ;jVp?PI*^Gd9rP^ָ쿎ܸB07Ǚ͉)MqǤD DPɗDASi++ `9$yvy\TdIAא.%Nh B"8^r ZȀݥx9agV L]@ׯ};,8T]LiNKtc.7l`T  cya Ʀ= !I!`[FQvn+PJә ũjo.بKA=&씤V/19yBOK]nD!כD x ÛЕvyw;2C/{Liwȱ@lYq&鵗5%'rҪ}8nT?S;lՕ.4PeU}iV_IJ pdvF\޴BAyO+v9SL~,Q*}SyX\o!PT*SW=PϴҾ`+ܷ-aqj4Euddl3+Kg@e1jg/KӪiDl)&q<`יA3iWPݳOwҍ'eX(vDXRgg[(RǧJVDL1SZLOvܷ#xJkgHu3qKSZ:*휛gSeئp^_5ӶXz;WWH`ިXCQښ@ ޏm/p1¢5EP .6]q T^ܠz$c]zii 4(;C?lRQ!)_֋Cϰ6:Krra HA?5iI U'(Cm-PϠ+PrMAT'z؟1l%Y(rn*JveY7eY9m(v(gThN3-P^J(] [*1C=z,cC0-塌 *Ae肱zUjU˖<mOSEq4>@Gī#>0+hһǨ+&y>d|l8Kh(ꑪ" hmnd(j ߤp@ o!y9I󓅫~C iuE8$`A/|$`g؀6@ uXy(=o.'+a(0E E05!@۽. vL'hw&ۯ`f>Sȭ EQDPz-0>؟Քj4ۅ6`?K 8rI)@67*SCHܖC/B,S]9cǀj"Ӊp2)7)&'2@2RܧDk~6EcmeN0[Ssk(9 |"p'< @횔Ȍ4Re)1l@ʸ0Ւ1[ɡNgy,̷Րj@l2$: x"!'ny `rC$[]UͣPBuzl.]+fBL!C1(َtBL9򧘩#e*DgJDv8:i5.|{X? @f6VwQ*J7hN )F yhj)Ja>Lf~IFޟL* zM32DȂ-@3 R悮$*}1#D2`l\mK0W ԹS ?ƂL 3t0/9*bR*Aip]me5Ԯyz8dz$ҍ!љ`I"q wTO@ ԑ` aV?c̹.*xN38ܭ}E n{CFJYp `#ё<\t|'@I4“us5waBpMN!r4u]]41"zN :4i;H9h]a *u]g=xN;Kjjy-Ăz9 +˔ԅpNGx}XGPzo 2="ه{ fU ՝H5rhk|vtpGl電.H'Z& ÊMj qF'v;*,T; lOPgqf(!!0EyԤomPEf p)2Jཛྷja9k.h^rMe]}E^+}K8d^RBawH^fE _LJ=cfݤ…,P["f[%ʻXWEԛYU"#2~QS94ZFkGi]huMGi$>,n OXpC H1!C^' (.@ܝ aeR<;<+zS O`e+sQ=1]8Cewb`[ʹ O`[jno97 F~dݺ%o!}'8@9xP[2`1:x=Ҝ9PՉ1(ZK#IMފN<{s)qbC-@ IJ@Me6 G'j9%U7迋q0Q;߆/]z6mu$,y/ [͡ NEPcNz]GP7y-/ _LL$u`zT)`[@ç3̮/%/ZTyw1H+x+°<t Hcx0HQSrr4pN$KX̷*,Pl\d,vB@1L!o;SM(<֋6"D |/Vs`!BEDhcsV|}< m8Ȝ2ǿ Y^xNRr4GywUxx16E ![@nGy;!@*[Px< VV(9Ϳ xCk~n;q8ft6Ő'w%]פی_.V7ONգ̷KdBf ζSCI%upz. |tst!TgLp1=C%XJmfl9 w3._̴q*pLI~dyn2:$^2.SʸX9o]bl XPƼLwtވ#$2H=(yjE1RNT &/tD uZ0Xj roRvOI](ѪC|te\O%\^N8{pgJ<: `,p%0n+}7oN!.5']8N,.?]`C>`]>bW |E(PuiG?CB ]hMJlrsƴ,}msD-0HB2#@u!;xLX?z 3.B(*~)@`{DsײU$*u-S"1k2bN$%C? @;b,ҳŜ۳ B |?R]^ԉE$}DL@"Ro"ݕ4< yz]0͉.eWЅ<ث$BBT*Y@v6?&ьMtp '[F:!uf-P=>3Tr(Wt:(gҽG~e U+%@]]J~r-^"@W 3BR3}:R$i9(^HirڀE1η6C۽_ߪMtoq9qGWen_cݹܛfi_ ?&e\ j@&4d=;1> w/NSlAdxzLo2s٭ jpE=͞/0|s[G/R_ UtB"/ŵ2.N(rMb))!^X}:J)_!ށ@ 䕊.&@*{ q7R(U0eKݻj;:U(Jo5N0i.*B+*X~[I}@}H,y?3P{5>v_ܯ]DWΥ as>wRݫ^4K^.w扱$_^cg] ,jx+Wu5,J5MF}(m__M4ݷ.W(oq>-]XORrn]NhaI}ORɗso_)ʺHSʺ;)v֜Q-p5p'T)+ ;B!ᐔI}v.r G,ʍQq>\%&tķf͏kҐd|, 9ny;_" e.ȑFܷkHK S @ ;t` ZQW04LQsr*]{($G}:c`ҜL~S<)NjRk1A7ӑ,eRG:j1ݟҏ<7% U_ ^S$ OP*|y?H?4_@a=6)e5(*}G!:@J% #RtK+*h) hS}LSt&8䤗CvHi5%]w'͔(d_Z Q̦[I>H0,wCV٢h5Աo5,CC:1(ZɤM!E7 1\M(-hٻ!9(]ד'k&Uj%& `R WD4 Hchl,d?34X]CYf.Ghf̮m >=ׂ׏1Z] 2 orQJ*B+ѧ\rFܕP"˜aR|y7"#C6X㸬!L8@_Oa u2:fgBH 2)!rMB(л"qmS~_ϡQh;ܦ<&S(4 uM`wR](,4uSp cC-D48RƹG ^P~{0osowͫT$ytG&s_/H4,j^ xaޫQ#S t|7oA ʑMP40ɝ@CY{8?FhP}F Q2j(\s5;5uFNrҠcN:U!D>N~=&ƽJOp%E%|J߭m]~X_&Bဘ7|Y.jq/kq>κa"y_ͼND'>v<&эMI1+K M!rM>@0y8_00h9d>&DRDclĵb氒:!YltgB_u}`ƭkI! JiPU-i,;Íl)7$kɤ(5*!aYHp>(l 6zyc!uBHs>P|B䁄!|&(} 'xA:vyVg P%]ږa %E r|BƗz4iFD^;4d+ O #fR (:xfYtI9=h'3_ Sc :M lY?8DC$ 3hGz1s:`".-KMPn_d'BS ĿbG$- * E4AX2jYodh/`-IBԆny$*C[_ _ۆ`򸃬Wo%53K,1s}潌lG ~e0f[e]l6l~~ϐMMH_`# A'd~fsLڴ$x&6EODAjgɆ%$`c6gbLkQ.`LELR|ykĆi kSP6^w6grmꉙ> C_5gN񭫍\;q꾘x= Q[LMR(Mμ7gFJ4/(9:t(9]f=o7dđItgF4ș7[PBFL0PF Bfbp™ $+PBAkS FLR{nL3I9;G F.5ں[%\#vZC%OYFMj~:-i4"hrI[uzJ>W'!5bgB^[ЙҮj K - 2`>p̶ h׿$p]Tlw%Yo:* ݓ;[,aE}m0Փ},͓șyսM]}FLPBڐa; [JtgؙC莄(+H"y2f!h(4 Za=FQMߠ9g~#LօCLQ\r[#&&XF㦰ҕD>~ ˨gELRu5'ƽHI)t z>/V(٤_-=n(Yܠ  5 q{"fvP.2p'L[jJ$LS&$ J^=Lh5^izrAԚ$N%D˿>Bc}Jmz"x3_" HL 9}7=^L"f32)h7%n_3/G,߀ 9.و co6e)7t@LCӗy5ebFL&rMvŔ! g]#F G*-_'4ڄRicܝ;*m~52b$r;?7M.%u >{jmUQPK/53FLAN YDC(tKrO5*,QAx}Ɛhh5WlID+3(<6fBHRdR/:l:cMewn2e-LK,xՃED\fwy˄"P|=EDNaAaWpt)bf9s`fBp?bU_lj:MdYF(J{ JޣFLP…o joz$):H/r j8ۿbpD$e A.Zl,2)X/qSF#f&).īrC@^[~L&v,Rbf.yfmk2 LD)G$#a DVEOz@F @3(WlR''4ͤK}%j&yfi`RcΣvtI&7`xJ!e;,CBɾSL #ն1蜊Ig8ޟ!yUơ8<eB:3ӊ9zm?j!dZ׶uGӈ\K]5f]2uH9r)Nn̈́G6o`=D)H[k})fN;_6ns#h&&.ɋ9d?j@ͤn& ϋpq@ͤk5H6fJ0)a3CGn1r4LPWZ8NMD9XKU*I137oLt59Dͯ3ܐܜ!3܅cXK#NLRxW{ ㏘t⡠NV7a4gŨ0C`9d`y7ј)6-`)#uOL8$_)H .E6!q3AEa}'Mf]xd$t/p4fWl&T91^ 9={n&~4a3Ln kxEJ6eK+f55E'QZo3|MA^1 |Kr)O]HR.PA vF23=ͷ̜rYt"@3A!'F7.5S9AL?^MVy=A't&|W;s(wI;T΅p9J3,fy2K4v&"(Bk08+, I+SЙxn9Cmg*Ɨ/<{5u/'+ 6M6sr|(a3aռ`Q_zP3Ґ'A鈩]]8AL;fp`nm*f.o%[la3ArNE_γ < ̓Q8Ogo4?ZXwW 6.ZӍLsn[ȻSmq3]̮ l[* "OgL)76DP%XEM!YCL\a@̤< "fn)]z LSkt<@jzXˤJ H-qK!1 Xթ V&,2)ʄ9 ey# J_e4:\˄g77rm,',˚N+˂ A̐(V"V4n&Z&)t ֝,^XG~X1oB*Chyx6?XA"p6H;' }3e(hN-T%2GMeY'MŸfX$ŷO7ݣ藴2)h<:m}=_lLUI$P%k{3V7r3S43QLL5۷,?V|fb]1IOS.dћ㞸,xeyl]GH,"xGIGeB# en)]uscʒGxLه KZYg/y4V2ǝxx1܋D̤jH 7QXqlKG6gx8~(¼ߞNDZ>"蠋̴'S0T9yŒV?s˻]h@joܜЕ<5ɁɎb 2 Cu&ܕn:o:lwuPHz`wJxm.N`2NjFW#5rׯGb,Q3I96hBL]{ܾAA.+4Snx)u lFwX,rܯH^Tﺕk&E̦H\uIT̗ #x2舝ybAHvH841I*K̭r 24G.-ݼ1TRS_.A̩3\bQ&ޓzdwLE!:n**ěǨq͛#vfWi1%] VLUZuCZPgB{l09M`ݪ-lJ?"xMR)F6|@43Us!D뇣? \C/Q범k,Zb]+Q7uD&P9>)п"RR^.jVK(s;94ZT tw(bCZ`l?gK崅tu?2oT˗ck&(g#V搯k5CF2$gMIkBn0@? ^&Dw?$\fʭHﴜ+'zB1%dRW 2n5GPNz"dfS`S\WH)ELխlj{:P|'y8h,A0ٽ5ki:CKByҹN4)(v?r< (K.58! :lAКX2ɫtBϔF-J lꍛ=S̤s l ʲ̽\mv]/eYݚR$mdPyʭ ^&(雓b$µMEZM22qŎKڴEH:szKP %V >%X撆s MpgəĆ:ruղ< <1ˤ'v9ފ8R@hW0c7u#<e/ӾX` Xf7{|9훅J@zK2dLEc̤VmK̐!&) b5V"f_)H#dfʔͧGPJ/Z%̵ֺRZP#+ Aa;d͍#1,d[L*@jہu7č=NP URy[&!6Zಚ d 4!U;IQfܡ /3EY81bwf⎣h&s(1M)'f57bNtv3(2*ubf6%^hgP)KOYís׺%d&[t{Gu3UaR\&k0*;eR{s.GDm"4+b۞IG"]$̨$ I5:jfe 9^&X&5o7 dX!2"^x/ۀOFݶ|`/Pi2SAEh \ ʵS@Z ]&'\&n˰iJLPB%TSZ/eJK!l gp̳1k s+ӅPw T(ςaKBbc/Wb_<G(  ;#ߦs)!vg߆\k/>HHHvg`9DBByƘֽ0 jEŸ;Sz? F$g_H4,^ Uw??N]?sR 1%R#(E@ o(Euݻ7^Z?^:쏿*^}K?~OL'M_JI(~C9k߃pӞ<o =lp~)㯾|j ??~^ =?qZ;4)=ݥ(p?~=h;cKճwsfzǿ﫩_1}'Z:u05?k?|/P>t4&Z?#hx^N!aʠ|V\ g^s4b`b ?ߎ@hMߟ;Sic?ݙJ)q g*5/Z忪 ;Gox$<pje[yfh~m=ہ!{gox\I'8#^k a?otk?~sZ='OZ{/JzfX|?kgd_hȬ( /Z??mY>c:D~GKLӏr ?DowH 2◌yc00u^N?˝`@evxܿ{ۿuD9:"o-x:?a7BRwN%4kc##^J_29endstream endobj 328 0 obj << /Filter /FlateDecode /Length 3155 >> stream xkoKfޏI0\[i?Apˮu:[')Qrfv; ,zp&ga_r_?ϣ/?[_{drÄa"ӽUo˽F?r"†W͋\A⏇Iغ"-Z챟ϔoTY͔kmPy7UBfqv!l49K hE1R/B֥!f5՜#f%`MqÁF\k蛿ςneL&4o\%M0 ܔU_h.{՜%b 7$C~ "!!I9Yoy1DȥU,HQz`4{B$1"l ,. F<]T^Re]ĪV+ۚ`[DмUE7@.FgL[t\]^ ƳODF .W|=E 5vP^v_}bϳzUmG)|Sz6} ?NوX0`k/" M*ա4OZSUtU/#B.5 x fRd?QvnR'eи4 rUֶ4Ul/4lTuծ1_ݥj. /(6`,20FS2njQ3Ԅnݬqk9 ,*p=QpV)46ɺ֤A=ÿG!#JY|f4A{SOw]MW0(F2 N(($JdV"u4lɓtP *CQ c2 kF8e|}p( 9$o}q8gv+`q,F7hQUF  $-ӢK:TU-6f-KP JzMSDköj:!_;޲tc`5ƺYp0I1 45¶rѩ9hR+6-^" ّs)dMԖLUT*B!vnSZ.FsYaF]U [ Z mJ'Y:J@<(K212NdEX4hȝc@QhztEAf-$o"E D+#n 96iViH' ]8fetbpM%L,[_NQ:Zp;#[W%Ri8Ye7tr+/)PFf Hrq$B5w[u+kYLZ15.z}96{Us ^j%|v,7y#,*.<.nbdΚ<H{Hru}>5çPU&@rUMwNi꠬bs#+4oNSi iA2 ÅKaήMD~^xNG[;?lT[ PVӻiǻwI'/тI),}CⓥL5Qڲu6ϙLYȁG韭w:zWפd|\Pbj:/͗F)?Agc?W'GlFN[?eW*W%t0L?ͥ2f/Afu5s=>ILfi pR#'N)ȋ5qڹTߥYJV᧿ hݓ-&_zoX2`'U2s9k,5bP8/X`ЏcѻV>n`!FM4^Myӈ9'|x2'a#O%'.f},YAoM6&o4SV]aRsqJ ?+%{ ''o0ݭ /ƻIT6t9-WSV4*T\(&%К(p<==efhd@>7X"8;yQ:OGk=z$齈P3} y3cm͓Bw? Ltpy>7^ڔcXBZBI:Lh[ pDέp| @.GaA5A9"Y;ȜG6O0R};w?Bt8 ) )  JvU!h4X VARpB=WEa,A3A=A)dDfU7ANK$+tr6eҲ``q#A;As im{hPWSx =S=NpÇo *ݔ*wźMMU!z*wG̫̓R~އ{-N_:~Or'P,XC֑m'Zö]uti}ҿ&yC;˺G~:XKNX1#~c=nu9c_%.k 4f]D$O#+ؒE@ /rl}wYGfendstream endobj 329 0 obj << /Filter /FlateDecode /Length 2041 >> stream xZr}G#U*a5K*~8.?)R\$|}zf;g ְ}7-_z1Zf҈F(N^GPP[i:j;,vtTU4*j>muFAUKڇr4Zd]uj5+_ dRA[WݒNiUM/IicDVS=K9$)%9|C:(GNiXF]]HDrNNb^eR1:aoVnIӦQivˤ!b0FA iq m0JU Jp7md ] ʨLIzm)GR'J䟉=Ҡcm\R}U"VwE0-yjˊ /s"_ƕǕxd~^q^wɵnعkyVt)e(|фW5-m5XX5m65P]@h48-~3F2 pʒVݫ=*~{68 n=c9T(Gh7:֞&mKz]-vE-cU:,izy%f豾јBd9Z f\ ~cyRQ{-2S&tyx}zcn[lwZm5!FKKڜsKOS \Zѵ y(@q|tv^>! hO,, )]N;ɟMn,r66ॣj+P&-t 'YC,]4tĪji$I_hg ŲtՄ)dhɐA) Ne†O;-MlACK4bj0aq4iםu_ci#,\S}^ GNpgwsx͂(7*I5'}BjMgnm7 ͧ&8m?Cbʌ2EcΦOe]4SEevSmVP0]LF~y;H߇mEfFiߓ",G?ѿˢ]K-E@۽2N{ƝvEu ,Hb:+iX<90Zv`y޻/w"\U.Y@Ʌx if7BQ Zi2;endstream endobj 330 0 obj << /Filter /FlateDecode /Length 2657 >> stream xn# fdq#>Jv629p*H(Z3]3S$E"!@*]5q>a']:lr>_x$YN +gOfi+8>6^ !{H(ҖܩU ם)'`^pVB'94 (i;I;W\Q|Z#1$=+T7 )0k&| 0!DK]e_# Wf{K٣7r9`\*}(/Dv{,;R5$#xSSrɠ²h}X^` mkЁĈV nb$/{#37󐮫x¾9T~.8|*ӯDl@4^jBlR\z8_h嗼<%WWqnokWG^jN eX7b7eI`HYvG4VG7|+H>H2;Ebܨ1 !R2-7sU%ǂh^fr8o7OKP}U qO>| 3U{E7\X?*z+e:QxA3yЂDhH dheK9+3@g醩$rύ 6+2 jHQsS@ r jMw1dp'}M:L4ޖ'9-G`>[81'endstream endobj 331 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 936 >> stream x_L[evIH6`^0A4"9醈bC[vzB7I`_XJ:(P ".C'zdwg4\Ljֻ{_^ )dʚWꏽ~'\ܛY@)"! ٘'Dr:譴;N/rM 犋K /fF+yVL#4xEnjMB{ig7zo,f;5V­bj?#Wci3BhjkEUTjЎ8@'/T,C)IUI?Ү)<)3W~hd}w ypCȠZ$VDn;u>wj>MBk>iZ%9݉(V?˥)W;ADK75b#^'i/ je._g6Eon8[ <1≷D@]tt|88%"+%J}T}}Ng vLђB6} D|C0Fcǟm {l㟜ఝ3vX~-ɶuW*-3[xCW _9./`ap;S۴'nRI\ M!IXH|$<0< VW0Vy~oU^Zmh2K0g|pmd59f*n̬j"OB} g>ή|L0OtT<\@ḵۑ8;P|_0ޖGV28E=|$ Q9]ښZ#cQ?&ƶS;72 ER**+,endstream endobj 332 0 obj << /Type /XRef /Length 291 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 333 /ID [<98fb73cb0d35a536998daaa13f22ed44><40ff95766c591932bc4adbe5fa3b516c>] >> stream xcb&F~0 $8JLmW켠L`4mrt%0Uܙ2*F6Af5-y DA$_(L/?A$k[ "ٙA0D: 6dZ6-,D-`VՀSq` K,v@5-`Hɣ Vs %`SlV|DrԃzlW4l`5`eY"! Rp2X'TQ 6BOAd^=g.X%|`?21ܿ0 endstream endobj startxref 268492 %%EOF deSolve/inst/CITATION0000644000176000001440000000214513503434211014013 0ustar ripleyuserscitHeader("To cite package 'deSolve' in publications use:") citEntry(entry="Article", title = "Solving Differential Equations in {R}: Package de{S}olve", author = personList(as.person("Karline Soetaert"), as.person("Thomas Petzoldt"), as.person("R. Woodrow Setzer")), journal = "Journal of Statistical Software", volume = "33", number = "9", pages = "1--25", year = "2010", CODEN = "JSSOBK", ISSN = "1548-7660", URL = "http://www.jstatsoft.org/v33/i09", DOI = "10.18637/jss.v033.i09", keywords = "ordinary differential equations, partial differential equations, differential algebraic equations, initial value problems, R, FORTRAN, C", textVersion = paste("Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer (2010).", "Solving Differential Equations in R: Package deSolve.", "Journal of Statistical Software, 33(9), 1--25.", "URL http://www.jstatsoft.org/v33/i09/", "DOI 10.18637/jss.v033.i09") )