[r-cran-gam] 02/20: Imported Upstream version 1.06.2
Andreas Tille
tille at debian.org
Fri Dec 16 14:32:10 UTC 2016
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository r-cran-gam.
commit a0347a55a8fb9537b787b742ef703a0df18592e4
Author: Andreas Tille <tille at debian.org>
Date: Fri Dec 16 13:32:20 2016 +0100
Imported Upstream version 1.06.2
---
DESCRIPTION | 17 +
INDEX | 14 +
MD5 | 89 ++
NAMESPACE | 20 +
R/all.wam.R | 87 ++
R/anova.gam.R | 10 +
R/anova.gamlist.R | 5 +
R/as.anova.R | 15 +
R/as.data.frame.lo.smooth.R | 23 +
R/assign.list.R | 6 +
R/deviance.default.R | 3 +
R/deviance.glm.R | 3 +
R/deviance.lm.R | 4 +
R/gam.R | 70 ++
R/gam.control.R | 27 +
R/gam.exact.R | 149 +++
R/gam.fit.R | 171 +++
R/gam.lo.R | 64 +
R/gam.match.R | 55 +
R/gam.nlchisq.R | 9 +
R/gam.random.R | 30 +
R/gam.s.R | 48 +
R/gam.scope.R | 20 +
R/gam.slist.R | 2 +
R/gam.sp.R | 51 +
R/gam.wlist.R | 2 +
R/gamlist.R | 7 +
R/gplot.R | 3 +
R/gplot.default.R | 23 +
R/gplot.factor.R | 66 +
R/gplot.list.R | 16 +
R/gplot.matrix.R | 32 +
R/gplot.numeric.R | 58 +
R/labels.gam.R | 3 +
R/lo.R | 58 +
R/lo.wam.R | 101 ++
R/na.gam.replace.R | 45 +
R/newdata.predict.gam.R | 66 +
R/onLoad.R | 3 +
R/plot.gam.R | 93 ++
R/plot.preplot.gam.R | 27 +
R/polylo.R | 70 ++
R/predict.gam.R | 64 +
R/preplot.gam.R | 97 ++
R/print.gam.R | 17 +
R/print.gamex.R | 7 +
R/print.summary.gam.R | 33 +
R/random.R | 13 +
R/s.R | 29 +
R/s.wam.R | 84 ++
R/step.gam.R | 206 +++
R/subset.smooth.R | 24 +
R/summary.gam.R | 99 ++
R/ylim.scale.R | 8 +
data/gam.data.RData | Bin 0 -> 4131 bytes
data/gam.newdata.RData | Bin 0 -> 201 bytes
data/kyphosis.RData | Bin 0 -> 737 bytes
inst/ratfor/linear.r | 2555 +++++++++++++++++++++++++++++++++++++
man/anova.gam.Rd | 67 +
man/gam-internal.Rd | 39 +
man/gam.Rd | 258 ++++
man/gam.control.Rd | 43 +
man/gam.data.Rd | 32 +
man/gam.exact.Rd | 50 +
man/kyphosis.Rd | 26 +
man/lo.Rd | 120 ++
man/na.gam.replace.Rd | 46 +
man/plot.gam.Rd | 94 ++
man/predict.gam.Rd | 95 ++
man/s.Rd | 89 ++
man/step.gam.Rd | 86 ++
src/Makevars | 2 +
src/Makevars.win | 1 +
src/backfit.f | 168 +++
src/backlo.f | 164 +++
src/bsplvd.f | 222 ++++
src/bvalue.f | 185 +++
src/bvalus.f | 14 +
src/linear.f | 2926 +++++++++++++++++++++++++++++++++++++++++++
src/lo.f | 234 ++++
src/loessc.c | 796 ++++++++++++
src/loessf.f | 2078 ++++++++++++++++++++++++++++++
src/modreg.h | 252 ++++
src/qsbart.f | 33 +
src/sbart.c | 758 +++++++++++
src/sgram.f | 143 +++
src/sinerp.f | 98 ++
src/splsm.f | 188 +++
src/sslvrg.f | 136 ++
src/stxwx.f | 65 +
90 files changed, 14409 insertions(+)
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..2035559
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,17 @@
+Package: gam
+Type: Package
+Title: Generalized Additive Models
+Date: 2011-12-05
+Version: 1.06.2
+Author: Trevor Hastie
+Description: Functions for fitting and working with generalized
+ additive models, as described in chapter 7 of "Statistical Models in
+ S" (Chambers and Hastie (eds), 1991), and "Generalized Additive
+ Models" (Hastie and Tibshirani, 1990).
+Maintainer: Trevor Hastie <hastie at stanford.edu>
+Depends: stats, splines
+Suggests: akima
+License: GPL-2
+Packaged: 2011-12-06 01:44:56 UTC; hastie
+Repository: CRAN
+Date/Publication: 2011-12-06 07:00:29
diff --git a/INDEX b/INDEX
new file mode 100644
index 0000000..f67f440
--- /dev/null
+++ b/INDEX
@@ -0,0 +1,14 @@
+gam Fit a generalized additive model
+lo local regression wrapper to be used in a gam formula
+s smoothing spline wrapper to be used in a gam formula
+plot.gam an interactive plotting function for gams
+predict.gam make predictions from a gam object
+step.gam stepwise model search with gam
+anova.gam compare the fits of a number of gam models
+summary.gam summary method for gam
+preplot.gam extracts the components from a gam in a plot-ready form
+gam.lo local regression smoother for gam, used by all.wam
+gam.s smoothing spline smoother for gam,used by all.wam
+na.gam.replace a missing value method that is helpful with gams
+gam.exact a wrapper for semiparametric gams producing exact standard errors
+gam.control control parameters for fitting gam models
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..6b99772
--- /dev/null
+++ b/MD5
@@ -0,0 +1,89 @@
+88414eb45ea6971765a99732c9f3ba98 *DESCRIPTION
+af77f82fb0aa5e383808c5f36aa47066 *INDEX
+105cd87b9c243fbe33aabf84cf2b3271 *NAMESPACE
+3f56ee7eddd13ec792f7c2150b1e1eca *R/all.wam.R
+8cc1439da83368b103fe32e3f659d7c2 *R/anova.gam.R
+650f5fcfc4615d93f8743f2a93e0204b *R/anova.gamlist.R
+c67ddb150e807c4a0ef77acf132c1021 *R/as.anova.R
+996bcecc62a9687cb77863e45830a000 *R/as.data.frame.lo.smooth.R
+69d4bccf3afc7a1a9fd2b5d8b2f60fec *R/assign.list.R
+24f8cb3be5bf4bc1739a45087826e78f *R/deviance.default.R
+0d38ab9b7f2639649afa27ee3ac9ffb6 *R/deviance.glm.R
+4ab8260f7666ffd65e9ef915fb245531 *R/deviance.lm.R
+60657ce607548e744477b5b157776116 *R/gam.R
+6f9d6d8a11d7b20d791233f1ed3445dc *R/gam.control.R
+4be1a4ec9218947bab2f6f708acbb03d *R/gam.exact.R
+52ac1d379ebc2189d982e3f86e62c8af *R/gam.fit.R
+bd96ac15ba688c863f09f0e632a411f2 *R/gam.lo.R
+946d0c85f06753f768700803d197c247 *R/gam.match.R
+526f48fabc38d73bef43169182a7051a *R/gam.nlchisq.R
+0825a9bc8c213e3ddfc262178239a48f *R/gam.random.R
+302811098b9e378092cbc12fd11cef0d *R/gam.s.R
+a6bc1a9e490a60aaa1d5d8d47b872c00 *R/gam.scope.R
+6ccfc23d8ade2bae10532a2f0d6ad683 *R/gam.slist.R
+1f8d4b4e6776250d0e4080e64a1273e9 *R/gam.sp.R
+c83f70ebeee69ffd30cb96bcabd2c2c7 *R/gam.wlist.R
+3145f500d12b60398d2bf36eb20973c9 *R/gamlist.R
+6bc9b975aa99176b8d021818760af91c *R/gplot.R
+f8026ded9300952fe6a9810e8bfeecdf *R/gplot.default.R
+55d310d740e82e36a69686600b331072 *R/gplot.factor.R
+4e843123d1fd91f5d2fea87e487f795d *R/gplot.list.R
+6f9f511873884b3b16bd995a3ec42086 *R/gplot.matrix.R
+5fc7caa79f441edc92935788f38444b2 *R/gplot.numeric.R
+9c06038289b4ccad8383f467b73ad06b *R/labels.gam.R
+093d17804fa5ce90f12cdeb4f9fbcf6a *R/lo.R
+f8e577af7d28bdf5252ef489f4cb824d *R/lo.wam.R
+901999a84e9e5db5552b706a99fcc303 *R/na.gam.replace.R
+a82abbfbf9d226c04290dd721e1d8b51 *R/newdata.predict.gam.R
+0b14c3fb8b9f3899d54b63cf090491ec *R/onLoad.R
+9229d04542aa65b686e6a44fc5e5eb52 *R/plot.gam.R
+07745ab717cea5503a96ccfbd3d66529 *R/plot.preplot.gam.R
+b0b4e3ea29649f25919a9b3b9a01886f *R/polylo.R
+8e6ec4cd97cfd239ae7ef53d3e39be85 *R/predict.gam.R
+4314caf8a4bc9da21bd847ea1322146c *R/preplot.gam.R
+87477db085b0209bab1a5fc82cca43be *R/print.gam.R
+ca3a618d4376069f1d43a2aabaea5e4c *R/print.gamex.R
+671e6f217888df1fb52aa3f5828c22e7 *R/print.summary.gam.R
+c318b1f9d34fda3e660a9af01b86c830 *R/random.R
+1478722abc4269fede0d572840c0cfbe *R/s.R
+596d38e0f6ec11d3921b0ee8bd3590a4 *R/s.wam.R
+addd48040c8374e5a9ed5d587cfe77e7 *R/step.gam.R
+9c1302d138d07b10f17c27765bd87955 *R/subset.smooth.R
+6dec63db9138e124e7535b79e82558ab *R/summary.gam.R
+5cc7658080bc925bb5fc11172d78fb41 *R/ylim.scale.R
+ba66638e3de17b868b4d98dffe95009d *data/gam.data.RData
+83529cbff37939aff8d96d32d6458f12 *data/gam.newdata.RData
+4df6bee1aa3bee402b8f1083dda04b04 *data/kyphosis.RData
+b1c5751278caefdae9c643f6dd3daded *inst/ratfor/linear.r
+ddba04cdcf5d2044919c08bcf71c7786 *man/anova.gam.Rd
+d39a839642a1ee2b71d93df9a41c62c5 *man/gam-internal.Rd
+ffbb793ebf7414ea69df18b384e40534 *man/gam.Rd
+5167ecd9baaea501d766f87b4e22cf20 *man/gam.control.Rd
+d3c27998fb1cdce4cb00703557f1138d *man/gam.data.Rd
+d39920b918d9a57b3ad4090658750e45 *man/gam.exact.Rd
+dd3553bd8578858873bd1384b000273a *man/kyphosis.Rd
+800542a98f81e40c0930605f288c9ca4 *man/lo.Rd
+5068084693ec99de54e0531a53d4e637 *man/na.gam.replace.Rd
+a79905d34d4d93cb9939329b7cc8f507 *man/plot.gam.Rd
+fe97676fb4413c259621109a5d78edac *man/predict.gam.Rd
+7f2b4a226c564121816e2594f7fd61c3 *man/s.Rd
+03718b63cb73f8be1d573ecca2c9a48f *man/step.gam.Rd
+f80de2889856cba0512e5377926af1aa *src/Makevars
+2fa4c7011c2bc0f7449ae151d5cc44ae *src/Makevars.win
+65a8e52762837be96db5d33cf8f859a7 *src/backfit.f
+819e82fd2b11f2acdda88efbf0a9fba0 *src/backlo.f
+10f91c907532cc70e76074ca47d14716 *src/bsplvd.f
+2cf888d1f6a6ca37a7211c7c6ab86c0e *src/bvalue.f
+40c1f6b57d6c3a03a1d972f009c5e5df *src/bvalus.f
+f8d84e4eab8700aa419a7aefd1a8ddd4 *src/linear.f
+85c9d000ac0b8cc1dc61a8bfa40f3ed2 *src/lo.f
+388f5201bdc80e4c25a575f4810915d6 *src/loessc.c
+425c0bc459b1dee59d08e5cd6c28d89c *src/loessf.f
+6ada085e39fd48968fcd79368c0ccddd *src/modreg.h
+e1c0a8ef61f04b6239ff2ea6874be92d *src/qsbart.f
+876032799d52ef84fb846af58939a318 *src/sbart.c
+82da999d24034505301e31c78d1e58cc *src/sgram.f
+d277bb97eef775673f5fa2da911d81de *src/sinerp.f
+362186247368f8550e59c0bf1cde8eb5 *src/splsm.f
+39a0d0a34a95130be92b075a49feac36 *src/sslvrg.f
+4f6275039d4731d4f2920fc3de5f61e7 *src/stxwx.f
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..f4163fc
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,20 @@
+useDynLib(gam)
+import(stats)
+importFrom(utils,head,tail,packageDescription)
+export(all.wam,anova.gamlist,as.anova,as.data.frame.lo.smooth,assign.list,deviance.default,deviance.glm,deviance.lm,gam,gam.control,gam.exact,gam.fit,gamlist,gam.lo,gam.match,gam.nlchisq,gam.random,gam.s,gam.scope,gam.slist,gam.sp,gam.wlist,gplot,gplot.default,gplot.factor,gplot.list,gplot.matrix,gplot.numeric,lo,lo.wam,na.gam.replace,newdata.predict.gam,plot.gam,polylo,predict.gam,random,s,s.wam,ylim.scale,step.gam,summary.gam)
+S3method("[",smooth)
+S3method(labels,gam)
+S3method(plot,gam)
+S3method(summary,gam)
+S3method(print,summary.gam)
+S3method(print,gamex)
+S3method(print,gam)
+S3method(predict,gam)
+S3method(plot,preplot.gam)
+S3method(plot,gam)
+S3method(preplot,gam)
+S3method(anova,gam)
+
+
+
+
diff --git a/R/all.wam.R b/R/all.wam.R
new file mode 100644
index 0000000..7956c79
--- /dev/null
+++ b/R/all.wam.R
@@ -0,0 +1,87 @@
+"all.wam" <-
+ function(x, y, w, s, which, smooth.frame, maxit = 30, tol = 1e-7, trace = FALSE,
+ se = TRUE, ...)
+{
+ if(inherits(smooth.frame, "data.frame")) {
+ data <- smooth.frame
+### Note; the lev component of the smooths is the diagonal hat matrix elements
+### for the NONLINEAR part of the fit.
+###The smoother can return both the linear and nonlinear parts, although only
+### the nonlinear part is strictly necessary.
+###
+ oldClass(data) <- NULL
+ names.calls <- names(which)
+ smooth.calls <- lapply(data[names.calls], attr, "call")
+ names(smooth.calls) <- names.calls
+ smooth.frame <- list(data = data, smooth.calls = smooth.calls)
+ }
+ else {
+ data <- smooth.frame$data
+ smooth.calls <- smooth.frame$smooth.calls
+ }
+ names.calls <- names(smooth.calls)
+ y <- as.vector(y)
+ residuals <- as.vector(y - s %*% rep(1., ncol(s)))
+ n <- length(y)
+ fit <- list(fitted.values = 0.)
+ rss <- weighted.mean(residuals^2., w)
+ rssold <- rss * 10.
+ nit <- 0.
+ df <- rep(NA, length(which))
+ var <- s
+ if(trace)
+ cat("\nWAM iter rss/n term\n")
+ ndig <- - log10(tol) + 1.
+ RATIO <- tol + 1.
+ while(RATIO > tol & nit < maxit) {
+ rssold <- rss
+ nit <- nit + 1.
+ z <- residuals + fit$fitted.values
+ fit <- lm.wfit(x, z, w, method = "qr", singular.ok = TRUE,
+ ...)
+ residuals <- fit$residuals
+ rss <- weighted.mean(residuals^2., w)
+ if(trace)
+ cat("\n ", nit, " ", format(round(rss, ndig)),
+ " Parametric -- lm.wfit\n", sep = "")
+ deltaf <- 0.
+ for(j in seq(names.calls)) {
+ old <- s[, j]
+ z <- residuals + s[, j]
+ fit.call <- eval(smooth.calls[[j]])
+ residuals <- as.double(fit.call$residuals)
+ if(length(residuals) != n)
+ stop(paste(names.calls[j],
+ "returns a vector of the wrong length")
+ )
+ s[, j] <- z - residuals
+ deltaf <- deltaf + weighted.mean((s[, j] - old)^2.,
+ w)
+ rss <- weighted.mean(residuals^2., w)
+ if(trace) {
+ cat(" ", nit, " ", format(round(
+ rss, ndig)), " Nonparametric -- ",
+ names.calls[j], "\n", sep = "")
+ }
+ df[j] <- fit.call$nl.df
+ if(se)
+ var[, j] <- fit.call$var
+ }
+ RATIO <- sqrt(deltaf/sum(w * apply(s, 1., sum)^2.))
+ if(trace)
+ cat("Relative change in functions:", format(round(
+ RATIO, ndig)), "\n")
+ }
+ if((nit == maxit) & maxit > 1.)
+ warning(paste("all.wam convergence not obtained in ", maxit,
+ " iterations"))
+ names(df) <- names.calls
+ if(trace)
+ cat("\n")
+ fit$fitted.values <- y - residuals
+ rl <- c(fit, list(smooth = s, nl.df = df))
+ rl$df.residual <- rl$df.residual - sum(df)
+ if(se)
+ rl <- c(rl, list(var = var))
+ c(list(smooth.frame = smooth.frame), rl)
+}
diff --git a/R/anova.gam.R b/R/anova.gam.R
new file mode 100644
index 0000000..d0a0282
--- /dev/null
+++ b/R/anova.gam.R
@@ -0,0 +1,10 @@
+"anova.gam" <-
+ function(object, ..., test = c("Chisq", "F", "Cp"))
+{
+ test=match.arg(test)
+ margs <- function(...)
+ nargs()
+ if(margs(...))
+ anova.glmlist(list(object, ...), test = test)
+ else summary.gam(object)$anova
+}
diff --git a/R/anova.gamlist.R b/R/anova.gamlist.R
new file mode 100644
index 0000000..e1306ae
--- /dev/null
+++ b/R/anova.gamlist.R
@@ -0,0 +1,5 @@
+"anova.gamlist" <-
+function(object, ..., test = c("none", "Chisq", "F", "Cp")){
+ test=match.arg(test)
+ anova.glmlist(object, test = test)
+}
diff --git a/R/as.anova.R b/R/as.anova.R
new file mode 100644
index 0000000..4879a6e
--- /dev/null
+++ b/R/as.anova.R
@@ -0,0 +1,15 @@
+"as.anova" <-
+ function(df, heading)
+{
+ if(!inherits(df, "data.frame"))
+ stop("df must be a data frame")
+ attr(df, "heading") <- heading
+ #if the "class" attribute of df already starts with "anova" return(df)
+ if(inherits(df, "anova")) {
+ dfClasses <- attr(df, "class")
+ if(dfClasses[1] == "anova")
+ return(df)
+ }
+ class(df) <- unique(c("anova", class(df)))
+ df
+}
diff --git a/R/as.data.frame.lo.smooth.R b/R/as.data.frame.lo.smooth.R
new file mode 100644
index 0000000..93c3088
--- /dev/null
+++ b/R/as.data.frame.lo.smooth.R
@@ -0,0 +1,23 @@
+"as.data.frame.lo.smooth" <-
+function(x, row.names = NULL, optional = FALSE,...)
+{
+ d <- dim(x)
+ nrows <- d[[1.]]
+ dn <- dimnames(x)
+ row.names <- dn[[1.]]
+ value <- list(x)
+ if(length(row.names)) {
+ row.names <- as.character(row.names)
+ if(length(row.names) != nrows)
+ stop(paste("supplied", length(row.names),
+ "names for a data frame with", nrows, "rows"))
+ }
+ else if(optional)
+ row.names <- character(nrows)
+ else row.names <- as.character(seq(length = nrows))
+ if(!optional)
+ names(value) <- deparse(substitute(x))[[1.]]
+ attr(value, "row.names") <- row.names
+ oldClass(value) <- "data.frame"
+ value
+}
diff --git a/R/assign.list.R b/R/assign.list.R
new file mode 100644
index 0000000..74cb2c1
--- /dev/null
+++ b/R/assign.list.R
@@ -0,0 +1,6 @@
+assign.list<-function(assignx,term.labels){
+ ass<-as.list(seq(term.labels))
+ names(ass)<-term.labels
+ indexset<-seq(along=assignx)
+ lapply(ass,function(i,indexset,assignx)indexset[assignx==i],indexset,assignx)
+}
diff --git a/R/deviance.default.R b/R/deviance.default.R
new file mode 100644
index 0000000..00fc4d5
--- /dev/null
+++ b/R/deviance.default.R
@@ -0,0 +1,3 @@
+"deviance.default" <-
+function(object, ...)
+object$deviance
diff --git a/R/deviance.glm.R b/R/deviance.glm.R
new file mode 100644
index 0000000..6766a19
--- /dev/null
+++ b/R/deviance.glm.R
@@ -0,0 +1,3 @@
+"deviance.glm" <-
+function(object, ...)
+object$deviance
diff --git a/R/deviance.lm.R b/R/deviance.lm.R
new file mode 100644
index 0000000..8dac1fe
--- /dev/null
+++ b/R/deviance.lm.R
@@ -0,0 +1,4 @@
+"deviance.lm" <-
+function(object, ...)
+if(is.null(w <- object$weights)) sum(object$residuals^2.) else sum(w * object$
+ residuals^2.)
diff --git a/R/gam.R b/R/gam.R
new file mode 100644
index 0000000..41292f2
--- /dev/null
+++ b/R/gam.R
@@ -0,0 +1,70 @@
+"gam" <-
+ function(formula, family = gaussian, data,
+ weights, subset, na.action, start = NULL, etastart, mustart, control = gam.control(...),
+ model = FALSE, method="glm.fit", x = FALSE, y = TRUE, ...)
+{
+ call <- match.call()
+ if (is.character(family))
+ family <- get(family, mode = "function", envir = parent.frame())
+ if (is.function(family))
+ family <- family()
+ if (is.null(family$family)) {
+ print(family)
+ stop("`family' not recognized")
+ }
+ if (missing(data))
+ data <- environment(formula)
+ mf <- match.call(expand.dots = FALSE)
+ m <- match(c("formula", "data", "subset", "weights", "na.action",
+ "etastart", "mustart", "offset"), names(mf), 0)
+ mf <- mf[c(1, m)]
+ mf$drop.unused.levels <- TRUE
+ mf[[1]] <- as.name("model.frame")
+ mt <- if(missing(data)) terms(formula, gam.slist) else terms(formula,gam.slist,data = data)
+ mf$formula<-mt
+ mf <- eval(mf, parent.frame())
+ switch(method, model.frame = return(mf), glm.fit = 1, glm.fit.null = 1,
+ stop("invalid `method': ", method))
+
+
+ Y <- model.response(mf, "any")
+ X <- if (!is.empty.model(mt))
+ model.matrix(mt, mf, contrasts)
+ else matrix(, NROW(Y), 0)
+ weights <- model.weights(mf)
+ offset <- model.offset(mf)
+ if (!is.null(weights) && any(weights < 0))
+ stop("Negative wts not allowed")
+ if (!is.null(offset) && length(offset) != NROW(Y))
+ stop("Number of offsets is ", length(offset), ", should equal ",
+ NROW(Y), " (number of observations)")
+ mustart <- model.extract(mf, "mustart")
+ etastart <- model.extract(mf, "etastart")
+fit<-gam.fit(x=X,y=Y,smooth.frame=mf,weights=weights,start=start,
+ etastart=etastart,mustart=mustart,
+ offset=offset,family=family,control=control)
+
+### If both an offset and intercept are present, iterations are needed to
+### compute the Null deviance; these are done here
+###
+ if(length(offset) && attr(mt, "intercept")>0) {
+ fit$null.dev <- glm.fit(x = X[, "(Intercept)", drop = FALSE],
+ y = Y, weights = weights, offset = offset, family = family,
+ control = control[c("epsilon","maxit","trace")], intercept = TRUE)$deviance
+ }
+ if(model) fit$model <- mf
+ fit$na.action <- attr(mf, "na.action")
+ if(x) fit$x <- X
+ if(!y) fit$y <- NULL
+ fit <- c(fit, list(call = call, formula = formula,
+ terms = mt, data = data,
+ offset = offset, control = control, method = method,
+ contrasts = attr(X, "contrasts"),
+ xlevels = .getXlevels(mt, mf)))
+ class(fit) <- c("gam","glm", "lm")
+ if(!is.null(fit$df.residual) && !(fit$df.residual > 0))
+ warning("Residual degrees of freedom are negative or zero. This occurs when the sum of the parametric and nonparametric degrees of freedom exceeds the number of observations. The model is probably too complex for the amount of data available."
+ )
+ fit
+}
+
diff --git a/R/gam.control.R b/R/gam.control.R
new file mode 100644
index 0000000..003f422
--- /dev/null
+++ b/R/gam.control.R
@@ -0,0 +1,27 @@
+"gam.control" <-
+function(epsilon = 9.9999999999999995e-08, bf.epsilon = 9.9999999999999995e-08,
+ maxit = 30, bf.maxit = 30, trace = FALSE, ...)
+{
+ if(epsilon <= 0) {
+ warning("the value of epsilon supplied is zero or negative; the default value of 1e-7 was used instead"
+ )
+ epsilon <- 9.9999999999999995e-08
+ }
+ if(maxit < 1) {
+ warning("the value of maxit supplied is too small; the default value of 30 was used instead"
+ )
+ maxit <- 30
+ }
+ if(bf.epsilon <= 0) {
+ warning("the value of bf.epsilon supplied is zero or negative; the default value of 1e-7 was used instead"
+ )
+ bf.epsilon <- 9.9999999999999995e-08
+ }
+ if(bf.maxit < 1) {
+ warning("the value of bf.maxit supplied is too small; the default value of 30 was used instead"
+ )
+ bf.maxit <- 30
+ }
+ list(epsilon = epsilon, maxit = maxit, bf.epsilon = bf.epsilon,
+ bf.maxit = bf.maxit, trace = as.logical(trace)[1])
+}
diff --git a/R/gam.exact.R b/R/gam.exact.R
new file mode 100644
index 0000000..df2d231
--- /dev/null
+++ b/R/gam.exact.R
@@ -0,0 +1,149 @@
+"gam.exact" <-
+function(gam.obj)
+### -----------------------------------------------------------------------------------
+### gam.exact is a method for the gam class.
+###
+### Computes the asymptotically exact variance-covariance matrix for the linear
+### terms in the model (except for the intercept).
+###
+### Note: Use of lo in the model formula is not allowed.
+###
+### Author: Aidan McDermott (AMcD)
+### Date: Mar 5, 2003
+###
+### Mar 28, 2003
+### Fixed single linear term models -- thanks to Tim Ramsay
+### April 17, 2006
+### Modified to work in R by Trevor Hastie
+###
+### See:
+###
+### [1] Issues in Semiparametric Regression: A Case Study of Time Series
+### Models in Air Pollution and Mortality,
+### Dominici F., McDermott A., Hastie T.J.,
+### Technical Report, Department of Biostatistics, Johns Hopkins University,
+### Baltimore, MD, USA.
+###
+### -----------------------------------------------------------------------------------
+ {
+
+ if ( is.na(match("gam",class(gam.obj))) ) {
+ stop("not a gam object")
+ }
+
+ nl.df <- gam.obj$nl.df
+ terms <- terms(gam.obj)
+ at.terms <- attributes(terms)
+
+ coef <- coef(gam.obj)
+
+ w <- gam.obj$weights
+ mu <- gam.obj$fitted.values
+ eta <- gam.obj$additive.predictors
+ y <- as.matrix(gam.obj$y)
+
+ family <- family(gam.obj)
+ mu.eta.val <- family$mu.eta(eta)
+ z <- eta + (y - mu)/mu.eta.val
+
+
+### Don't want lo in gam formula.
+### if ( length((at.terms$specials)$lo) > 0 ) {
+### stop("lo found in gam formula.")
+### }
+
+ X <- model.matrix(gam.obj)
+ Y <- as.matrix(gam.obj$y)
+
+### only take terms that survived the original gam call
+ names.coef <- names(coef)
+ has.intercept <- match("(Intercept)",names.coef)
+ if ( !is.na(has.intercept) ) names.coef <- names.coef[-has.intercept]
+ X <- X[,names.coef]
+ tnames <- dimnames(X)[[2]]
+ form <- "y~"
+ special.list <- c()
+### Replace the df with the actual df returned by gam.
+### Rewrite fromula to match names in X
+ for ( k in 1:length(tnames) ) {
+ if ( substring(tnames[k],1,2) == "s(" ) {
+ s.call <- match.call(s,parse(text=tnames[k]))
+ this.name <- as.name(paste("x",k,sep=""))
+
+ which <- match(tnames[k],names(nl.df))
+ if ( is.na(which) ) stop(paste("can't find df for term",tnames[k]))
+ this.df <- nl.df[which]+1
+
+ form <- paste(form,
+ "+s(",this.name,",df =",this.df,")")
+ special.list <- c(special.list,k)
+ }
+ else if ( substring(tnames[k],1,3) == "lo(" ) {
+ lname <- length(tnames[k])
+ if ( substring(tnames[k],lname,lname) == "1" ) tnames[k] <- substring(tnames[k],1,(lname-1))
+ if ( substring(tnames[k],lname,lname) == ")" ) {
+ lo.call <- match.call(lo,parse(text=tnames[k]))
+ this.name <- as.name(paste("x",k,sep=""))
+
+ lo.call[[2]] <- this.name
+ lo.call <- deparse(lo.call)
+ form <- paste(form,"+",lo.call)
+ }
+ special.list <- c(special.list,k)
+ }
+ else form <- paste(form,"+x",k,sep="")
+ }
+ mydat <- data.frame(cbind(Y,X))
+ names(mydat) <- c("y",paste("x",1:ncol(X),sep=""))
+
+ XX <- X
+ mydat[,"w"] <- w
+
+ Control <- gam.obj$call$control
+ if ( is.null(Control) ) {
+ call <- gam.obj$call
+ call[[1]] <- as.name("gam.control")
+ Control <- eval(call,sys.parent())
+ }
+
+ for ( k in 1:length(tnames) ) {
+ if ( substring(tnames[k],1,2) != "s(" & substring(tnames[k],1,3) != "lo(" ) {
+ this.var <- paste("x",k,sep="")
+ upd.form <- update(as.formula(form),paste(this.var,"~. -",this.var))
+
+ XX[,k] <- gam(formula=upd.form,data=mydat,family=gaussian,weight=w,
+ control=eval(Control))$fitted
+ }
+ }
+
+### Need to test we get some data
+ if ( length(X) == 0 ) stop("nothing to do")
+
+ X <- X[,-special.list,drop=FALSE]
+ sx <- XX[,-special.list,drop=FALSE]
+ swx <- w*sx
+
+ if ( length(X) == 0 ) stop("no linear terms in the model -- nothing to do")
+
+ A <- t(X) %*% ( w * X ) - t(X) %*% ( w * sx )
+ B <- t(X*w) - t(swx)
+ H <- solve(A) %*% B
+
+ beta <- H %*% z
+ varbeta <- (H * (1/w)) %*% t(H) * as.vector(summary(gam.obj)$dispersion)
+ se <- sqrt(diag(varbeta))
+
+ coef <- cbind(summary.glm(gam.obj)$coef,NA,NA,NA)
+ tab <- cbind(beta,se,beta/se,2*(1-pnorm(beta/se)))
+ coef[dimnames(tab)[[1]],c(5,6,7)] <- tab[,c(2,3,4)]
+
+ dimnames(coef) <- list(dimnames(coef)[[1]],
+ c(dimnames(coef)[[2]][1:4],
+ "A-exact SE","A-exact Z","A-exact P"))
+
+ out.object <- list(coefficients=coef,covariance=varbeta)
+ class(out.object) <- c("gamex")
+
+ return(out.object)
+ }
+
diff --git a/R/gam.fit.R b/R/gam.fit.R
new file mode 100644
index 0000000..de93d57
--- /dev/null
+++ b/R/gam.fit.R
@@ -0,0 +1,171 @@
+"gam.fit" <-
+ function (x, y, smooth.frame, weights = rep(1, nobs), start = NULL,
+ etastart = NULL, mustart = NULL, offset = rep(0, nobs), family = gaussian(),
+ control = gam.control())
+{
+ ynames <- if (is.matrix(y))
+ dimnames(y)[[1]]
+ else names(y)
+ xnames <- dimnames(x)[[2]]
+ nobs <- NROW(y)
+ nvars <- ncol(x)
+ maxit <- control$maxit
+ bf.maxit <- control$bf.maxit
+ epsilon <- control$epsilon
+ bf.epsilon <- control$bf.epsilon
+ trace <- control$trace
+ digits <- -log10(epsilon) + 1
+ if (is.null(weights))
+ weights <- rep.int(1, nobs)
+ if (is.null(offset))
+ offset <- rep.int(0, nobs)
+ variance <- family$variance
+ dev.resids <- family$dev.resids
+ aic <- family$aic
+ linkinv <- family$linkinv
+ mu.eta <- family$mu.eta
+ if (!is.function(variance) || !is.function(linkinv))
+ stop("illegal `family' argument")
+ valideta <- family$valideta
+ if (is.null(valideta))
+ valideta <- function(eta) TRUE
+ validmu <- family$validmu
+ if (is.null(validmu))
+ validmu <- function(mu) TRUE
+ eval(family$initialize)
+ if (is.null(mustart)) {
+ eval(family$initialize)
+ }
+ else {
+ mukeep <- mustart
+ eval(family$initialize)
+ mustart <- mukeep
+ }
+ eta <- if (!is.null(etastart))
+ etastart
+ else if (!is.null(start))
+ if (length(start) != nvars)
+ stop("Length of start should equal ", nvars, " and correspond to initial coefs for ",
+ deparse(xnames))
+ else {
+ coefold <- start
+ offset + as.vector(if (NCOL(x) == 1)
+ x * start
+ else x %*% start)
+ }
+ else family$linkfun(mustart)
+ mu <- linkinv(eta)
+ if (!(validmu(mu) && valideta(eta)))
+ stop("Can't find valid starting values: please specify some")
+ new.dev <- sum(dev.resids(y, mu, weights))
+ a <- attributes(attr(smooth.frame, "terms"))
+ smoothers <- a$specials
+ if (length(smoothers) > 0) {
+ smoothers <- smoothers[sapply(smoothers, length) > 0]
+ for (i in seq(along = smoothers)) {
+ tt <- smoothers[[i]]
+ ff <- apply(a$factors[tt, , drop = FALSE], 2, any)
+ smoothers[[i]] <- if (any(ff))
+ seq(along = ff)[a$order == 1 & ff]
+ else NULL
+ }
+ }
+ if (length(smoothers) > 0) {
+ smooth.labels <- a$term.labels[unlist(smoothers)]
+ assignx <- attr(x, "assign")
+ assignx <- assign.list(assignx, a$term.labels)
+ which <- assignx[smooth.labels]
+ if (length(smoothers) > 1)
+ bf <- "all.wam"
+ else {
+ sbf <- match(names(smoothers), gam.wlist, FALSE)
+ bf <- if (sbf)
+ paste(gam.wlist[sbf], "wam", sep = ".")
+ else "all.wam"
+ }
+ bf.call <- parse(text = paste(bf, "(x, z, wz, fit$smooth, which, fit$smooth.frame,bf.maxit,bf.epsilon, trace)",
+ sep = ""))[[1]]
+ s <- matrix(0, length(y), length(which))
+ dimnames(s) <- list(names(y), names(which))
+ fit <- list(smooth = s, smooth.frame = smooth.frame)
+ }
+ else {
+ bf.call <- expression(lm.wfit(x, z, wz, method = "qr",
+ singular.ok = TRUE))
+ bf <- "lm.wfit"
+ }
+ old.dev <- 10 * new.dev + 10
+ for (iter in 1:maxit) {
+ good <- weights > 0
+ varmu <- variance(mu)
+ if (any(is.na(varmu[good])))
+ stop("NAs in V(mu)")
+ if (any(varmu[good] == 0))
+ stop("0s in V(mu)")
+ mu.eta.val <- mu.eta(eta)
+ if (any(is.na(mu.eta.val[good])))
+ stop("NAs in d(mu)/d(eta)")
+ good <- (weights > 0) & (mu.eta.val != 0)
+ z <- eta - offset
+ z[good] <- z[good] + (y - mu)[good]/mu.eta.val[good]
+ wz <- weights
+ wz[!good] <- 0
+ wz[good] <- wz[good] * mu.eta.val[good]^2/varmu[good]
+ fit <- eval(bf.call)
+ eta <- fit$fitted.values + offset
+ mu <- linkinv(eta)
+ old.dev <- new.dev
+ new.dev <- sum(dev.resids(y, mu, weights))
+ if (trace)
+ cat("GAM ", bf, " loop ", iter, ": deviance = ",
+ format(round(new.dev, digits)), " \n", sep = "")
+ if (is.na(new.dev)) {
+ one.more <- FALSE
+ warning("iterations terminated prematurely because of singularities")
+ }
+ else one.more <- abs(old.dev - new.dev)/(old.dev + 0.1) >
+ epsilon
+ if (!one.more)
+ break
+ }
+ fitqr <- fit$qr
+ xxnames <- xnames[fitqr$pivot]
+ nr <- min(sum(good), nvars)
+ if (nr < nvars) {
+ Rmat <- diag(nvars)
+ Rmat[1:nr, 1:nvars] <- fitqr$qr[1:nr, 1:nvars]
+ }
+ else Rmat <- fitqr$qr[1:nvars, 1:nvars]
+ Rmat <- as.matrix(Rmat)
+ Rmat[row(Rmat) > col(Rmat)] <- 0
+ dimnames(Rmat) <- list(xxnames, xxnames)
+ names(fit$residuals) <- ynames
+ names(mu) <- ynames
+ names(eta) <- ynames
+ fit$additive.predictors <- eta
+ fit$fitted.values <- mu
+ names(fit$weights) <- ynames
+ names(fit$effects) <- c(xxnames[seq(len = fitqr$rank)], rep.int("",
+ sum(good) - fitqr$rank))
+ if (length(fit$smooth) > 0)
+ fit$smooth.frame <- smooth.frame[smooth.labels]
+ wtdmu <- if (a$intercept)
+ sum(weights * y)/sum(weights)
+ else linkinv(offset)
+ nulldev <- sum(dev.resids(y, wtdmu, weights))
+ n.ok <- nobs - sum(weights == 0)
+ nulldf <- n.ok - as.integer(a$intercept)
+ rank <- n.ok - fit$df.residual
+ aic.model <- aic(y, nobs, mu, weights, new.dev) + 2 * rank
+ if (!is.null(fit$smooth)) {
+ nonzeroWt <- (wz > 0)
+ nl.chisq <- gam.nlchisq(fit$qr, fit$residuals, wz, fit$smooth)
+ }
+ else nl.chisq <- NULL
+ fit <- c(fit, list(R = Rmat, rank = fitqr$rank, family = family,
+ deviance = new.dev, aic = aic.model, null.deviance = nulldev,
+ iter = iter, prior.weights = weights, y = y, df.null = nulldf,
+ nl.chisq = nl.chisq))
+ fit
+}
+
diff --git a/R/gam.lo.R b/R/gam.lo.R
new file mode 100644
index 0000000..ea94c67
--- /dev/null
+++ b/R/gam.lo.R
@@ -0,0 +1,64 @@
+"gam.lo" <-
+function(x, y, w = rep(1, length(y)), span = 0.5, degree = 1, ncols = p, xeval
+ = x)
+{
+ storage.mode(x) <- storage.mode(y) <- storage.mode(w) <- storage.mode(
+ span) <- "double"
+ storage.mode(degree) <- "integer"
+ if(is.null(np <- dim(x))) {
+ n <- as.integer(length(x))
+ p <- as.integer(1)
+ }
+ else {
+ np <- as.integer(np)
+ n <- np[1]
+ p <- np[2]
+ }
+ storage.mode(ncols) <- "integer"
+ o <- gam.match(x)
+ nef <- o$nef
+ nvmax <- as.integer(200 + 300 * (1 - 1/log(max(c(nef - 200, 3)))))
+ liv <- as.integer(50 + (2^ncols + 4) * nvmax + 2 * nef)
+ lv <- as.integer(50 + (3 * ncols + 3) * nvmax + nef + (ifelse(degree ==
+ 2, ((ncols + 2) * (ncols + 1))/2, ncols + 1) + 2) * (nef * span +
+ 1))
+ fit <- .Fortran("lo0",
+ x,
+ y,
+ w,
+ n,
+ ncols,
+ p,
+ nvmax,
+ span,
+ degree,
+ o$o,
+ nef,
+ df = double(1),
+ s = double(n),
+ var = double(n),
+ beta = double(p + 1),
+ iv = integer(liv),
+ liv,
+ lv,
+ v = double(lv),
+ integer(2*ncols),
+ double(nef * (p + ncols + 8) + 2 * p + n + 9),
+ PACKAGE="gam")
+ if(!missing(xeval)) {
+ storage.mode(xeval) <- "double"
+ m <- as.integer(dim(xeval)[1])
+ if(length(m) == 0)
+ m <- as.integer(length(xeval))
+ .Fortran("lowese",
+ fit$iv,
+ liv,
+ lv,
+ fit$v,
+ m,
+ xeval,
+ s = double(m),
+ PACKAGE="gam")$s - cbind(1, xeval) %*% fit$beta
+ }
+ else list(residuals = y - fit$s, var = fit$var, nl.df = fit$df)
+}
diff --git a/R/gam.match.R b/R/gam.match.R
new file mode 100644
index 0000000..151dca3
--- /dev/null
+++ b/R/gam.match.R
@@ -0,0 +1,55 @@
+"gam.match" <-
+function(x)
+{
+ if(is.list(x)) {
+ junk <- Recall(x[[1]])
+ if((nvar <- length(x)) == 1)
+ return(list(o = junk$o, nef = junk$nef))
+ else {
+ o <- matrix(junk$o, length(junk$o), nvar)
+ nef <- rep(junk$nef, nvar)
+ for(i in 2:nvar) {
+ junk <- Recall(x[[i]])
+ o[, i] <- junk$o
+ nef[i] <- junk$nef
+ }
+ names(nef) <- nn <- names(x)
+ dimnames(o) <- list(NULL, nn)
+ return(list(o = o, nef = nef))
+ }
+ }
+ if(is.matrix(x)) {
+ ats <- attributes(x)
+ a <- ats$NAs
+ ncols <- ats$ncols
+ d <- dim(x)
+ if(is.null(ncols))
+ ncols <- d[2]
+ if(ncols == 1)
+ return(Recall(structure(x[, 1, drop = TRUE], NAs = a)))
+ if(is.null(a)) {
+ o <- seq(d[1])
+ nef <- d[1]
+ }
+ else {
+ nef <- d[1] - length(a)
+ o <- rep(nef + 1, d[1])
+ o[ - a] <- seq(nef)
+ }
+ return(list(o = as.integer(o), nef = as.integer(nef)))
+ }
+ else {
+ a <- attributes(x)$NAs
+ if(!is.null(a))
+ x[a] <- NA
+ xr <- signif(as.vector(x), 6)
+ sx <- unique(sort(xr))
+ nef <- as.integer(length(sx))
+ if(nef <= 3)
+ stop("A smoothing variable encountered with 3 or less unique values; at least 4 needed"
+ )
+ o <- match(xr, sx, nef + 1)
+ o[is.na(o)] <- nef + 1
+ return(list(o = as.integer(o), nef = as.integer(nef)))
+ }
+}
diff --git a/R/gam.nlchisq.R b/R/gam.nlchisq.R
new file mode 100644
index 0000000..a9dddd9
--- /dev/null
+++ b/R/gam.nlchisq.R
@@ -0,0 +1,9 @@
+"gam.nlchisq" <-
+function(qr, resid, w, s)
+{
+ wt <- sqrt(w)
+ s <- s * wt
+ resid <- wt * resid
+ Rsw <- qr.resid(qr, s)
+ apply(Rsw^2 + 2 * s * resid, 2, sum)
+}
diff --git a/R/gam.random.R b/R/gam.random.R
new file mode 100644
index 0000000..6741dcd
--- /dev/null
+++ b/R/gam.random.R
@@ -0,0 +1,30 @@
+"gam.random" <-
+function(x, y, w, df = sum(non.zero), sigma = 0)
+{
+ df.inv <- function(n, df, sigma = sum(n)/df - mean(n), iterations = 10
+ )
+ {
+ if(df > length(n))
+ return(0)
+ current.df <- sum(n/(n + sigma))
+ if(abs((df - current.df)/df) < 0.0001 | iterations == 1)
+ sigma
+ else {
+ sigma <- exp(log(sigma) + (current.df - df)/(sum((
+ n * sigma)/(n + sigma)^2)))
+ Recall(n, df, sigma, iterations - 1)
+ }
+ }
+ nw <- tapply(w, x, sum)
+ non.zero <- !is.na(nw)
+ if(is.null(df))
+ df <- sum(non.zero)
+ if(sigma == 0)
+ sigma <- df.inv(nw[non.zero], df)
+ df <- sum(nw[non.zero]/(nw[non.zero] + sigma))
+ fit <- tapply(w * y, x, sum)/(nw + sigma)
+ var <- as.vector(w/(nw[x] + sigma))
+ residuals <- as.vector(y - fit[x])
+ list(x = seq(along = nw), y = fit, residuals = residuals, var = var,
+ nl.df = df, sigma = sigma)
+}
diff --git a/R/gam.s.R b/R/gam.s.R
new file mode 100644
index 0000000..5bc0e36
--- /dev/null
+++ b/R/gam.s.R
@@ -0,0 +1,48 @@
+"gam.s" <-
+ function(x, y, w = rep(1, length(x)), df = 4, spar = 1, xeval)
+{
+ storage.mode(x) <- storage.mode(y) <- storage.mode(w) <- storage.mode(
+ spar) <- storage.mode(df) <- "double"
+ n <- as.integer(length(x))
+ x <- signif(x, 6)
+ mat <- gam.match(x)
+ omat <- mat$o
+ nef <- mat$nef
+ ##
+ ## in rgam.r, splsm calls both splsm1 and splsm2.
+ ## splsm2 needs (10+2*4)*(nef+2)+5*nef+n+15 doubles for work.
+ ## splsm1 needs 3*nef+2*n+10.
+ work.len <- max(3 * nef + 2 * n + 10, (10 + 2 * 4) * (nef + 2) + 5 *
+ nef + n + 15)
+ fit <- .Fortran("splsm",
+ x,
+ y,
+ w,
+ n,
+ omat,
+ nef,
+ spar = spar,
+ df = df,
+ s = double(n),
+ s0 = double(1),
+ var = double(nef),
+ FALSE,
+ work = double(work.len),
+ PACKAGE="gam")
+ if(missing(xeval))
+ list(residuals = y - fit$s, nl.df = fit$df - 1, var = fit$
+ var[omat])
+ else {
+ skn <- .Fortran("sknotl",
+ fit$work[seq(nef)],
+ nef,
+ knot = double(nef + 6),
+ k = integer(1),
+ PACKAGE="gam")
+ smallest <- x[omat == 1][1]
+ largest <- x[omat == nef][1]
+ k <- skn$k
+ gam.sp(xeval, skn$knot[seq(k)], k - 4, fit$work[seq(3 * nef +
+ n + 10, length = k - 4)], smallest, largest - smallest)
+ }
+}
diff --git a/R/gam.scope.R b/R/gam.scope.R
new file mode 100644
index 0000000..5f10fd3
--- /dev/null
+++ b/R/gam.scope.R
@@ -0,0 +1,20 @@
+"gam.scope" <-
+function(frame, response = 1, smoother = "s", arg = NULL, form = TRUE)
+{
+ vnames <- names(frame)
+ vnames <- vnames[ - response]
+ step.list <- as.list(vnames)
+ names(step.list) <- vnames
+ for(vname in vnames) {
+ junk <- c("1", vname)
+ if(is.vector(frame[[vname]]))
+ junk <- c(junk, paste(smoother, "(", vname, if(is.null(
+ arg)) ")" else paste(",", arg, ")", sep = ""),
+ sep = ""))
+ if(form)
+ junk <- eval(parse(text = paste("~", paste(junk,
+ collapse = "+"))))
+ step.list[[vname]] <- junk
+ }
+ step.list
+}
diff --git a/R/gam.slist.R b/R/gam.slist.R
new file mode 100644
index 0000000..a98a91f
--- /dev/null
+++ b/R/gam.slist.R
@@ -0,0 +1,2 @@
+"gam.slist" <-
+c("s", "lo", "random")
diff --git a/R/gam.sp.R b/R/gam.sp.R
new file mode 100644
index 0000000..02d96a0
--- /dev/null
+++ b/R/gam.sp.R
@@ -0,0 +1,51 @@
+"gam.sp" <-
+function(x, knots, nknots, coef, smallest, scale)
+{
+ nas <- is.na(x)
+ xs <- as.double((x[!nas] - smallest)/scale)
+ bad.left <- xs < 0
+ bad.right <- xs > 1
+ good <- !(bad.left | bad.right)
+ y <- xs
+ if(any(good)) {
+ junk <- .Fortran("bvalus",
+ as.integer(sum(good)),
+ knots,
+ coef,
+ as.integer(nknots),
+ xs[good],
+ s = double(sum(good)),
+ as.integer(0),
+ PACKAGE="gam")
+ y[good] <- junk$s
+ }
+ if(any(!good)) {
+ end.fit <- .Fortran("bvalus",
+ as.integer(2),
+ knots,
+ coef,
+ as.integer(nknots),
+ as.double(c(0, 1)),
+ s = double(2),
+ as.integer(0),
+ PACKAGE="gam")$s
+ end.slopes <- .Fortran("bvalus",
+ as.integer(2),
+ knots,
+ coef,
+ as.integer(nknots),
+ as.double(c(0, 1)),
+ s = double(2),
+ as.integer(1),
+ PACKAGE="gam")$s
+ if(any(bad.left))
+ y[bad.left] <- end.fit[1] + end.slopes[1] * (xs[
+ bad.left])
+ if(any(bad.right))
+ y[bad.right] <- end.fit[2] + end.slopes[2] * (xs[
+ bad.right] - 1)
+ }
+ pred <- x * 0
+ pred[!nas] <- y
+ pred
+}
diff --git a/R/gam.wlist.R b/R/gam.wlist.R
new file mode 100644
index 0000000..1a71a07
--- /dev/null
+++ b/R/gam.wlist.R
@@ -0,0 +1,2 @@
+"gam.wlist" <-
+c("s","lo")
diff --git a/R/gamlist.R b/R/gamlist.R
new file mode 100644
index 0000000..9c6ae83
--- /dev/null
+++ b/R/gamlist.R
@@ -0,0 +1,7 @@
+"gamlist" <-
+function(...)
+{
+ gl <- list(...)
+ oldClass(gl) <- c("gamlist", "glmlist")
+ gl
+}
diff --git a/R/gplot.R b/R/gplot.R
new file mode 100644
index 0000000..33f39e0
--- /dev/null
+++ b/R/gplot.R
@@ -0,0 +1,3 @@
+"gplot" <-
+function(x, ...)
+UseMethod("gplot")
diff --git a/R/gplot.default.R b/R/gplot.default.R
new file mode 100644
index 0000000..578f627
--- /dev/null
+++ b/R/gplot.default.R
@@ -0,0 +1,23 @@
+"gplot.default" <-
+function(x, y, se.y = NULL, xlab = "", ylab = "", residuals = NULL, rugplot = FALSE,
+ scale = 0, se = FALSE, fit = TRUE, ...)
+switch(data.class(x)[1],
+ AsIs = { class(x)<-NULL
+ gplot.default(x , y = y, se.y = se.y, xlab = xlab,
+ ylab = ylab, residuals = residuals, rugplot = rugplot, scale =
+ scale, se = se, fit = fit, ...)
+ },
+ logical = gplot.factor(x = factor(x), y = y, se.y = se.y, xlab = xlab,
+ ylab = ylab, residuals = residuals, rugplot = rugplot, scale =
+ scale, se = se, fit = fit, ...),
+ list = gplot.list(x = x, y = y, se.y = se.y, xlab = xlab, ylab = ylab,
+ residuals = residuals, rugplot = rugplot, scale = scale, se =
+ se, fit = fit, ...),
+ if(is.numeric(x)) gplot.numeric(x = as.vector(x), y = y, se.y = se.y,
+ xlab = xlab, ylab = ylab, residuals = residuals,
+ rugplot = rugplot, scale = scale, se = se, fit = fit,
+ ...) else warning(paste("The \"x\" component of \"",
+ ylab, "\" has class \"", paste(class(x), collapse =
+ "\", \""), "\"; no gplot() methods available", sep = ""
+ )))
+
diff --git a/R/gplot.factor.R b/R/gplot.factor.R
new file mode 100644
index 0000000..19c1586
--- /dev/null
+++ b/R/gplot.factor.R
@@ -0,0 +1,66 @@
+"gplot.factor" <-
+function(x, y, se.y = NULL, xlab, ylab, residuals = NULL, rugplot = FALSE, scale =
+ 0, se = FALSE, xlim = NULL, ylim = NULL, fit = TRUE, ...)
+{
+ if(length(x) != length(y))
+ stop("x and y do not have the same length; possibly a consequence of an na.action"
+ )
+ nn <- as.numeric(table(x))
+ codex <- as.numeric(x)
+ ucodex <- seq(nn)[nn > 0]
+ o <- match(ucodex, codex, 0)
+ uy <- as.numeric(y[o])
+ ylim <- range(ylim, uy)
+ xlim <- range(c(0, sum(nn), xlim))
+ rightx <- cumsum(nn)
+ leftx <- c(0, rightx[ - length(nn)])
+ ux <- ((leftx + rightx)/2)
+ delta <- (rightx - leftx)/8
+ jx <- runif(length(codex), (ux - delta)[codex], (ux + delta)[codex])
+ nnajx <- jx[!is.na(jx)]
+ if(rugplot)
+ xlim <- range(c(xlim, nnajx))
+ if(se && !is.null(se.y)) {
+ se.upper <- uy + 2 * se.y[o]
+ se.lower <- uy - 2 * se.y[o]
+ ylim <- range(c(ylim, se.upper, se.lower))
+ }
+ if(!is.null(residuals)) {
+ if(length(residuals) == length(y)) {
+ residuals <- y + residuals
+ ylim <- range(c(ylim, residuals))
+ }
+ else {
+ residuals <- NULL
+ warning(paste("Residuals do not match x in \"", ylab,
+ "\" preplot object", sep = ""))
+ }
+ }
+ ylim <- ylim.scale(ylim, scale)
+ Levels <- levels(x)
+ if(!all(nn>0)) {
+ keep <- nn > 0
+ ux <- ux[keep]
+ delta <- delta[keep]
+ leftx <- leftx[keep]
+ rightx <- rightx[keep]
+ Levels <- Levels[keep]
+ }
+ plot(ux, uy, ylim = ylim, xlim = xlim, xlab = "", type = "n", ylab =
+ ylab, xaxt = "n", ...)
+ mtext(xlab, 1, 2)
+ axis(side = 3, at = ux - delta, labels = Levels, srt = 45, tick = FALSE,
+ adj = 0)
+ if(fit)
+ segments(leftx + delta, uy, rightx - delta, uy)
+ if(!is.null(residuals))
+ points(jx, residuals)
+ if(rugplot)
+ rug(nnajx)
+ if(se) {
+ segments(ux + delta, se.upper, ux - delta, se.upper)
+ segments(ux + delta, se.lower, ux - delta, se.lower)
+ segments(ux, se.lower, ux, se.upper, lty = 2)
+ }
+ invisible(diff(ylim))
+}
diff --git a/R/gplot.list.R b/R/gplot.list.R
new file mode 100644
index 0000000..3d8a94c
--- /dev/null
+++ b/R/gplot.list.R
@@ -0,0 +1,16 @@
+"gplot.list" <-
+function(x, y, se.y = NULL, xlab, ylab, residuals = NULL, rugplot = FALSE, scale =
+ 0, se = FALSE, fit = TRUE, ...)
+{
+ if(length(x) != 2) {
+ warning(paste("A perspective plot was requested for \"", ylab,
+ "\" but the \"x\" variable has dimension other than 2",
+ sep = ""))
+ invisible(return(0))
+ }
+ names(x) <- xlab
+ x <- data.matrix(data.frame(x))
+ # UseMethod("gplot")
+ gplot.matrix(x, y, se.y, xlab, ylab, residuals, rugplot, scale, se,
+ fit, ...)
+}
diff --git a/R/gplot.matrix.R b/R/gplot.matrix.R
new file mode 100644
index 0000000..61b2fda
--- /dev/null
+++ b/R/gplot.matrix.R
@@ -0,0 +1,32 @@
+"gplot.matrix" <-
+ function(x, y, se.y = NULL, xlab, ylab, residuals = NULL, rugplot = FALSE, scale =
+ 0, se = FALSE, fit, ...)
+{
+ if(ncol(x) != 2) {
+ warning(paste("A perspective plot was requested for \"", ylab,
+ "\" but the \"x\" variable has dimension other than 2",
+ sep = ""))
+ invisible(return(0))
+ }
+ bivar.dup <- function(x)
+ {
+ if(is.null(dx <- dim(x)) || dx[2] > 2)
+ stop("x must be bivariate")
+ duplicated(x[, 1] + (1i) * x[, 2])
+ }
+ interp.loaded<-require("akima")
+ if(!interp.loaded)stop("You need to install and load the package 'akima' from the R contributed libraries")
+ xname <- dimnames(x)[[2]]
+ dups <- bivar.dup(x)
+ xyz <- interp(x[!dups, 1], x[!dups, 2], y[!dups])
+ zmin <- min(xyz$z[!is.na(xyz$z)])
+ z <- ifelse(is.na(xyz$z), zmin, xyz$z)
+ scale2 <- diff(range(z))
+ # Adjust scale
+ scale <- max(scale, scale2)
+ # persp(xyz$x, xyz$y, (z - zmin)/scale, xlab = xname[1], ylab = xname[
+ # 2], zlab = ylab, ...)
+ persp(xyz$x, xyz$y, z, xlab = xname[1], ylab = xname[2], zlab = ylab,
+ ...)
+ invisible(scale)
+}
diff --git a/R/gplot.numeric.R b/R/gplot.numeric.R
new file mode 100644
index 0000000..408a059
--- /dev/null
+++ b/R/gplot.numeric.R
@@ -0,0 +1,58 @@
+"gplot.numeric" <-
+function(x, y, se.y = NULL, xlab, ylab, residuals = NULL, rugplot = FALSE, scale =
+ 0, se = FALSE, xlim = NULL, ylim = NULL, fit = TRUE, ...)
+{
+ if(length(x) != length(y))
+ stop("x and y do not have the same length; possibly a consequence of an na.action"
+ )
+### Here we check if its a simple linear term; if so, we include a point at the mean of x
+ if(se && !is.null(se.y) && ylab==paste("partial for",xlab)){
+ x=c(x,mean(x))
+ y=c(y,0)
+ se.y=c(se.y,0)
+ }
+ ux <- unique(sort(x))
+ o <- match(ux, x)
+ uy <- y[o]
+ xlim <- range(xlim, ux)
+ ylim <- range(ylim, uy)
+ if(rugplot) {
+ jx <- jitter(x[!is.na(x)])
+ xlim <- range(c(xlim, jx))
+ }
+ if(se && !is.null(se.y)) {
+ se.upper <- uy + 2 * se.y[o]
+ se.lower <- uy - 2 * se.y[o]
+ ylim <- range(c(ylim, se.upper, se.lower))
+ }
+ if(!is.null(residuals)) {
+ if(length(residuals) == length(y)) {
+ residuals <- y + residuals
+ ylim <- range(c(ylim, residuals))
+ }
+ else {
+ residuals <- NULL
+ warning(paste("Residuals do not match x in \"", ylab,
+ "\" preplot object", sep = ""))
+ }
+ }
+ ylim <- ylim.scale(ylim, scale)
+ if(!is.null(residuals)) {
+ plot(x, residuals, xlim = xlim, ylim = ylim, xlab = xlab, ylab
+ = ylab, ...)
+ if(fit)
+ lines(ux, uy)
+ }
+ else {
+ if(fit)
+ plot(ux, uy, type = "l", xlim = xlim, ylim = ylim,
+ xlab = xlab, ylab = ylab, ...)
+ }
+ if(rugplot)
+ rug(jx)
+ if(se) {
+ lines(ux, se.upper, lty = 3)
+ lines(ux, se.lower, lty = 3)
+ }
+ invisible(diff(ylim))
+}
diff --git a/R/labels.gam.R b/R/labels.gam.R
new file mode 100644
index 0000000..bf35812
--- /dev/null
+++ b/R/labels.gam.R
@@ -0,0 +1,3 @@
+labels.gam<-function(object,...){
+ attr(object$terms, "term.labels")
+ }
diff --git a/R/lo.R b/R/lo.R
new file mode 100644
index 0000000..0562f1c
--- /dev/null
+++ b/R/lo.R
@@ -0,0 +1,58 @@
+lo <-
+ function (..., span = 0.5, degree = 1)
+{
+ vars <- list(...)
+ locall <- sys.call()
+ chcall <- deparse(locall)
+ nvars <- length(vars)
+ if (degree > 2)
+ stop("degrees 1 or 2 are implemented")
+ if (nvars == 1) {
+ xvar <- as.matrix(vars[[1]])
+ xnames <- deparse(locall[[2]])
+ if(is.null(dimnames(xvar)[[2]])){
+ nc=ncol(xvar)
+ dxnames=xnames
+ if(nc>1)dxnames=paste(xnames,1:nc,sep=".")
+ dimnames(xvar)=list(NULL,dxnames)
+ }
+ }
+ else {
+ nobs <- length(vars[[1]])
+ xvar <- matrix(0, nobs, nvars)
+ xnames <- character(nvars)
+ for (i in seq(nvars)) {
+ tt <- vars[[i]]
+ if (!is.null(dd <- dim(tt)) && dd[2] > 1)
+ stop("either call lo with a matrix argument, or else a comma separated list x1, x2")
+ exptt <- locall[[i + 1]]
+ xnames[i] <- deparse(exptt)
+ xvar[, i] <- as.numeric(tt)
+ }
+ dimnames(xvar) <- list(NULL, xnames)
+ }
+
+ polyx <- polylo(xvar, degree = degree)
+ pd <- attr(polyx, "degree")
+ opd <- order(pd)
+ if (length(pd) > 1) {
+ polyx <- polyx[, opd]
+ p <- sum(pd == 1)
+ }
+ else p <- 1
+ nobs <- dim(polyx)[1]
+ nas <- is.na(polyx[, 1:p])
+ if (any(nas)) {
+ if (p > 1)
+ nas <- nas %*% array(1, c(p, 1))
+ attr(polyx, "NAs") <- seq(nobs)[nas > 0]
+ }
+ real.call <- substitute(gam.lo(data[[chcall]], z, w, span = span,
+ degree = degree, ncols = p), list(span = span, degree = degree,
+ chcall = chcall, p = p))
+ atts <- c(attributes(polyx), list(span = span, degree = degree,
+ ncols = p, call = real.call))
+ attributes(polyx) <- atts
+ class(polyx) <- c("smooth", "matrix")
+ polyx
+}
diff --git a/R/lo.wam.R b/R/lo.wam.R
new file mode 100644
index 0000000..8825c2c
--- /dev/null
+++ b/R/lo.wam.R
@@ -0,0 +1,101 @@
+"lo.wam" <-
+function(x, y, w, s, which, smooth.frame, maxit = 30, tol = 1e-7, trace = FALSE,
+ se = TRUE, ...)
+{
+ if(is.data.frame(smooth.frame)) {
+ first <- TRUE
+ # first call to wam; set up some things
+ #on first entry, smooth.frame is a data frame with elements the terms to be
+ #smoothed in which
+ data <- smooth.frame[, names(which), drop = FALSE]
+ smooth.frame <- gam.match(data)
+ dx <- as.integer(dim(x))
+ oldClass(data) <- NULL
+ atts <- lapply(data, attributes)
+ span <- sapply(atts, "[[", "span")
+ degree <- sapply(atts, "[[", "degree")
+ nvars <- sapply(atts, "[[", "ncols")
+ ndim <- sapply(atts, "[[", "dim")[2., ]
+ npetc <- as.integer(c(dx, length(which), 0., maxit, 0.))
+ nef <- smooth.frame$nef
+ nvmax <- 200. + 300. * (1. - 1./log(apply(cbind(nef - 200.,
+ 3.), 1., max)))
+ nspar <- (nef * span + 1.)
+ liv <- 50. + (2.^nvars + 4.) * nvmax + 2. * nef
+ lv <- 50. + (3. * nvars + 3.) * nvmax + nef + (ifelse(degree ==
+ 2., ((nvars + 2.) * (nvars + 1.))/2., nvars + 1.) +
+ 2.) * nspar
+ LL <- nspar * nvmax
+ liv <- liv + LL
+ lv <- lv + (nvars + 1.) * LL
+ which <- sapply(which, "[", 1.)
+ wddnfl <- cbind(unlist(which), nvars, ndim, degree, nef, liv,
+ lv, nvmax)
+ storage.mode(wddnfl) <- "integer"
+ spatol <- as.double(c(span, tol))
+ nwork <- 9. * dx[1.] + sum(nef * (nvars + ndim + 4.) + 5. +
+ 3. * ndim)
+ liv <- sum(liv)
+ lv <- sum(lv)
+ smooth.frame <- c(smooth.frame, list(npetc = npetc, wddnfl =
+ wddnfl, spatol = spatol,niwork=2*sum(nvars), nwork = nwork, liv = liv,
+ lv = lv))
+ }
+ else first <- FALSE
+ storage.mode(y) <- "double"
+ storage.mode(w) <- "double"
+ n <- smooth.frame$npetc[1.]
+ p <- smooth.frame$npetc[2.]
+ q <- smooth.frame$npetc[3.]
+ fit <- .Fortran("baklo",
+ x,
+ y = y,
+ w = w,
+ npetc = smooth.frame$npetc,
+ smooth.frame$wddnfl,
+ smooth.frame$spatol,
+ smooth.frame$o,
+ etal = double(n),
+ s = s,
+ eta = double(n),
+ beta = double(p),
+ var = s,
+ df = double(q),
+ qr = x,
+ qraux = double(p),
+ qpivot = as.integer(1.:p),
+ effects=double(n),
+ integer(smooth.frame$liv),
+ double(smooth.frame$lv),
+ integer(smooth.frame$niwork),
+ double(smooth.frame$nwork),
+ PACKAGE="gam")
+
+ nit <- fit$npetc[4.]
+ qrank <- fit$npetc[6.]
+ if((nit == maxit) & maxit > 1.)
+ warning(paste("lo.wam convergence not obtained in ", maxit,
+ " iterations"))
+ names(fit$df) <- dimnames(s)[[2]]
+ names(fit$beta) <- labels(x)[[2]]
+ qrx <- structure(list(qr = fit$qr,qraux = fit$qraux,
+ rank = qrank, pivot = fit$qpivot,tol=1e-7),class="qr")
+ effects<-fit$effects
+ r1 <- seq(len = qrx$rank)
+ dn <- colnames(x)
+ if (is.null(dn))
+ dn <- paste("x", 1:p, sep = "")
+ names(effects) <- c(dn[qrx$pivot[r1]], rep.int("", n - qrx$rank))
+ rl <- list(coefficients = fit$beta, residuals = fit$y - fit$eta,
+ fitted.values = fit$eta,
+ effects=effects, weights=w, rank=qrank,
+ assign=attr(x,"assign"),
+ qr=qrx,
+ smooth = fit$s,
+ nl.df = fit$df
+ )
+ rl$df.residual <- n - qrank - sum(rl$nl.df) - sum(fit$w == 0.)
+ if(se)
+ rl <- c(rl, list(var = fit$var))
+ c(list(smooth.frame = smooth.frame), rl)
+}
diff --git a/R/na.gam.replace.R b/R/na.gam.replace.R
new file mode 100644
index 0000000..f9de2c8
--- /dev/null
+++ b/R/na.gam.replace.R
@@ -0,0 +1,45 @@
+"na.gam.replace" <-
+function(frame)
+{
+ vars <- names(frame)
+ if(!is.null(resp <- attr(attr(frame, "terms"), "response"))) {
+ vars <- vars[ - resp]
+ x <- frame[[resp]]
+ pos <- is.na(x)
+ if(any(pos)) {
+ frame <- frame[!pos, , drop = FALSE]
+ warning(paste(sum(pos),
+ "observations omitted due to missing values in the response"
+ ))
+ }
+ }
+ for(j in vars) {
+ x <- frame[[j]]
+ pos <- is.na(x)
+ if(any(pos)) {
+ if(length(levels(x))) {
+ xx <- as.character(x)
+ xx[pos] <- "NA"
+ x <- factor(xx, exclude = NULL)
+ }
+ else if(is.matrix(x)) {
+ ats <- attributes(x)
+ w <- !pos
+ x[pos] <- 0
+ n <- nrow(x)
+ TT <- array(1, c(1, n))
+ xbar <- (TT %*% x)/(TT %*% w)
+ xbar <- t(TT) %*% xbar
+ x[pos] <- xbar[pos]
+ attributes(x) <- ats
+ }
+ else {
+ ats <- attributes(x)
+ x[pos] <- mean(x[!pos])
+ attributes(x) <- ats
+ }
+ frame[[j]] <- x
+ }
+ }
+ frame
+}
diff --git a/R/newdata.predict.gam.R b/R/newdata.predict.gam.R
new file mode 100644
index 0000000..37a9d9b
--- /dev/null
+++ b/R/newdata.predict.gam.R
@@ -0,0 +1,66 @@
+"newdata.predict.gam" <-
+ function(object, newdata, type = c("link", "response", "terms"), dispersion=NULL, se.fit = FALSE, na.action=na.pass,terms=labels(object), ...)
+{
+ out.attrs <- attr(newdata, "out.attrs")
+ is.gam<-inherits(object, "gam") && !is.null(object$smooth)
+ if(is.gam) {
+ if(se.fit){
+ se.fit<-FALSE
+ warning("No standard errors (currently) for gam predictions with newdata")
+ }
+ ##First get the linear predictions
+ type <- match.arg(type)
+ local.type<-type
+ if(type=="response")local.type<-"link"
+ pred<-predict.glm(object,newdata,type=local.type,dispersion=dispersion,se.fit=FALSE,terms=terms)
+ ##Build up the smooth.frame for the new data
+ tt <- terms(object)
+ Terms <- delete.response(tt)
+ smooth.frame <- model.frame(Terms, newdata, na.action = na.action,
+ xlev = object$xlevels)
+ nrows<-nrow(smooth.frame)
+ old.smooth<-object$smooth
+ data<-object$smooth.frame # this was the old smooth frame
+ smooth.labels<-names(data)
+ n.smooths<-length(smooth.labels)
+ if (!is.null(cl <- attr(Terms, "dataClasses")))
+ .checkMFClasses(cl, smooth.frame)
+ out.attrs <- attr(newdata, "out.attrs")
+
+
+ w <- object$weights
+ pred.s <- array(0, c(nrows, n.smooths), list(row.names(smooth.frame),
+ smooth.labels))
+ smooth.wanted <- smooth.labels[match(smooth.labels, terms,
+ 0) > 0]
+ pred.s<-pred.s[,smooth.wanted,drop=FALSE]
+ residuals <- object$residuals
+ for(TT in smooth.wanted) {
+ Call <- attr(data[[TT]], "call")
+ Call$xeval <- substitute(smooth.frame[[TT]], list(TT = TT))
+ z <- residuals + object$smooth[, TT]
+ pred.s[, TT] <- eval(Call)
+ }
+ if(type == "terms")
+ pred[, smooth.wanted] <- pred[, smooth.wanted] + pred.s[
+ , smooth.wanted]
+ else pred <- pred + rowSums(pred.s)
+ if(type == "response") {
+ famob <- family(object)
+ pred <- famob$linkinv(pred)
+ }
+ }
+ else {
+ pred<-predict.glm(object,newdata,type=type,dispersion=dispersion,se.fit=se.fit,terms=terms)
+ }
+ if(type != "terms" && !is.null(out.attrs)) {
+ if(!is.null(out.attrs)) {
+ if(se.fit) {
+ attributes(pred$fit) <- out.attrs
+ attributes(pred$se.fit) <- out.attrs
+ }
+ else attributes(pred) <- out.attrs
+ }
+ }
+pred
+}
diff --git a/R/onLoad.R b/R/onLoad.R
new file mode 100644
index 0000000..f637676
--- /dev/null
+++ b/R/onLoad.R
@@ -0,0 +1,3 @@
+.onLoad=function(libname,pkgname){
+ packageStartupMessage("Loaded gam ", as.character(packageDescription("gam")[["Version"]]),"\n")
+}
diff --git a/R/plot.gam.R b/R/plot.gam.R
new file mode 100644
index 0000000..35e2638
--- /dev/null
+++ b/R/plot.gam.R
@@ -0,0 +1,93 @@
+"plot.gam" <-
+ function(x, residuals = NULL, rugplot = TRUE, se = FALSE, scale = 0, ask = FALSE,
+terms=labels.gam(x), ...)
+{
+
+ if(!is.null(x$na.action))
+ x$na.action <- NULL
+ preplot.object <- x$preplot
+ if(is.null(preplot.object))
+ preplot.object <- preplot.gam(x,terms=terms)
+ x$preplot <- preplot.object
+ Residuals <- resid(x)
+ if(!is.null(residuals)) {
+ if(length(residuals) == 1)
+ if(residuals)
+ residuals <- Residuals
+ else residuals <- NULL
+ else Residuals <- residuals
+ }
+ if(!ask) {
+ plot.preplot.gam(preplot.object, residuals = residuals, rugplot
+ = rugplot, scale = scale, se = se, fit = TRUE, ...)
+ invisible(x)
+ }
+ else{
+ nterms <- names(preplot.object)
+ tterms <- substring(nterms, 1, 40)
+ #truncate long names
+ residualsmenu <- if(!is.null(residuals)) "residuals off" else
+ "residuals on"
+ rugmenu <- if(rugplot) "rug off" else "rug on"
+ semenu <- if(se) "se off" else "se on"
+ scalemenu <- paste("scale (", round(scale, 1), ")", sep = "")
+ scales <- numeric()
+ tmenu <- c(paste("plot:", tterms), "plot all terms", residualsmenu,
+ rugmenu, semenu, scalemenu)
+ tnames <- character()
+ pick <- 1
+ while(pick > 0 && pick <= length(tmenu)) {
+ pick <- menu(tmenu, title =
+ "Make a plot selection (or 0 to exit):\n")
+ if(pick > 0 && pick <= length(nterms)) {
+ tscale <- plot.preplot.gam(preplot.object[[pick]],
+ residuals = residuals, rugplot = rugplot, scale
+ = scale, se = se, fit = TRUE, ...)
+ names(tscale) <- nterms[pick]
+ scales <- c(scales, tscale)
+ cat("Plots performed:\n ")
+ print(scales)
+ }
+ else switch(pick - length(nterms),
+ {
+ scales <- plot.preplot.gam(
+ preplot.object, residuals =
+ residuals, rugplot = rugplot,
+ scale = scale, se = se, fit =
+ TRUE, ...)
+ print(scales)
+ }
+ ,
+ {
+ residuals <- if(is.null(residuals))
+ Residuals else NULL
+ residualsmenu <- if(!is.null(residuals)
+ ) "residuals off" else
+ "residuals on"
+ }
+ ,
+ {
+ rugplot <- !rugplot
+ rugmenu <- if(rugplot) "rug off" else
+ "rug on"
+ }
+ ,
+ {
+ se <- !se
+ semenu <- if(se) "se off" else "se on"
+ }
+ ,
+ {
+ cat("Type in a new scale\n")
+ scale <- eval(parse(n=1))
+ scalemenu <- paste("scale (", round(
+ scale, 1), ")", sep = "")
+ }
+ ,
+ invisible(return(x)))
+ tmenu <- c(paste("plot:", tterms), "plot all terms",
+ residualsmenu, rugmenu, semenu, scalemenu)
+ }
+ invisible(x)
+ }
+}
diff --git a/R/plot.preplot.gam.R b/R/plot.preplot.gam.R
new file mode 100644
index 0000000..d2d0a44
--- /dev/null
+++ b/R/plot.preplot.gam.R
@@ -0,0 +1,27 @@
+"plot.preplot.gam" <-
+function(x, y = NULL, residuals = NULL, rugplot = TRUE, se = FALSE, scale = 0, fit = TRUE,
+ ...)
+{
+ listof <- inherits(x[[1]], "preplot.gam")
+ if(listof) {
+ TT <- names(x)
+ scales <- rep(0, length(TT))
+ names(scales) <- TT
+ for(i in TT)
+ scales[i] <- plot.preplot.gam(x[[i]], y = NULL,
+ residuals, rugplot, se, scale, fit, ...)
+ # scales[i] <- UseMethod("plot",x[[i]])
+ invisible(scales)
+ }
+ else {
+ dummy <- function(residuals = NULL, rugplot = TRUE, se = FALSE, scale
+ = 0, fit = TRUE, ...)
+ c(list(residuals = residuals, rugplot = rugplot, se = se, scale
+ = scale, fit = fit), list(...))
+ d <- dummy(residuals, rugplot, se, scale, fit, ...)
+ uniq.comps <- unique(c(names(x), names(d)))
+ Call <- c(as.name("gplot"), c(d, x)[uniq.comps])
+ mode(Call) <- "call"
+ invisible(eval(Call))
+ }
+}
diff --git a/R/polylo.R b/R/polylo.R
new file mode 100644
index 0000000..c826f2b
--- /dev/null
+++ b/R/polylo.R
@@ -0,0 +1,70 @@
+polylo <-
+ function (x, degree = 1, monomial = FALSE)
+{
+ if (degree >= 4)
+ warning("This is not a smart polynomial routine. You may get numerical problems with a degree of 4 or more")
+ x <- as.matrix(x)
+ dn <- dimnames(x)
+ dd <- dim(x)
+ np <- dd[2]
+ ad <- rep(1, ncol(x))
+### Used to have a x=scale(x)
+### That messed up predictions on new data
+### So we remove it
+### x=scale(x)
+ if (np == 1)
+ monomial <- TRUE
+ if (degree > 1) {
+ if (monomial) {
+ ad <- seq(degree)
+ px <- x
+ cc <- sapply(split(paste(diag(np)), rep(seq(np),
+ rep(np, np))), paste, collapse = "")
+ tx <- x
+ for (i in 2:degree) {
+ px <- px * tx
+ x <- cbind(x, px)
+ cc <- c(cc, sapply(split(paste(diag(np) * i),
+ rep(seq(np), rep(np, np))), paste, collapse = ""))
+ }
+ }
+ else {
+ matarray <- array(x, c(dd, degree))
+ for (i in 2:degree) matarray[, , i] <- x^i
+ matarray <- aperm(matarray, c(1, 3, 2))
+ x <- matarray[, , np, drop=TRUE]
+ ad0 <- seq(degree)
+ ad <- ad0
+ ncol.mat0 <- degree
+ ncol.x <- degree
+ d0 <- paste(ad0)
+ cc <- d0
+ for (ii in seq(np - 1, 1)) {
+ index0 <- rep(seq(ncol.mat0), ncol.x)
+ index <- rep(seq(ncol.x), rep(ncol.mat0, ncol.x))
+ newad <- ad0[index0] + ad[index]
+ retain <- newad <= degree
+ mat0 <- matarray[, , ii, drop = TRUE]
+ if (any(retain))
+ newmat <- mat0[, index0[retain]] *
+ x[, index[retain]]
+ else newmat <- NULL
+ ddn <- paste(d0[index0[retain]], cc[index[retain]],
+ sep = "")
+ zeros <- paste(rep(0, nchar(cc[1])), collapse = "")
+ cc <- paste(0, cc, sep = "")
+ d00 <- paste(d0, zeros, sep = "")
+ x <- cbind(mat0, x, newmat)
+ cc <- c(d00, cc, ddn)
+ ad <- c(ad0, ad, newad[retain])
+ ncol.x <- length(ad)
+ }
+ }
+ if (!is.null(dn))
+ dn[[2]] <- cc
+ else dn <- list(NULL, cc)
+ dimnames(x) <- dn
+ }
+ attr(x, "degree") <- ad
+ x
+}
diff --git a/R/predict.gam.R b/R/predict.gam.R
new file mode 100644
index 0000000..6f8c764
--- /dev/null
+++ b/R/predict.gam.R
@@ -0,0 +1,64 @@
+"predict.gam" <-
+ function(object, newdata, type = c("link", "response", "terms"), dispersion=NULL, se.fit = FALSE, na.action=na.pass, terms = labels(object),...)
+{
+ type <- match.arg(type)
+ if(missing(newdata)) {
+ if(inherits(object, "gam") && !is.null(object$smooth)) {
+ if(se.fit)
+ switch(type,
+ response = {
+ out <- predict.gam(object,
+ type = "link", se.fit
+ = TRUE, ...)
+ famob <- family(object)
+ out$se.fit <- drop(out$se.fit*abs(famob$mu.eta(out$fit)))
+ out$fit <- fitted(object)
+ out
+ }
+ ,
+ link = {
+ out <- NextMethod("predict")
+ out$fit <- object$additive.predictors
+ TS <- out$residual.scale^2
+ TT <- ncol(object$var)
+ out$se.fit <- sqrt(out$se.fit^
+ 2 + TS * object$var %*%
+ rep(1, TT))
+ out
+ }
+ ,
+ terms = {
+ out <- NextMethod("predict")
+ TT <- dimnames(s <- object$smooth)[[2]]
+ out$fit[, TT] <- out$fit[,
+ TT] + s
+ TS <- out$residual.scale^2
+ out$se.fit[, TT] <- sqrt(out$
+ se.fit[, TT]^2 + TS *
+ object$var)
+ out
+ }
+ )
+ else switch(type,
+ terms = {
+ out <- NextMethod("predict")
+ TT <- dimnames(s <- object$smooth)[[2]]
+ out[, TT] <- out[, TT] + s
+ out
+ }
+ ,
+ link = object$additive.predictors,
+
+ response = object$fitted)
+ }
+ else {
+ if(inherits(object, "gam")) {
+ if(type == "link" && !se.fit)
+ object$additive.predictors
+ else NextMethod("predict")
+ }
+ else UseMethod("predict")
+ }
+ }
+ else newdata.predict.gam(object, newdata, type, dispersion,se.fit, na.action, terms, ...)
+}
diff --git a/R/preplot.gam.R b/R/preplot.gam.R
new file mode 100644
index 0000000..8dc96b4
--- /dev/null
+++ b/R/preplot.gam.R
@@ -0,0 +1,97 @@
+"preplot.gam" <-
+ function(object, newdata, terms = labels.gam(object),...)
+{
+ ## this labels.gam above is because there does not seem to be a label method for glms
+ Terms <- object$terms
+ a <- attributes(Terms)
+ Call <- object$call
+ all.terms <- labels(Terms)
+ xvars <- parse(text=all.terms)
+ names(xvars) <- all.terms
+ terms <- sapply(terms,match.arg, all.terms)
+ Interactions <- a$order > 1
+ if(any(Interactions)) {
+ all.terms <- all.terms[!Interactions]
+ TM <- match(terms, all.terms, 0)
+ if(!all(TM)) {
+ terms <- terms[TM > 0]
+ warning("No terms saved for \"a:b\" style interaction terms"
+ )
+ }
+ }
+ xvars <- xvars[terms]
+ xnames <- as.list(terms)
+ names(xnames) <- terms
+ modes <- sapply(xvars, mode)
+ for(term in terms[modes != "name"]) {
+ evars <- all.names(xvars[term], functions = FALSE, unique = TRUE)
+ if(!length(evars))
+ next
+ xnames[[term]] <- evars
+ evars <- parse(text = evars)
+ if(length(evars) == 1)
+ evars <- evars[[1]]
+ else {
+ evars <- c(as.name("list"), evars)
+ mode(evars) <- "call"
+ }
+ xvars[[term]] <- evars
+ }
+ xvars <- c(as.name("list"), xvars)
+ mode(xvars) <- "call"
+
+ if(!missing(newdata))
+ xvars <- eval(xvars, newdata)
+ else {
+ if(!is.null(Call$subset) | !is.null(Call$na.action) | !is.null(
+ options("na.action")[[1]])) {
+ Rownames <- names(object$fitted)
+
+ if(!(Rl <- length(Rownames)))
+ stop("need to have names for fitted.values when call has a subset or na.action argument"
+ )
+ form<-paste("~",unlist(xnames),collapse="+")
+ Mcall <- c(as.name("model.frame"), list(formula =
+ terms(as.formula(form)),
+ subset = Rownames, na.action = function(x)
+ x))
+ mode(Mcall) <- "call"
+ Mcall$data <- Call$data
+ xvars <- eval(xvars, eval(Mcall))
+ }
+ else {
+ ecall <- substitute(eval(expression(xvars)))
+ ecall$local <- Call$data
+ xvars <- eval(ecall)
+ }
+ }
+ if(missing(newdata))
+ pred <- predict(object, type = "terms", terms = terms,
+ se.fit = TRUE)
+ else pred <- predict(object, newdata, type = "terms", terms = terms,
+ se.fit = TRUE)
+ if(is.list(pred)){# oneday predict might return se.fit with newdata
+ fits <- pred$fit
+ se.fits <- pred$se.fit
+ }
+ else{
+ fits <- pred
+ se.fits <- NULL
+ }
+
+ gamplot <- xnames
+ for(term in terms) {
+ x <- xvars[[term]]
+ ## oldClass(x) <- unique(c(oldClass(x), data.class(unclass(x))))
+ xlab <- xnames[[term]]
+ ## Fix ylab for linear terms:
+ ylab <- if(length(xlab) == 1 && term == xlab) paste(
+ "partial for", term) else term
+ TT <- list(x = x, y = fits[, term], se.y = if(is.null(se.fits)
+ ) NULL else se.fits[, term], xlab = xlab, ylab = ylab)
+ oldClass(TT) <- "preplot.gam"
+ gamplot[[term]] <- TT
+ }
+ oldClass(gamplot) <- "preplot.gam"
+ gamplot
+}
diff --git a/R/print.gam.R b/R/print.gam.R
new file mode 100644
index 0000000..6e9d074
--- /dev/null
+++ b/R/print.gam.R
@@ -0,0 +1,17 @@
+"print.gam" <-
+ function(x, digits = 5, ...)
+{
+ if(!is.null(cl <- x$call)) {
+ cat("Call:\n")
+ dput(cl)
+ }
+ n <- x$df.null
+ if(is.null(df.resid <- x$df.resid))
+ df.resid <- n - sum(!is.na(x$coef)) - sum(x$nl.df)
+ cat("\nDegrees of Freedom:", n, "total;", format(round(df.resid, digits
+ )), "Residual\n")
+ if(!is.null(x$na.action))
+ cat(naprint(x$na.action), "\n")
+ cat("Residual Deviance:", format(round(x$deviance, digits)), "\n")
+ invisible(x)
+}
diff --git a/R/print.gamex.R b/R/print.gamex.R
new file mode 100644
index 0000000..cf906cd
--- /dev/null
+++ b/R/print.gamex.R
@@ -0,0 +1,7 @@
+"print.gamex" <-
+ function(x,...)
+ {
+ print(x$coefficients)
+ invisible()
+ }
+
diff --git a/R/print.summary.gam.R b/R/print.summary.gam.R
new file mode 100644
index 0000000..1ed8e1b
--- /dev/null
+++ b/R/print.summary.gam.R
@@ -0,0 +1,33 @@
+"print.summary.gam" <-
+ function(x, digits = max(3, getOption("digits") - 3), quote = TRUE, prefix = "", ...)
+{
+ cat("\nCall: ")
+ dput(x$call)
+ dresid <- x$deviance.resid
+ n <- length(dresid)
+ rdf <- x$df[2]
+ if(rdf > 5) {
+ cat("Deviance Residuals:\n")
+ rq <- quantile(as.vector(dresid))
+ names(rq) <- c("Min", "1Q", "Median", "3Q", "Max")
+ print(rq, digits = digits)
+ }
+ else if(rdf > 0) {
+ cat("Deviance Residuals:\n")
+ print(dresid, digits = digits)
+ }
+ cat(paste("\n(Dispersion Parameter for ", names(x$dispersion),
+ " family taken to be ", format(round(x$dispersion, digits)),
+ ")\n",sep=""))
+ int <- attr(x$terms, "intercept")
+ cat("\n Null Deviance:", format(round(x$null.deviance, digits)),
+ "on", n - int, "degrees of freedom")
+ cat("\nResidual Deviance:", format(round(x$deviance, digits)), "on",
+ format(round(rdf, digits)), "degrees of freedom")
+ cat("\nAIC:", format(round(x$aic, digits)),"\n")
+ if(!is.null(x$na.action))
+ cat(naprint(x$na.action), "\n")
+ cat("\nNumber of Local Scoring Iterations:", format(trunc(x$iter)),
+ "\n")
+ print(x$anova)
+}
diff --git a/R/random.R b/R/random.R
new file mode 100644
index 0000000..9be4cec
--- /dev/null
+++ b/R/random.R
@@ -0,0 +1,13 @@
+"random" <-
+ function(xvar, df = NULL, sigma = 0.)
+{
+ scall <- deparse(sys.call())
+ if(!inherits(xvar, "factor"))
+ stop("random() expects a factor or category as its first argument"
+ )
+ xvar <- C(xvar, rep(0., length(levels(xvar))), 1.)
+ attr(xvar, "call") <- substitute(gam.random(data[[scall]], z, w, df =
+ df, sigma))
+ oldClass(xvar) <- c("smooth", oldClass(xvar))
+ xvar
+}
diff --git a/R/s.R b/R/s.R
new file mode 100644
index 0000000..72af442
--- /dev/null
+++ b/R/s.R
@@ -0,0 +1,29 @@
+"s" <-
+ function(x, df = 4, spar = 1)
+{
+ scall <- deparse(sys.call())
+ if(missing(df)){
+ if(!missing(spar))df<-0
+ }
+
+ if(ncol(as.matrix(x)) > 1)
+ stop(paste(
+ "The default smoother is bivariate; you gave a matrix as an argument in ",
+ scall, "\n"))
+ if(!is.null(levels(x))) {
+ if(inherits(x, "ordered"))
+ x <- as.numeric(x)
+ else stop("unordered factors cannot be used as smoothing variables"
+ )
+ }
+ attr(x, "spar") <- spar
+ attr(x, "df") <- df
+ real.call <- substitute(gam.s(data[[scall]], z, w, spar = spar, df = df
+ ))
+ attr(x, "call") <- real.call
+ attr(x, "class") <- "smooth"
+ a <- is.na(x)
+ if(any(a))
+ attr(x, "NAs") <- seq(along = x)[a]
+ x
+}
diff --git a/R/s.wam.R b/R/s.wam.R
new file mode 100644
index 0000000..8cf1cfe
--- /dev/null
+++ b/R/s.wam.R
@@ -0,0 +1,84 @@
+"s.wam" <-
+function(x, y, w, s, which, smooth.frame, maxit = 30, tol = 1e-7, trace = FALSE,
+ se = TRUE, ...)
+{
+ if(is.data.frame(smooth.frame)) {
+ first <- TRUE
+ # first call to wam; set up some things
+ #on first entry, smooth.frame is a data frame with elements the terms to be
+ #smoothed in which
+ data <- smooth.frame[, names(which), drop = FALSE]
+ smooth.frame <- gam.match(data)
+ dx <- as.integer(dim(x))
+ smooth.frame$n <- dx[1]
+ smooth.frame$p <- dx[2]
+ oldClass(data) <- NULL
+ smooth.frame$spar <- unlist(lapply(data, attr, "spar"))
+ smooth.frame$df <- unlist(lapply(data, attr, "df"))
+ }
+ else first <- FALSE
+ storage.mode(tol) <- "double"
+ storage.mode(maxit) <- "integer"
+ which <- unlist(which)
+ storage.mode(which) <- "integer"
+ storage.mode(y) <- "double"
+ storage.mode(w) <- "double"
+ p <- smooth.frame$p
+ n <- smooth.frame$n
+ fit <- .Fortran("bakfit",
+ x,
+ npetc = as.integer(c(n, p, length(which), se, 0, maxit, 0)),
+
+ y = y,
+ w = w,
+ which,
+ spar = as.double(smooth.frame$spar),
+ df = as.double(smooth.frame$df),
+ as.integer(smooth.frame$o),
+ as.integer(smooth.frame$nef),
+ etal = double(n),
+ s = s,
+ eta = double(n),
+ beta = double(p),
+ var = s,
+ tol,
+ qr = x,
+ qraux = double(p),
+ qpivot = as.integer(1:p),
+ effects=double(n),
+ double((10 + 2 * 4 + 5) * (max(smooth.frame$nef) + 2) + 15 *
+ n + 15 + length(which)),
+ PACKAGE="gam")
+ nit <- fit$npetc[5]
+ qrank <- fit$npetc[7]
+ if((nit == maxit) & maxit > 1)
+ warning(paste("s.wam convergence not obtained in ", maxit,
+ " iterations"))
+ if(first) {
+ smooth.frame$spar <- fit$spar
+ first <- FALSE
+ }
+ names(fit$df) <- dimnames(s)[[2]]
+ names(fit$beta) <- labels(x)[[2]]
+ qrx <- structure(list(qr = fit$qr,qraux = fit$qraux,
+ rank = qrank, pivot = fit$qpivot,tol=1e-7),class="qr")
+ effects<-fit$effects #qr.qty(qrx,fit$y)
+ r1 <- seq(len = qrx$rank)
+ dn <- colnames(x)
+ if (is.null(dn))
+ dn <- paste("x", 1:p, sep = "")
+ names(effects) <- c(dn[qrx$pivot[r1]], rep.int("", n - qrx$rank))
+
+ rl <- list(coefficients = fit$beta, residuals = fit$y - fit$eta,
+ fitted.values = fit$eta,
+ effects=effects, weights=w, rank=qrank,
+ assign=attr(x,"assign"),
+ qr=qrx,
+ smooth = fit$s,
+ nl.df = fit$df - 1
+ )
+ rl$df.residual <- n - qrank - sum(rl$nl.df) - sum(fit$w == 0.)
+ if(se)
+ rl <- c(rl, list(var = fit$var))
+ c(list(smooth.frame = smooth.frame), rl)
+}
diff --git a/R/step.gam.R b/R/step.gam.R
new file mode 100644
index 0000000..3853e61
--- /dev/null
+++ b/R/step.gam.R
@@ -0,0 +1,206 @@
+`step.gam` <-
+function (object, scope, scale, direction = c("both", "backward",
+ "forward"), trace = TRUE, keep = NULL, steps = 1000, ...)
+{
+scope.char <-
+ function(formula) {
+ formula=update(formula,~-1+.)
+ tt <- terms(formula)
+ tl <- attr(tt, "term.labels")
+ if (attr(tt, "intercept"))
+ c("1", tl)
+ else tl
+ }
+re.arrange <- function(keep) {
+ namr <- names(k1 <- keep[[1]])
+ namc <- names(keep)
+ nc <- length(keep)
+ nr <- length(k1)
+ array(unlist(keep, recursive = FALSE), c(nr, nc), list(namr,
+ namc))
+ }
+ untangle.scope <- function(terms, regimens) {
+ a <- attributes(terms)
+ response <- deparse(a$variables[[2]])
+ term.labels <- a$term.labels
+ if (!is.null(a$offset)) {
+ off1 <- deparse(a$variables[[a$offset]])
+ }
+ nt <- length(regimens)
+ select <- integer(nt)
+ for (i in seq(nt)) {
+ j <- match(regimens[[i]], term.labels, 0)
+ if (any(j)) {
+ if (sum(j > 0) > 1)
+ stop(paste("The elements of a regimen", i,
+ "appear more than once in the initial model",
+ sep = " "))
+ select[i] <- seq(j)[j > 0]
+ term.labels <- term.labels[-sum(j)]
+ }
+ else {
+ if (!(j <- match("1", regimens[[i]], 0)))
+ stop(paste("regimen", i, "does not appear in the initial model",
+ sep = " "))
+ select[i] <- j
+ }
+ }
+ if (length(term.labels))
+ term.labels <- paste(term.labels, "+")
+ if (!is.null(a$offset))
+ term.labels <- paste(off1, term.labels, sep = " + ")
+ return(list(response = paste(response, term.labels, sep = " ~ "),
+ select = select))
+ }
+ make.step <- function(models, fit, scale, object) {
+ chfrom <- sapply(models, "[[", "from")
+ chfrom[chfrom == "1"] <- ""
+ chto <- sapply(models, "[[", "to")
+ chto[chto == "1"] <- ""
+ dev <- sapply(models, "[[", "deviance")
+ df <- sapply(models, "[[", "df.resid")
+ ddev <- c(NA, diff(dev))
+ ddf <- c(NA, diff(df))
+ AIC <- sapply(models, "[[", "AIC")
+ heading <- c("Stepwise Model Path \nAnalysis of Deviance Table",
+ "\nInitial Model:", deparse(as.vector(formula(object))),
+ "\nFinal Model:", deparse(as.vector(formula(fit))),
+ paste("\nScale: ", format(scale), "\n", sep = ""))
+ aod <- data.frame(From = chfrom, To = chto, Df = ddf,
+ Deviance = ddev, "Resid. Df" = df, "Resid. Dev" = dev,
+ AIC = AIC, check.names = FALSE)
+ fit$anova <- as.anova(aod, heading)
+ fit
+ }
+ direction <- match.arg(direction)
+ if (missing(scope))
+ stop("you must supply a scope argument to step.gam(); the gam.scope() function might be useful")
+ if (!is.character(scope[[1]]))
+ scope <- lapply(scope, scope.char)
+ response <- untangle.scope(object$terms, scope)
+ form.y <- response$response
+ backward <- direction == "both" | direction == "backward"
+ forward <- direction == "both" | direction == "forward"
+ items <- response$select
+ family <- family(object)
+ Call <- object$call
+ term.lengths <- sapply(scope, length)
+ n.items <- length(items)
+ visited <- array(FALSE, term.lengths)
+ visited[array(items, c(1, n.items))] <- TRUE
+ if (!is.null(keep)) {
+ keep.list <- vector("list", length(visited))
+ nv <- 1
+ }
+ models <- vector("list", length(visited))
+ nm <- 2
+ form.vector <- character(n.items)
+ for (i in seq(n.items)) form.vector[i] <- scope[[i]][items[i]]
+ form <- deparse(object$formula)
+ if (trace)
+ cat("Start: ", form)
+ fit <- object
+ n <- length(fit$fitted)
+ if (missing(scale)) {
+ famname <- family$family["name"]
+ scale <- switch(famname, Poisson = 1, Binomial = 1, deviance.lm(fit)/fit$df.resid)
+ }
+ else if (scale == 0)
+ scale <- deviance.lm(fit)/fit$df.resid
+ bAIC <- fit$aic
+ if (trace)
+ cat("; AIC=", format(round(bAIC, 4)), "\n")
+ models[[1]] <- list(deviance = deviance(fit), df.resid = fit$df.resid,
+ AIC = bAIC, from = "", to = "")
+ if (!is.null(keep)) {
+ keep.list[[nv]] <- keep(fit, bAIC)
+ nv <- nv + 1
+ }
+ AIC <- bAIC + 1
+ while (bAIC < AIC & steps > 0) {
+ steps <- steps - 1
+ AIC <- bAIC
+ bitems <- items
+ bfit <- fit
+ for (i in seq(n.items)) {
+ if (backward) {
+ trial <- items
+ trial[i] <- trial[i] - 1
+ if (trial[i] > 0 && !visited[array(trial, c(1,
+ n.items))]) {
+ visited[array(trial, c(1, n.items))] <- TRUE
+ tform.vector <- form.vector
+ tform.vector[i] <- scope[[i]][trial[i]]
+ form <- paste(form.y, paste(tform.vector, collapse = " + "))
+ if (trace)
+ cat("Trial: ", form)
+ tfit <- update(object, eval(parse(text = form)),
+ trace = FALSE, ...)
+ tAIC <- tfit$aic
+ if (!is.null(keep)) {
+ keep.list[[nv]] <- keep(tfit, tAIC)
+ nv <- nv + 1
+ }
+ if (tAIC < bAIC) {
+ bAIC <- tAIC
+ bitems <- trial
+ bfit <- tfit
+ bform.vector <- tform.vector
+ bfrom <- form.vector[i]
+ bto <- tform.vector[i]
+ }
+ if (trace)
+ cat("; AIC=", format(round(tAIC, 4)), "\n")
+ }
+ }
+ if (forward) {
+ trial <- items
+ trial[i] <- trial[i] + 1
+ if (trial[i] <= term.lengths[i] && !visited[array(trial,
+ c(1, n.items))]) {
+ visited[array(trial, c(1, n.items))] <- TRUE
+ tform.vector <- form.vector
+ tform.vector[i] <- scope[[i]][trial[i]]
+ form <- paste(form.y, paste(tform.vector, collapse = " + "))
+ if (trace)
+ cat("Trial: ", form)
+ tfit <- update(object, eval(parse(text = form)),
+ trace = FALSE, ...)
+ tAIC <- tfit$aic
+ if (!is.null(keep)) {
+ keep.list[[nv]] <- keep(tfit, tAIC)
+ nv <- nv + 1
+ }
+ if (tAIC < bAIC) {
+ bAIC <- tAIC
+ bitems <- trial
+ bfit <- tfit
+ bform.vector <- tform.vector
+ bfrom <- form.vector[i]
+ bto <- tform.vector[i]
+ }
+ if (trace)
+ cat("; AIC=", format(round(tAIC, 4)), "\n")
+ }
+ }
+ }
+ if (bAIC >= AIC | steps == 0) {
+ if (!is.null(keep))
+ fit$keep <- re.arrange(keep.list[seq(nv - 1)])
+ return(make.step(models[seq(nm - 1)], fit, scale,
+ object))
+ }
+ else {
+ if (trace)
+ cat("Step : ", deparse(bfit$formula), "; AIC=",
+ format(round(bAIC, 4)), "\n\n")
+ items <- bitems
+ models[[nm]] <- list(deviance = deviance(bfit), df.resid = bfit$df.resid,
+ AIC = bAIC, from = bfrom, to = bto)
+ nm <- nm + 1
+ fit <- bfit
+ form.vector <- bform.vector
+ }
+ }
+}
+
diff --git a/R/subset.smooth.R b/R/subset.smooth.R
new file mode 100644
index 0000000..ae33497
--- /dev/null
+++ b/R/subset.smooth.R
@@ -0,0 +1,24 @@
+"[.smooth" <-
+function(x, ..., drop = FALSE)
+{
+ cl <- oldClass(x)
+ oldClass(x) <- NULL
+ ats <- attributes(x)
+ ats$dimnames <- NULL
+ ats$dim <- NULL
+ ats$names <- NULL
+ y <- x[..., drop = drop]
+ if(!is.null(nas <- ats$NAs)) {
+ if(is.null(d <- dim(x)))
+ d <- c(length(x), 1.)
+ navec <- array(logical(d[1.]), d)
+ navec[nas, ] <- TRUE
+ navec <- navec[...]
+ nas <- if(is.null(dim(navec))) navec else navec[, 1.]
+ nas <- seq(nas)[nas]
+ ats$NAs <- nas
+ }
+ attributes(y) <- c(attributes(y), ats)
+ oldClass(y) <- cl
+ y
+}
diff --git a/R/summary.gam.R b/R/summary.gam.R
new file mode 100644
index 0000000..01062aa
--- /dev/null
+++ b/R/summary.gam.R
@@ -0,0 +1,99 @@
+"summary.gam" <-
+ function(object, dispersion = NULL,...)
+{
+ save.na.action <- object$na.action
+ object$na.action <- NULL
+ fun <- function(assign, coeff)
+ sum(!is.na(coeff[assign]))
+ wt <- object$weights
+ coef <- object$coef
+ dresid <- residuals(object, "deviance")
+ resid <- object$residuals
+ n <- length(resid)
+ s <- object$s
+ nl.chisq <- object$nl.chisq
+ assg <- object$assign
+ if(is.null(assg))
+ assg <- attributes(object$terms)$assign
+ df<-rep(1,length(assg))
+ df[is.na(object$coef)]<-0
+ df<-tapply(df,assg,sum)
+ dfnames<-attr(object$terms,"term.labels")
+ if(attr(object$terms,"intercept"))dfnames<-c("(Intercept)",dfnames)
+ names(df)<-dfnames
+ df<-unlist(df)
+ nldf <- object$nl.df
+ n <- length(object$residuals)
+ if(is.null(rdf <- object$df.resid)) {
+ rdf <- n - sum(df)
+ if(!is.null(nldf))
+ rdf <- rdf - sum(nldf)
+ }
+ if(!is.null(wt)) {
+ wt <- wt^0.5
+ resid <- resid * wt
+ excl <- wt == 0
+ if(any(excl)) {
+ warning(paste(sum(excl),
+ "rows with zero weights not counted"))
+ resid <- resid[!excl]
+ dresid <- dresid[!excl]
+ if(is.null(object$df.residual))
+ rdf <- rdf - sum(excl)
+ }
+ }
+ if(rdf > 0)
+ phihat <- sum(resid^2)/rdf
+ else {
+ phihat <- Inf
+ warning("Residual degrees of freedom are negative or zero. This occurs when the sum of the parametric and nonparametric degrees of freedom exceeds the number of observations. The model is probably too complex for the amount of data available."
+ )
+ }
+ famname <- object$family[["family"]]
+ if(is.null(famname))
+ famname <- "gaussian"
+ chiorf <- TRUE
+ if(!is.null(dispersion) && dispersion == 0)
+ dispersion <- phihat
+ if(is.null(dispersion))
+ dispersion <- switch(famname,
+ poisson = 1,
+ binomial = 1,
+ {
+ chiorf <- FALSE
+ phihat
+ }
+ )
+ names(dispersion) <- famname
+ if(length(df)) {
+ aod <- as.matrix(round(df, 1))
+ dimnames(aod) <- list(names(df), "Df")
+ if(!is.null(nl.chisq)) {
+ aod <- cbind(aod, NA, NA, NA)
+ nl.chisq <- nl.chisq/dispersion
+ snames <- names(nldf)
+ aod[snames, 2] <- round(nldf, 1)
+ aod[snames, 3] <- if(!chiorf) nl.chisq/nldf else
+ nl.chisq
+ aod[snames, 4] <- if(chiorf) 1 - pchisq(nl.chisq, nldf)
+ else if(rdf > 0)
+ 1 - pf(nl.chisq/nldf, nldf, rdf)
+ else NA
+ rnames <- c("Df", "Npar Df", "Npar Chisq", "P(Chi)")
+ if(!chiorf)
+ rnames[3:4] <- c("Npar F", "Pr(F)")
+ dimnames(aod) <- list(names(df), rnames)
+ heading <- if(chiorf)
+ "\nDF for Terms and Chi-squares for Nonparametric Effects\n"
+ else "\nDF for Terms and F-values for Nonparametric Effects\n"
+ }
+ else heading <- "DF for Terms\n\n"
+ aod <- as.anova(data.frame(aod, check.names = FALSE), heading)
+ }
+ else aod <- NULL
+ structure(list(call = object$call, terms = object$terms, anova = aod,
+ dispersion = dispersion, df = c(sum(df) + sum(nldf), rdf),
+ deviance.resid = dresid, deviance = deviance(object),
+ null.deviance = object$null.deviance, aic=object$aic,iter = object$iter,
+ na.action = save.na.action), class = "summary.gam")
+}
diff --git a/R/ylim.scale.R b/R/ylim.scale.R
new file mode 100644
index 0000000..88b2de5
--- /dev/null
+++ b/R/ylim.scale.R
@@ -0,0 +1,8 @@
+"ylim.scale" <-
+function(ylim, scale = 0.)
+{
+ scale2 <- diff(ylim)
+ if(scale2 < scale)
+ rep(mean(ylim), 2.) + ((ylim - mean(ylim)) * scale)/scale2
+ else ylim
+}
diff --git a/data/gam.data.RData b/data/gam.data.RData
new file mode 100644
index 0000000..d9884be
Binary files /dev/null and b/data/gam.data.RData differ
diff --git a/data/gam.newdata.RData b/data/gam.newdata.RData
new file mode 100644
index 0000000..babd23c
Binary files /dev/null and b/data/gam.newdata.RData differ
diff --git a/data/kyphosis.RData b/data/kyphosis.RData
new file mode 100644
index 0000000..0639105
Binary files /dev/null and b/data/kyphosis.RData differ
diff --git a/inst/ratfor/linear.r b/inst/ratfor/linear.r
new file mode 100644
index 0000000..fa755a9
--- /dev/null
+++ b/inst/ratfor/linear.r
@@ -0,0 +1,2555 @@
+subroutine dqrls(x,dx,pivot,qraux,y,dy,beta,res,qt,tol,scrtch,rank)
+integer pivot(1),dx(2),dy(2),rank
+double precision x(1), qraux(1), y(1), beta(1),res(1),qt(1),tol(1),
+ scrtch(1)
+
+integer n,p,q,kn,kp,k,info
+
+n=dx(1); p=dx(2); q=dy(2)
+call dqrdca(x,n,n,p,qraux,pivot,scrtch,rank,tol(1))
+
+kn=1; kp=1
+if(rank>0)for(k=1;k<=q;k=k+1){
+ call dqrsl(x,n,n,rank,qraux,y(kn),scrtch,qt(kn),beta(kp),
+ res(kn),scrtch,00110,info)
+ kn = kn+n; kp=kp+p
+}
+return
+end
+
+#apply the qr decomposition to do various jobs
+subroutine dqrsl1(qr,dq,qra,rank,y,k,qy,qb,job,info)
+double precision qr(1),qra(1),y(1),qy(1),qb(1); integer dq(2),job,k,rank
+integer n,kn,kb,j
+double precision ourqty(1), ourqy(1), ourb(1), ourrsd(1), ourxb(1)
+ourqty(1) = 0d0
+ourqy(1) = 0d0
+ourb(1) = 0d0
+ourrsd(1) = 0d0
+ourxb(1) = 0d0
+n = dq(1)
+kn = 1; kb = 1
+switch(job) {
+case 10000: #qy
+for(j=0; j<k; j = j+1) {
+ call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),qy(kn),ourqty,ourb,ourrsd,ourxb,job,info)
+ kn = kn +n
+}
+case 1000: #qty
+for(j=0; j<k; j = j+1) {
+ call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),ourqy,qy(kn),ourb,ourrsd,ourxb,job,info)
+ kn = kn +n
+}
+case 100: #coefs
+for(j=0; j<k; j = j+1) {
+ call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),ourqy,qy(kn),qb(kb),ourrsd,ourxb,job,info)
+ kn = kn +n; kb = kb +rank
+}
+case 10: #residuals
+for(j=0; j<k; j = j+1) {
+ call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),ourqy,qy(kn),ourb,qb(kn),ourxb,job,info)
+ kn = kn +n
+}
+case 1: #fitted
+for(j=0; j<k; j = j+1) {
+ call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),ourqy,qy(kn),ourb,ourrsd,qb(kn),job,info)
+ kn = kn +n
+}
+default:
+ info = -1
+}
+return
+end
+
+subroutine dqr(x,dx,pivot,qraux,tol,scrtch,rank)
+integer pivot(1),dx(2),rank
+double precision x(1), qraux(1), tol(1), scrtch(1)
+
+integer n,p
+
+n=dx(1); p=dx(2);
+call dqrdca(x,n,n,p,qraux,pivot,scrtch,rank,tol(1))
+return
+end
+
+
+# qr decomposition, modified from linpack routines to give stable
+# ordering and rank estimation
+subroutine dqrdca(x,ldx,n,p,qraux,jpvt,work,rank,eps)
+integer ldx,n,p,rank
+integer jpvt(1)
+double precision x(ldx,1),qraux(1),work(1),eps
+integer j,jj,jp,l,lup,curpvt
+double precision dnrm2,tt
+double precision ddot,nrmxl,t,ww
+do j=1,p {
+ qraux(j) = dnrm2(n,x(1,j),1)
+ work(j) = qraux(j); work(j+p) = qraux(j)
+}
+l=1; lup = min0(n,p); curpvt = p
+while(l<=lup) {
+ qraux(l) = 0.0d0
+ nrmxl = dnrm2(n-l+1,x(l,l),1)
+ t = work(l+p); if(t > 0.)t = nrmxl/t
+ if(t < eps){
+ call dshift(x,ldx,n,l,curpvt)
+ jp = jpvt(l); t=qraux(l); tt=work(l); ww = work(l+p)
+ for(j=l+1; j<=curpvt; j=j+1){
+ jj=j-1
+ jpvt(jj)=jpvt(j); qraux(jj)=qraux(j)
+ work(jj)=work(j); work(jj+p) = work(j+p)
+ }
+ jpvt(curpvt)=jp; qraux(curpvt)=t;
+ work(curpvt)=tt; work(curpvt+p) = ww
+ curpvt=curpvt-1; if(lup>curpvt)lup=curpvt
+ }
+ else {
+ if(l==n)break
+ if (x(l,l)!=0.0d0)
+ nrmxl = dsign(nrmxl,x(l,l))
+ call dscal(n-l+1,1.0d0/nrmxl,x(l,l),1)
+ x(l,l) = 1.0d0+x(l,l)
+ for(j=l+1; j<=curpvt; j=j+1) {
+ t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l)
+ call daxpy(n-l+1,t,x(l,l),1,x(l,j),1)
+ if (qraux(j)!=0.0d0) {
+ tt = 1.0d0-(dabs(x(l,j))/qraux(j))**2
+ tt = dmax1(tt,0.0d0)
+ t = tt
+ tt = 1.0d0+0.05d0*tt*(qraux(j)/work(j))**2
+ if (tt!=1.0d0)
+ qraux(j) = qraux(j)*dsqrt(t)
+ else {
+ qraux(j) = dnrm2(n-l,x(l+1,j),1)
+ work(j) = qraux(j)
+ }
+ }
+ }
+ qraux(l) = x(l,l)
+ x(l,l) = -nrmxl
+ l=l+1
+ }
+}
+rank = lup
+return
+end
+
+subroutine dchdc(a,lda,p,work,jpvt,job,info)
+integer lda,p,jpvt(p),job,info
+double precision a(lda,p),work(p)
+integer pu,pl,plp1,j,jp,jt,k,kb,km1,kp1,l,maxl
+double precision temp
+double precision maxdia
+logical swapk,negk
+pl = 1
+pu = 0
+info = p
+if (job!=0) {
+ do k = 1,p {
+ swapk = jpvt(k)>0
+ negk = jpvt(k)<0
+ jpvt(k) = k
+ if (negk)
+ jpvt(k) = -jpvt(k)
+ if (swapk) {
+ if (k!=pl) {
+ call dswap(pl-1,a(1,k),1,a(1,pl),1)
+ temp = a(k,k)
+ a(k,k) = a(pl,pl)
+ a(pl,pl) = temp
+ plp1 = pl+1
+ if (p>=plp1)
+ do j = plp1,p
+ if (j<k) {
+ temp = a(pl,j)
+ a(pl,j) = a(j,k)
+ a(j,k) = temp
+ }
+ else if (j!=k) {
+ temp = a(k,j)
+ a(k,j) = a(pl,j)
+ a(pl,j) = temp
+ }
+ jpvt(k) = jpvt(pl)
+ jpvt(pl) = k
+ }
+ pl = pl+1
+ }
+ }
+ pu = p
+ if (p>=pl)
+ do kb = pl,p {
+ k = p-kb+pl
+ if (jpvt(k)<0) {
+ jpvt(k) = -jpvt(k)
+ if (pu!=k) {
+ call dswap(k-1,a(1,k),1,a(1,pu),1)
+ temp = a(k,k)
+ a(k,k) = a(pu,pu)
+ a(pu,pu) = temp
+ kp1 = k+1
+ if (p>=kp1)
+ do j = kp1,p
+ if (j<pu) {
+ temp = a(k,j)
+ a(k,j) = a(j,pu)
+ a(j,pu) = temp
+ }
+ else if (j!=pu) {
+ temp = a(k,j)
+ a(k,j) = a(pu,j)
+ a(pu,j) = temp
+ }
+ jt = jpvt(k)
+ jpvt(k) = jpvt(pu)
+ jpvt(pu) = jt
+ }
+ pu = pu-1
+ }
+ }
+ }
+do k = 1,p {
+# reduction loop.
+ maxdia = a(k,k)
+ kp1 = k+1
+ maxl = k
+# determine the pivot element.
+ if (k>=pl&&k<pu)
+ do l = kp1,pu
+ if (a(l,l)>maxdia) {
+ maxdia = a(l,l)
+ maxl = l
+ }
+# quit if the pivot element is not positive.
+ if (maxdia<=0.0d0)
+ go to 10
+ if (k!=maxl) {
+# start the pivoting and update jpvt.
+ km1 = k-1
+ call dswap(km1,a(1,k),1,a(1,maxl),1)
+ a(maxl,maxl) = a(k,k)
+ a(k,k) = maxdia
+ jp = jpvt(maxl)
+ jpvt(maxl) = jpvt(k)
+ jpvt(k) = jp
+ }
+# reduction step. pivoting is contained across the rows.
+ work(k) = dsqrt(a(k,k))
+ a(k,k) = work(k)
+ if (p>=kp1)
+ do j = kp1,p {
+ if (k!=maxl)
+ if (j<maxl) {
+ temp = a(k,j)
+ a(k,j) = a(j,maxl)
+ a(j,maxl) = temp
+ }
+ else if (j!=maxl) {
+ temp = a(k,j)
+ a(k,j) = a(maxl,j)
+ a(maxl,j) = temp
+ }
+ a(k,j) = a(k,j)/work(k)
+ work(j) = a(k,j)
+ temp = -a(k,j)
+ call daxpy(j-k,temp,work(kp1),1,a(kp1,j),1)
+ }
+ }
+return
+10 info = k-1
+return
+end
+
+
+
+double precision function epslon(x)
+double precision x
+# estimate unit roundoff in quantities of size x.
+double precision a,b,c,eps
+a = 4.0d0/3.0d0
+repeat {
+ b = a-1.0d0
+ c = b+b+b
+ eps = dabs(c-1.0d0)
+ }
+ until(eps!=0.0d0)
+epslon = eps*dabs(x)
+return
+end
+
+
+
+double precision function pythag(a,b)
+double precision a,b
+double precision p,r,s,t,u
+p = dmax1(dabs(a),dabs(b))
+if (p!=0.0d0) {
+ r = (dmin1(dabs(a),dabs(b))/p)**2
+ repeat {
+ t = 4.0d0+r
+ if (t==4.0d0)
+ break 1
+ s = r/t
+ u = 1.0d0+2.0d0*s
+ p = u*p
+ r = (s/u)**2*r
+ }
+ }
+pythag = p
+return
+end
+
+
+
+subroutine rg(nm,n,a,wr,wi,matz,z,iv1,fv1,ierr)
+integer n,nm,is1,is2,ierr,matz
+double precision a(nm,n),wr(n),wi(n),z(nm,n),fv1(n)
+integer iv1(n)
+if (n>nm)
+ ierr = 10*n
+else {
+ call balanc(nm,n,a,is1,is2,fv1)
+ call elmhes(nm,n,is1,is2,a,iv1)
+ if (matz==0)
+# .......... find eigenvalues only ..........
+ call hqr(nm,n,is1,is2,a,wr,wi,ierr)
+ else {
+# .......... find both eigenvalues and eigenvectors ..........
+ call eltran(nm,n,is1,is2,a,iv1,z)
+ call hqr2(nm,n,is1,is2,a,wr,wi,z,ierr)
+ if (ierr==0)
+ call balbak(nm,n,is1,is2,fv1,n,z)
+ }
+ }
+return
+end
+
+subroutine chol(a,p,work,jpvt,job,info)
+integer p,jpvt(1),job,info(1)
+double precision a(p,1),work(1)
+integer i,j
+ for(j =2; j<=p; j = j+1)
+ for(i=1; i<j; i = i+1)
+ if(a(i,j)!=a(j,i)){ info(1) = -1 ; return}
+ call dchdc(a,p,p,work,jpvt,job,info(1))
+ for(j =2; j<=p; j = j+1)
+ for(i=1; i<j; i = i+1)
+ a(j,i) = 0.
+ return
+end
+
+#x is a real symmetric matrix
+subroutine crs(x,dmx,matz,w,z,fv1,fv2,ierr)
+double precision x(1),w(1),z(1),fv1(1),fv2(1)
+integer dmx(2),nx,nv,ierr,matz
+nx=dmx(1)
+nv=dmx(2)
+call rs(nx,nv,x,w,matz,z,fv1,fv2,ierr)
+return
+end
+
+subroutine dqrls2(x,dx,pivot,qraux,y,dy,beta,res,qt,scrtch,eps)
+integer pivot(1),dx(2),dy(2)
+double precision x(1), qraux(1), y(1), beta(1),res(1),qt(1),
+ scrtch(1),eps
+
+integer n,p,q,kn,kp,k,info,rank
+
+n=dx(1); p=dx(2); q=dy(2)
+call dqrdca(x,n,n,p,qraux,pivot,scrtch,rank,eps)
+
+kn=1; kp=1
+for(k=1;k<=q;k=k+1){
+ call dqrsl(x,n,n,p,qraux,y(kn),scrtch,qt(kn),beta(kp),
+ res(kn),scrtch,00110,info)
+ kn = kn+n; kp=kp+p
+}
+return
+end
+
+subroutine dsvdc1(x,dmx,job,work,e,s,u,v,info)
+double precision x(1),work(1),s(1),e(1),u(1),v(1)
+integer dmx(2),nx,nv,job,info
+nx=dmx(1)
+nv=dmx(2)
+call dsvdc(x,nx,nx,nv,s,e,u,nx,v,nv,work,job,info)
+return
+end
+
+subroutine balanc(nm,n,a,low,igh,scale)
+integer i,j,k,l,m,n,nm,igh,low,iexc
+double precision a(nm,n),scale(n)
+double precision c,f,g,r,s,b2,radix
+logical noconv
+radix = 16.0d0
+b2 = radix*radix
+k = 1
+l = n
+repeat {
+# .......... for j=l step -1 until 1 do -- ..........
+ for(j=l; j>0; j=j-1 ){
+ do i = 1,l
+ if (i!=j)
+ if (a(j,i)!=0.0d0)
+ next 2
+ go to 10
+ }
+ go to 20
+ 10 m = l
+ iexc = 1
+ repeat {
+# .......... in-line procedure for row and
+# column exchange ..........
+ scale(m) = j
+ if (j!=m) {
+ do i = 1,l {
+ f = a(i,j)
+ a(i,j) = a(i,m)
+ a(i,m) = f
+ }
+ do i = k,n {
+ f = a(j,i)
+ a(j,i) = a(m,i)
+ a(m,i) = f
+ }
+ }
+ switch(iexc) {
+ case 1:
+# .......... search for rows isolating an eigenvalue
+# and push them down ..........
+ if (l==1)
+ go to 40
+ l = l-1
+ break 1
+ case 2:
+# .......... search for columns isolating an eigenvalue
+# and push them left ..........
+ k = k+1
+ 20 do j = k,l {
+ do i = k,l
+ if (i!=j)
+ if (a(i,j)!=0.0d0)
+ next 2
+ go to 30
+ }
+ break 2
+ 30 m = k
+ iexc = 2
+ }
+ }
+ }
+# .......... now balance the submatrix in rows k to l ..........
+do i = k,l
+ scale(i) = 1.0d0
+repeat {
+# .......... iterative loop for norm reduction ..........
+ noconv = .false.
+ do i = k,l {
+ c = 0.0d0
+ r = 0.0d0
+ do j = k,l
+ if (j!=i) {
+ c = c+dabs(a(j,i))
+ r = r+dabs(a(i,j))
+ }
+# .......... guard against zero c or r due to underflow ..........
+ if (c!=0.0d0&&r!=0.0d0) {
+ g = r/radix
+ f = 1.0d0
+ s = c+r
+ while (c<g) {
+ f = f*radix
+ c = c*b2
+ }
+ g = r*radix
+ while (c>=g) {
+ f = f/radix
+ c = c/b2
+ }
+# .......... now balance ..........
+ if ((c+r)/f<0.95d0*s) {
+ g = 1.0d0/f
+ scale(i) = scale(i)*f
+ noconv = .true.
+ do j = k,n
+ a(i,j) = a(i,j)*g
+ do j = 1,l
+ a(j,i) = a(j,i)*f
+ }
+ }
+ }
+ }
+ until(!noconv)
+40 low = k
+igh = l
+return
+end
+
+
+
+subroutine balbak(nm,n,low,igh,scale,m,z)
+integer i,j,k,m,n,ii,nm,igh,low
+double precision scale(n),z(nm,m)
+double precision s
+if (m!=0) {
+ if (igh!=low)
+ do i = low,igh {
+ s = scale(i)
+# .......... left hand eigenvectors are back transformed
+# if the foregoing statement is replaced by
+# s=1.0d0/scale(i). ..........
+ do j = 1,m
+ z(i,j) = z(i,j)*s
+ }
+# ......... for i=low-1 step -1 until 1,
+# igh+1 step 1 until n do -- ..........
+ do ii = 1,n {
+ i = ii
+ if (i<low||i>igh) {
+ if (i<low)
+ i = low-ii
+ k = scale(i)
+ if (k!=i)
+ do j = 1,m {
+ s = z(i,j)
+ z(i,j) = z(k,j)
+ z(k,j) = s
+ }
+ }
+ }
+ }
+return
+end
+
+
+
+subroutine elmhes(nm,n,low,igh,a,int)
+integer i,j,m,n,la,nm,igh,kp1,low,mm1,mp1
+double precision a(nm,n)
+double precision x,y
+integer int(igh)
+la = igh-1
+kp1 = low+1
+if (la>=kp1)
+ do m = kp1,la {
+ mm1 = m-1
+ x = 0.0d0
+ i = m
+ do j = m,igh
+ if (dabs(a(j,mm1))>dabs(x)) {
+ x = a(j,mm1)
+ i = j
+ }
+ int(m) = i
+ if (i!=m) {
+# .......... interchange rows and columns of a ..........
+ do j = mm1,n {
+ y = a(i,j)
+ a(i,j) = a(m,j)
+ a(m,j) = y
+ }
+ do j = 1,igh {
+ y = a(j,i)
+ a(j,i) = a(j,m)
+ a(j,m) = y
+ }
+ }
+# .......... end interchange ..........
+ if (x!=0.0d0) {
+ mp1 = m+1
+ do i = mp1,igh {
+ y = a(i,mm1)
+ if (y!=0.0d0) {
+ y = y/x
+ a(i,mm1) = y
+ do j = m,n
+ a(i,j) = a(i,j)-y*a(m,j)
+ do j = 1,igh
+ a(j,m) = a(j,m)+y*a(j,i)
+ }
+ }
+ }
+ }
+return
+end
+
+
+
+subroutine eltran(nm,n,low,igh,a,int,z)
+integer i,j,n,kl,mp,nm,igh,low,mp1
+double precision a(nm,igh),z(nm,n)
+integer int(igh)
+# .......... initialize z to identity matrix ..........
+do j = 1,n {
+ do i = 1,n
+ z(i,j) = 0.0d0
+ z(j,j) = 1.0d0
+ }
+kl = igh-low-1
+if (kl>=1)
+ for(mp = igh-1; mp > low; mp = mp -1) {
+ mp1 = mp+1
+ do i = mp1,igh
+ z(i,mp) = a(i,mp-1)
+ i = int(mp)
+ if (i!=mp) {
+ do j = mp,igh {
+ z(mp,j) = z(i,j)
+ z(i,j) = 0.0d0
+ }
+ z(i,mp) = 1.0d0
+ }
+ }
+return
+end
+
+
+
+subroutine hqr(nm,n,low,igh,h,wr,wi,ierr)
+integer i,j,k,l,m,n,en,mm,na,nm,igh,itn,its,low,mp2,enm2,ierr
+double precision h(nm,n),wr(n),wi(n)
+double precision p,q,r,s,t,w,x,y,zz,norm,tst1,tst2
+logical notlas
+ierr = 0
+norm = 0.0d0
+k = 1
+# .......... store roots isolated by balanc
+# and compute matrix norm ..........
+do i = 1,n {
+ do j = k,n
+ norm = norm+dabs(h(i,j))
+ k = i
+ if (i<low||i>igh) {
+ wr(i) = h(i,i)
+ wi(i) = 0.0d0
+ }
+ }
+en = igh
+t = 0.0d0
+itn = 30*n
+repeat {
+# .......... search for next eigenvalues ..........
+ if (en<low)
+ return
+ its = 0
+ na = en-1
+ enm2 = na-1
+ repeat {
+# .......... look for single small sub-diagonal element
+ for(l=en; l > low; l = l-1){
+ s = dabs(h(l-1,l-1))+dabs(h(l,l))
+ if (s==0.0d0)
+ s = norm
+ tst1 = s
+ tst2 = tst1+dabs(h(l,l-1))
+ if (tst2==tst1)
+ break 1
+ }
+# .......... form shift ..........
+ x = h(en,en)
+ if (l==en)
+ go to 50
+ y = h(na,na)
+ w = h(en,na)*h(na,en)
+ if (l==na)
+ break 1
+ if (itn==0)
+ break 2
+ if (its==10||its==20) {
+# .......... form exceptional shift ..........
+ t = t+x
+ do i = low,en
+ h(i,i) = h(i,i)-x
+ s = dabs(h(en,na))+dabs(h(na,enm2))
+ x = 0.75d0*s
+ y = x
+ w = -0.4375d0*s*s
+ }
+ its = its+1
+ itn = itn-1
+# .......... look for two consecutive small
+# sub-diagonal elements.
+# for m=en-2 step -1 until l do -- ..........
+ do mm = l,enm2 {
+ m = enm2+l-mm
+ zz = h(m,m)
+ r = x-zz
+ s = y-zz
+ p = (r*s-w)/h(m+1,m)+h(m,m+1)
+ q = h(m+1,m+1)-zz-r-s
+ r = h(m+2,m+1)
+ s = dabs(p)+dabs(q)+dabs(r)
+ p = p/s
+ q = q/s
+ r = r/s
+ if (m==l)
+ break 1
+ tst1 = dabs(p)*(dabs(h(m-1,m-1))+dabs(zz)+dabs(h(m+1,m+1)))
+ tst2 = tst1+dabs(h(m,m-1))*(dabs(q)+dabs(r))
+ if (tst2==tst1)
+ break 1
+ }
+ mp2 = m+2
+ do i = mp2,en {
+ h(i,i-2) = 0.0d0
+ if (i!=mp2)
+ h(i,i-3) = 0.0d0
+ }
+# .......... double qr step involving rows l to en and
+# columns m to en ..........
+ do k = m,na {
+ notlas = k!=na
+ if (k!=m) {
+ p = h(k,k-1)
+ q = h(k+1,k-1)
+ r = 0.0d0
+ if (notlas)
+ r = h(k+2,k-1)
+ x = dabs(p)+dabs(q)+dabs(r)
+ if (x==0.0d0)
+ next 1
+ p = p/x
+ q = q/x
+ r = r/x
+ }
+ s = dsign(dsqrt(p*p+q*q+r*r),p)
+ if (k!=m)
+ h(k,k-1) = -s*x
+ else if (l!=m)
+ h(k,k-1) = -h(k,k-1)
+ p = p+s
+ x = p/s
+ y = q/s
+ zz = r/s
+ q = q/p
+ r = r/p
+ if (!notlas) {
+# .......... row modification ..........
+ do j = k,n {
+ p = h(k,j)+q*h(k+1,j)
+ h(k,j) = h(k,j)-p*x
+ h(k+1,j) = h(k+1,j)-p*y
+ }
+ j = min0(en,k+3)
+# .......... column modification ..........
+ do i = 1,j {
+ p = x*h(i,k)+y*h(i,k+1)
+ h(i,k) = h(i,k)-p
+ h(i,k+1) = h(i,k+1)-p*q
+ }
+ }
+ else {
+# .......... row modification ..........
+ do j = k,n {
+ p = h(k,j)+q*h(k+1,j)+r*h(k+2,j)
+ h(k,j) = h(k,j)-p*x
+ h(k+1,j) = h(k+1,j)-p*y
+ h(k+2,j) = h(k+2,j)-p*zz
+ }
+ j = min0(en,k+3)
+# .......... column modification ..........
+ do i = 1,j {
+ p = x*h(i,k)+y*h(i,k+1)+zz*h(i,k+2)
+ h(i,k) = h(i,k)-p
+ h(i,k+1) = h(i,k+1)-p*q
+ h(i,k+2) = h(i,k+2)-p*r
+ }
+ }
+ }
+ }
+# .......... two roots found ..........
+ p = (y-x)/2.0d0
+ q = p*p+w
+ zz = dsqrt(dabs(q))
+ x = x+t
+ if (q<0.0d0) {
+# .......... complex pair ..........
+ wr(na) = x+p
+ wr(en) = x+p
+ wi(na) = zz
+ wi(en) = -zz
+ }
+ else {
+# .......... real pair ..........
+ zz = p+dsign(zz,p)
+ wr(na) = x+zz
+ wr(en) = wr(na)
+ if (zz!=0.0d0)
+ wr(en) = x-w/zz
+ wi(na) = 0.0d0
+ wi(en) = 0.0d0
+ }
+ en = enm2
+ next 1
+# .......... one root found ..........
+ 50 wr(en) = x+t
+ wi(en) = 0.0d0
+ en = na
+ }
+# .......... set error -- all eigenvalues have not
+# converged after 30*n iterations ..........
+ierr = en
+return
+end
+
+
+
+subroutine hqr2(nm,n,low,igh,h,wr,wi,z,ierr)
+integer i,j,k,l,m,n,en,ii,jj,ll,mm,na,nm,nn,igh,itn,its,low,mp2,enm2,ierr
+double precision h(nm,n),wr(n),wi(n),z(nm,n)
+double precision p,q,r,s,t,w,x,y,ra,sa,vi,vr,zz,norm,tst1,tst2
+logical notlas
+ierr = 0
+norm = 0.0d0
+k = 1
+# .......... store roots isolated by balanc
+# and compute matrix norm ..........
+do i = 1,n {
+ do j = k,n
+ norm = norm+dabs(h(i,j))
+ k = i
+ if (i<low||i>igh) {
+ wr(i) = h(i,i)
+ wi(i) = 0.0d0
+ }
+ }
+en = igh
+t = 0.0d0
+itn = 30*n
+repeat {
+# .......... search for next eigenvalues ..........
+ if (en<low)
+ go to 70
+ its = 0
+ na = en-1
+ enm2 = na-1
+ repeat {
+# .......... look for single small sub-diagonal element
+# for l=en step -1 until low do -- ..........
+ do ll = low,en {
+ l = en+low-ll
+ if (l==low)
+ break 1
+ s = dabs(h(l-1,l-1))+dabs(h(l,l))
+ if (s==0.0d0)
+ s = norm
+ tst1 = s
+ tst2 = tst1+dabs(h(l,l-1))
+ if (tst2==tst1)
+ break 1
+ }
+# .......... form shift ..........
+ x = h(en,en)
+ if (l==en)
+ go to 60
+ y = h(na,na)
+ w = h(en,na)*h(na,en)
+ if (l==na)
+ break 1
+ if (itn==0)
+ break 2
+ if (its==10||its==20) {
+# .......... form exceptional shift ..........
+ t = t+x
+ do i = low,en
+ h(i,i) = h(i,i)-x
+ s = dabs(h(en,na))+dabs(h(na,enm2))
+ x = 0.75d0*s
+ y = x
+ w = -0.4375d0*s*s
+ }
+ its = its+1
+ itn = itn-1
+# .......... look for two consecutive small
+# sub-diagonal elements.
+# for m=en-2 step -1 until l do -- ..........
+ do mm = l,enm2 {
+ m = enm2+l-mm
+ zz = h(m,m)
+ r = x-zz
+ s = y-zz
+ p = (r*s-w)/h(m+1,m)+h(m,m+1)
+ q = h(m+1,m+1)-zz-r-s
+ r = h(m+2,m+1)
+ s = dabs(p)+dabs(q)+dabs(r)
+ p = p/s
+ q = q/s
+ r = r/s
+ if (m==l)
+ break 1
+ tst1 = dabs(p)*(dabs(h(m-1,m-1))+dabs(zz)+dabs(h(m+1,m+1)))
+ tst2 = tst1+dabs(h(m,m-1))*(dabs(q)+dabs(r))
+ if (tst2==tst1)
+ break 1
+ }
+ mp2 = m+2
+ do i = mp2,en {
+ h(i,i-2) = 0.0d0
+ if (i!=mp2)
+ h(i,i-3) = 0.0d0
+ }
+# .......... double qr step involving rows l to en and
+# columns m to en ..........
+ do k = m,na {
+ notlas = k!=na
+ if (k!=m) {
+ p = h(k,k-1)
+ q = h(k+1,k-1)
+ r = 0.0d0
+ if (notlas)
+ r = h(k+2,k-1)
+ x = dabs(p)+dabs(q)+dabs(r)
+ if (x==0.0d0)
+ next 1
+ p = p/x
+ q = q/x
+ r = r/x
+ }
+ s = dsign(dsqrt(p*p+q*q+r*r),p)
+ if (k!=m)
+ h(k,k-1) = -s*x
+ else if (l!=m)
+ h(k,k-1) = -h(k,k-1)
+ p = p+s
+ x = p/s
+ y = q/s
+ zz = r/s
+ q = q/p
+ r = r/p
+ if (!notlas) {
+# .......... row modification ..........
+ do j = k,n {
+ p = h(k,j)+q*h(k+1,j)
+ h(k,j) = h(k,j)-p*x
+ h(k+1,j) = h(k+1,j)-p*y
+ }
+ j = min0(en,k+3)
+# .......... column modification ..........
+ do i = 1,j {
+ p = x*h(i,k)+y*h(i,k+1)
+ h(i,k) = h(i,k)-p
+ h(i,k+1) = h(i,k+1)-p*q
+ }
+# .......... accumulate transformations ..........
+ do i = low,igh {
+ p = x*z(i,k)+y*z(i,k+1)
+ z(i,k) = z(i,k)-p
+ z(i,k+1) = z(i,k+1)-p*q
+ }
+ }
+ else {
+# .......... row modification ..........
+ do j = k,n {
+ p = h(k,j)+q*h(k+1,j)+r*h(k+2,j)
+ h(k,j) = h(k,j)-p*x
+ h(k+1,j) = h(k+1,j)-p*y
+ h(k+2,j) = h(k+2,j)-p*zz
+ }
+ j = min0(en,k+3)
+# .......... column modification ..........
+ do i = 1,j {
+ p = x*h(i,k)+y*h(i,k+1)+zz*h(i,k+2)
+ h(i,k) = h(i,k)-p
+ h(i,k+1) = h(i,k+1)-p*q
+ h(i,k+2) = h(i,k+2)-p*r
+ }
+# .......... accumulate transformations ..........
+ do i = low,igh {
+ p = x*z(i,k)+y*z(i,k+1)+zz*z(i,k+2)
+ z(i,k) = z(i,k)-p
+ z(i,k+1) = z(i,k+1)-p*q
+ z(i,k+2) = z(i,k+2)-p*r
+ }
+ }
+ }
+ }
+# .......... two roots found ..........
+ p = (y-x)/2.0d0
+ q = p*p+w
+ zz = dsqrt(dabs(q))
+ h(en,en) = x+t
+ x = h(en,en)
+ h(na,na) = y+t
+ if (q<0.0d0) {
+# .......... complex pair ..........
+ wr(na) = x+p
+ wr(en) = x+p
+ wi(na) = zz
+ wi(en) = -zz
+ }
+ else {
+# .......... real pair ..........
+ zz = p+dsign(zz,p)
+ wr(na) = x+zz
+ wr(en) = wr(na)
+ if (zz!=0.0d0)
+ wr(en) = x-w/zz
+ wi(na) = 0.0d0
+ wi(en) = 0.0d0
+ x = h(en,na)
+ s = dabs(x)+dabs(zz)
+ p = x/s
+ q = zz/s
+ r = dsqrt(p*p+q*q)
+ p = p/r
+ q = q/r
+# .......... row modification ..........
+ do j = na,n {
+ zz = h(na,j)
+ h(na,j) = q*zz+p*h(en,j)
+ h(en,j) = q*h(en,j)-p*zz
+ }
+# .......... column modification ..........
+ do i = 1,en {
+ zz = h(i,na)
+ h(i,na) = q*zz+p*h(i,en)
+ h(i,en) = q*h(i,en)-p*zz
+ }
+# .......... accumulate transformations ..........
+ do i = low,igh {
+ zz = z(i,na)
+ z(i,na) = q*zz+p*z(i,en)
+ z(i,en) = q*z(i,en)-p*zz
+ }
+ }
+ en = enm2
+ next 1
+# .......... one root found ..........
+ 60 h(en,en) = x+t
+ wr(en) = h(en,en)
+ wi(en) = 0.0d0
+ en = na
+ }
+# .......... set error -- all eigenvalues have not
+# converged after 30*n iterations ..........
+ierr = en
+return
+# .......... all roots found. backsubstitute to find
+# vectors of upper triangular form ..........
+70 if (norm!=0.0d0) {
+# .......... for en=n step -1 until 1 do -- ..........
+ do nn = 1,n {
+ en = n+1-nn
+ p = wr(en)
+ q = wi(en)
+ na = en-1
+ if (q<0) {
+# .......... complex vector ..........
+ m = na
+# .......... last vector component chosen imaginary so that
+# eigenvector matrix is triangular ..........
+ if (dabs(h(en,na))<=dabs(h(na,en)))
+ call cdiv(0.0d0,-h(na,en),h(na,na)-p,q,h(na,na),h(na,en))
+ else {
+ h(na,na) = q/h(en,na)
+ h(na,en) = -(h(en,en)-p)/h(en,na)
+ }
+ h(en,na) = 0.0d0
+ h(en,en) = 1.0d0
+ enm2 = na-1
+ if (enm2!=0)
+# .......... for i=en-2 step -1 until 1 do -- ..........
+ do ii = 1,enm2 {
+ i = na-ii
+ w = h(i,i)-p
+ ra = 0.0d0
+ sa = 0.0d0
+ do j = m,en {
+ ra = ra+h(i,j)*h(j,na)
+ sa = sa+h(i,j)*h(j,en)
+ }
+ if (wi(i)<0.0d0) {
+ zz = w
+ r = ra
+ s = sa
+ }
+ else {
+ m = i
+ if (wi(i)==0.0d0)
+ call cdiv(-ra,-sa,w,q,h(i,na),h(i,en))
+ else {
+# .......... solve complex equations ..........
+ x = h(i,i+1)
+ y = h(i+1,i)
+ vr = (wr(i)-p)*(wr(i)-p)+wi(i)*wi(i)-q*q
+ vi = (wr(i)-p)*2.0d0*q
+ if (vr==0.0d0&&vi==0.0d0) {
+ tst1 = norm*(dabs(w)+dabs(q)+dabs(x)+dabs(y)+dabs(zz))
+ vr = tst1
+ repeat {
+ vr = 0.01d0*vr
+ tst2 = tst1+vr
+ }
+ until(tst2<=tst1)
+ }
+ call cdiv(x*r-zz*ra+q*sa,x*s-zz*sa-q*ra,vr,vi,h(i,na),h(i,en))
+ if (dabs(x)<=dabs(zz)+dabs(q)) {
+ call cdiv(-r-y*h(i,na),-s-y*h(i,en),zz,q,h(i+1,na),h(i+1,en))
+ }
+ else {
+ h(i+1,na) = (-ra-w*h(i,na)+q*h(i,en))/x
+ h(i+1,en) = (-sa-w*h(i,en)-q*h(i,na))/x
+ }
+ }
+# .......... overflow control ..........
+ t = dmax1(dabs(h(i,na)),dabs(h(i,en)))
+ if (t!=0.0d0) {
+ tst1 = t
+ tst2 = tst1+1.0d0/tst1
+ if (tst2<=tst1)
+ do j = i,en {
+ h(j,na) = h(j,na)/t
+ h(j,en) = h(j,en)/t
+ }
+ }
+ }
+ }
+ }
+ else if (q==0) {
+# .......... real vector ..........
+ m = en
+ h(en,en) = 1.0d0
+ if (na!=0)
+# .......... for i=en-1 step -1 until 1 do -- ..........
+ do ii = 1,na {
+ i = en-ii
+ w = h(i,i)-p
+ r = 0.0d0
+ do j = m,en
+ r = r+h(i,j)*h(j,en)
+ if (wi(i)<0.0d0) {
+ zz = w
+ s = r
+ }
+ else {
+ m = i
+ if (wi(i)!=0.0d0) {
+# .......... solve real equations ..........
+ x = h(i,i+1)
+ y = h(i+1,i)
+ q = (wr(i)-p)*(wr(i)-p)+wi(i)*wi(i)
+ t = (x*s-zz*r)/q
+ h(i,en) = t
+ if (dabs(x)<=dabs(zz))
+ h(i+1,en) = (-s-y*t)/zz
+ else
+ h(i+1,en) = (-r-w*t)/x
+ }
+ else {
+ t = w
+ if (t==0.0d0) {
+ tst1 = norm
+ t = tst1
+ repeat {
+ t = 0.01d0*t
+ tst2 = norm+t
+ }
+ until(tst2<=tst1)
+ }
+ h(i,en) = -r/t
+ }
+# .......... overflow control ..........
+ t = dabs(h(i,en))
+ if (t!=0.0d0) {
+ tst1 = t
+ tst2 = tst1+1.0d0/tst1
+ if (tst2<=tst1)
+ do j = i,en
+ h(j,en) = h(j,en)/t
+ }
+ }
+ }
+ }
+ }
+# .......... end back substitution.
+# vectors of isolated roots ..........
+ do i = 1,n
+ if (i<low||i>igh)
+ do j = i,n
+ z(i,j) = h(i,j)
+# .......... multiply by transformation matrix to give
+# vectors of original full matrix.
+# for j=n step -1 until low do -- ..........
+ do jj = low,n {
+ j = n+low-jj
+ m = min0(j,igh)
+ do i = low,igh {
+ zz = 0.0d0
+ do k = low,m
+ zz = zz+z(i,k)*h(k,j)
+ z(i,j) = zz
+ }
+ }
+ }
+return
+end
+
+
+
+subroutine cdiv(ar,ai,br,bi,cr,ci)
+double precision ar,ai,br,bi,cr,ci
+# complex division, (cr,ci) = (ar,ai)/(br,bi)
+double precision s,ars,ais,brs,bis
+s = dabs(br)+dabs(bi)
+ars = ar/s
+ais = ai/s
+brs = br/s
+bis = bi/s
+s = brs**2+bis**2
+cr = (ars*brs+ais*bis)/s
+ci = (ais*brs-ars*bis)/s
+return
+end
+
+
+
+subroutine rs(nm,n,a,w,matz,z,fv1,fv2,ierr)
+integer n,nm,ierr,matz
+double precision a(nm,n),w(n),z(nm,n),fv1(n),fv2(n)
+if (n>nm)
+ ierr = 10*n
+else
+ if (matz!=0) {
+# .......... find both eigenvalues and eigenvectors ..........
+ call tred2(nm,n,a,w,fv1,z)
+ call tql2(nm,n,w,fv1,z,ierr)
+ }
+else {
+# .......... find eigenvalues only ..........
+ call tred1(nm,n,a,w,fv1,fv2)
+ call tqlrat(n,w,fv2,ierr)
+ }
+return
+end
+
+
+
+subroutine tql2(nm,n,d,e,z,ierr)
+integer i,j,k,l,m,n,ii,l1,l2,nm,mml,ierr
+double precision d(n),e(n),z(nm,n)
+double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag
+ierr = 0
+if (n!=1) {
+ do i = 2,n
+ e(i-1) = e(i)
+ f = 0.0d0
+ tst1 = 0.0d0
+ e(n) = 0.0d0
+ do l = 1,n {
+ j = 0
+ h = dabs(d(l))+dabs(e(l))
+ if (tst1<h)
+ tst1 = h
+# .......... look for small sub-diagonal element ..........
+ do m = l,n {
+ tst2 = tst1+dabs(e(m))
+ if (tst2==tst1)
+ break 1
+ }
+ if (m!=l)
+ repeat {
+ if (j==30)
+ go to 10
+ j = j+1
+# .......... form shift ..........
+ l1 = l+1
+ l2 = l1+1
+ g = d(l)
+ p = (d(l1)-g)/(2.0d0*e(l))
+ r = pythag(p,1.0d0)
+ d(l) = e(l)/(p+dsign(r,p))
+ d(l1) = e(l)*(p+dsign(r,p))
+ dl1 = d(l1)
+ h = g-d(l)
+ if (l2<=n)
+ do i = l2,n
+ d(i) = d(i)-h
+ f = f+h
+# .......... ql transformation ..........
+ p = d(m)
+ c = 1.0d0
+ c2 = c
+ el1 = e(l1)
+ s = 0.0d0
+ mml = m-l
+# .......... for i=m-1 step -1 until l do -- ..........
+ do ii = 1,mml {
+ c3 = c2
+ c2 = c
+ s2 = s
+ i = m-ii
+ g = c*e(i)
+ h = c*p
+ r = pythag(p,e(i))
+ e(i+1) = s*r
+ s = e(i)/r
+ c = p/r
+ p = c*d(i)-s*g
+ d(i+1) = h+s*(c*g+s*d(i))
+# .......... form vector ..........
+ do k = 1,n {
+ h = z(k,i+1)
+ z(k,i+1) = s*z(k,i)+c*h
+ z(k,i) = c*z(k,i)-s*h
+ }
+ }
+ p = -s*s2*c3*el1*e(l)/dl1
+ e(l) = s*p
+ d(l) = c*p
+ tst2 = tst1+dabs(e(l))
+ }
+ until(tst2<=tst1)
+ d(l) = d(l)+f
+ }
+# .......... order eigenvalues and eigenvectors ..........
+ do ii = 2,n {
+ i = ii-1
+ k = i
+ p = d(i)
+ do j = ii,n
+ if (d(j)<p) {
+ k = j
+ p = d(j)
+ }
+ if (k!=i) {
+ d(k) = d(i)
+ d(i) = p
+ do j = 1,n {
+ p = z(j,i)
+ z(j,i) = z(j,k)
+ z(j,k) = p
+ }
+ }
+ }
+ return
+# .......... set error -- no convergence to an
+# eigenvalue after 30 iterations ..........
+ 10 ierr = l
+ }
+return
+end
+
+
+
+subroutine tqlrat(n,d,e2,ierr)
+integer i,j,l,m,n,ii,l1,mml,ierr
+double precision d(n),e2(n)
+double precision b,c,f,g,h,p,r,s,t,epslon,pythag
+ierr = 0
+if (n!=1) {
+ do i = 2,n
+ e2(i-1) = e2(i)
+ f = 0.0d0
+ t = 0.0d0
+ e2(n) = 0.0d0
+ do l = 1,n {
+ j = 0
+ h = dabs(d(l))+dsqrt(e2(l))
+ if (t<=h) {
+ t = h
+ b = epslon(t)
+ c = b*b
+ }
+# .......... look for small squared sub-diagonal element ..........
+ do m = l,n
+ if (e2(m)<=c)
+ break 1
+ if (m!=l)
+ repeat {
+ if (j==30)
+ go to 20
+ j = j+1
+# .......... form shift ..........
+ l1 = l+1
+ s = dsqrt(e2(l))
+ g = d(l)
+ p = (d(l1)-g)/(2.0d0*s)
+ r = pythag(p,1.0d0)
+ d(l) = s/(p+dsign(r,p))
+ h = g-d(l)
+ do i = l1,n
+ d(i) = d(i)-h
+ f = f+h
+# .......... rational ql transformation ..........
+ g = d(m)
+ if (g==0.0d0)
+ g = b
+ h = g
+ s = 0.0d0
+ mml = m-l
+# .......... for i=m-1 step -1 until l do -- ..........
+ do ii = 1,mml {
+ i = m-ii
+ p = g*h
+ r = p+e2(i)
+ e2(i+1) = s*r
+ s = e2(i)/r
+ d(i+1) = h+s*(h+d(i))
+ g = d(i)-e2(i)/g
+ if (g==0.0d0)
+ g = b
+ h = g*p/r
+ }
+ e2(l) = s*g
+ d(l) = h
+# .......... guard against underflow in convergence test ..........
+ if (h==0.0d0)
+ break 1
+ if (dabs(e2(l))<=dabs(c/h))
+ break 1
+ e2(l) = h*e2(l)
+ }
+ until(e2(l)==0.0d0)
+ p = d(l)+f
+# .......... order eigenvalues ..........
+ if (l!=1)
+# .......... for i=l step -1 until 2 do -- ..........
+ do ii = 2,l {
+ i = l+2-ii
+ if (p>=d(i-1))
+ go to 10
+ d(i) = d(i-1)
+ }
+ i = 1
+ 10 d(i) = p
+ }
+ return
+# .......... set error -- no convergence to an
+# eigenvalue after 30 iterations ..........
+ 20 ierr = l
+ }
+return
+end
+
+
+
+subroutine tred1(nm,n,a,d,e,e2)
+integer i,j,k,l,n,ii,nm,jp1
+double precision a(nm,n),d(n),e(n),e2(n)
+double precision f,g,h,scale
+do i = 1,n {
+ d(i) = a(n,i)
+ a(n,i) = a(i,i)
+ }
+# .......... for i=n step -1 until 1 do -- ..........
+do ii = 1,n {
+ i = n+1-ii
+ l = i-1
+ h = 0.0d0
+ scale = 0.0d0
+ if (l>=1) {
+# .......... scale row (algol tol then not needed) ..........
+ do k = 1,l
+ scale = scale+dabs(d(k))
+ if (scale==0.0d0)
+ do j = 1,l {
+ d(j) = a(l,j)
+ a(l,j) = a(i,j)
+ a(i,j) = 0.0d0
+ }
+ else {
+ do k = 1,l {
+ d(k) = d(k)/scale
+ h = h+d(k)*d(k)
+ }
+ e2(i) = scale*scale*h
+ f = d(l)
+ g = -dsign(dsqrt(h),f)
+ e(i) = scale*g
+ h = h-f*g
+ d(l) = f-g
+ if (l!=1) {
+# .......... form a*u ..........
+ do j = 1,l
+ e(j) = 0.0d0
+ do j = 1,l {
+ f = d(j)
+ g = e(j)+a(j,j)*f
+ jp1 = j+1
+ if (l>=jp1)
+ do k = jp1,l {
+ g = g+a(k,j)*d(k)
+ e(k) = e(k)+a(k,j)*f
+ }
+ e(j) = g
+ }
+# .......... form p ..........
+ f = 0.0d0
+ do j = 1,l {
+ e(j) = e(j)/h
+ f = f+e(j)*d(j)
+ }
+ h = f/(h+h)
+# .......... form q ..........
+ do j = 1,l
+ e(j) = e(j)-h*d(j)
+# .......... form reduced a ..........
+ do j = 1,l {
+ f = d(j)
+ g = e(j)
+ do k = j,l
+ a(k,j) = a(k,j)-f*e(k)-g*d(k)
+ }
+ }
+ do j = 1,l {
+ f = d(j)
+ d(j) = a(l,j)
+ a(l,j) = a(i,j)
+ a(i,j) = f*scale
+ }
+ next 1
+ }
+ }
+ e(i) = 0.0d0
+ e2(i) = 0.0d0
+ }
+return
+end
+
+
+
+subroutine tred2(nm,n,a,d,e,z)
+integer i,j,k,l,n,ii,nm,jp1
+double precision a(nm,n),d(n),e(n),z(nm,n)
+double precision f,g,h,hh,scale
+do i = 1,n {
+ do j = i,n
+ z(j,i) = a(j,i)
+ d(i) = a(n,i)
+ }
+if (n!=1) {
+# .......... for i=n step -1 until 2 do -- ..........
+ do ii = 2,n {
+ i = n+2-ii
+ l = i-1
+ h = 0.0d0
+ scale = 0.0d0
+ if (l>=2) {
+# .......... scale row (algol tol then not needed) ..........
+ do k = 1,l
+ scale = scale+dabs(d(k))
+ if (scale!=0.0d0) {
+ do k = 1,l {
+ d(k) = d(k)/scale
+ h = h+d(k)*d(k)
+ }
+ f = d(l)
+ g = -dsign(dsqrt(h),f)
+ e(i) = scale*g
+ h = h-f*g
+ d(l) = f-g
+# .......... form a*u ..........
+ do j = 1,l
+ e(j) = 0.0d0
+ do j = 1,l {
+ f = d(j)
+ z(j,i) = f
+ g = e(j)+z(j,j)*f
+ jp1 = j+1
+ if (l>=jp1)
+ do k = jp1,l {
+ g = g+z(k,j)*d(k)
+ e(k) = e(k)+z(k,j)*f
+ }
+ e(j) = g
+ }
+# .......... form p ..........
+ f = 0.0d0
+ do j = 1,l {
+ e(j) = e(j)/h
+ f = f+e(j)*d(j)
+ }
+ hh = f/(h+h)
+# .......... form q ..........
+ do j = 1,l
+ e(j) = e(j)-hh*d(j)
+# .......... form reduced a ..........
+ do j = 1,l {
+ f = d(j)
+ g = e(j)
+ do k = j,l
+ z(k,j) = z(k,j)-f*e(k)-g*d(k)
+ d(j) = z(l,j)
+ z(i,j) = 0.0d0
+ }
+ go to 10
+ }
+ }
+ e(i) = d(l)
+ do j = 1,l {
+ d(j) = z(l,j)
+ z(i,j) = 0.0d0
+ z(j,i) = 0.0d0
+ }
+ 10 d(i) = h
+ }
+# .......... accumulation of transformation matrices ..........
+ do i = 2,n {
+ l = i-1
+ z(n,l) = z(l,l)
+ z(l,l) = 1.0d0
+ h = d(i)
+ if (h!=0.0d0) {
+ do k = 1,l
+ d(k) = z(k,i)/h
+ do j = 1,l {
+ g = 0.0d0
+ do k = 1,l
+ g = g+z(k,i)*z(k,j)
+ do k = 1,l
+ z(k,j) = z(k,j)-g*d(k)
+ }
+ }
+ do k = 1,l
+ z(k,i) = 0.0d0
+ }
+ }
+do i = 1,n {
+ d(i) = z(n,i)
+ z(n,i) = 0.0d0
+ }
+z(n,n) = 1.0d0
+e(1) = 0.0d0
+return
+end
+
+
+
+subroutine dmatp(x,dx,y,dy,z)
+integer dx(2),dy(2)
+double precision x(1), y(1),z(1),ddot
+
+integer n,p,q,i,j
+
+n=dx(1); p=dx(2); q=dy(2)
+do i = 1,n {
+ jj = 1; ij = i
+ do j = 1, q {
+ z(ij) = ddot(p,x(i),n,y(jj),1) # x[i,1] & y[1,j]
+ if(j<q){jj = jj + p; ij = ij + n}
+ }
+}
+return
+end
+
+subroutine dmatpt(x,dx,y,dy,z)
+integer dx(2),dy(2)
+double precision x(1), y(1),z(1),ddot
+
+integer n,p,q,i,j,ii
+
+n=dx(1); p=dx(2); q=dy(2); ii=1
+do i = 1,p {
+ jj = 1; ij = i
+ do j = 1, q {
+ z(ij) = ddot(n,x(ii),1,y(jj),1) #x[1,i] & y[1,j]
+ if(j<q){jj = jj + n; ij = ij + p}
+ }
+ ii = ii +n
+}
+return
+end
+
+subroutine matpm(x,dx,mmx,mx,y,dy,mmy,my,z)
+integer dx(2),dy(2)
+integer mmx(1), mmy(1)
+integer mx(1), my(1)
+double precision x(1), y(1),z(1),ddot
+
+integer n,p,q,i,j
+
+n=dx(1); p=dx(2); q=dy(2)
+call rowmis(mmx,dx(1),dx(2),mx)
+call colmis(mmy,dy(1),dy(2),my)
+do i = 1,n {
+ jj = 1; ij = i
+ do j = 1, q {
+ if(!(mx(i)!=0 || my(j)!=0))
+ z(ij) = ddot(p,x(i),n,y(jj),1) # x[i,1] & y[1,j]
+ if(j<q){jj = jj + p; ij = ij + n}
+ }
+}
+return
+end
+
+subroutine matptm(x,dx,mmx,mx,y,dy,mmy,my,z)
+integer dx(2),dy(2)
+integer mmx(1), mmy(1)
+integer mx(1), my(1)
+double precision x(1), y(1),z(1),ddot
+
+integer n,p,q,i,j
+call colmis(mmx,dx(1),dx(2),mx)
+call colmis(mmy,dy(1),dy(2),my)
+
+n=dx(1); p=dx(2); q=dy(2); ii=1
+do i = 1,p {
+ jj = 1; ij = i
+ do j = 1, q {
+ if(!(mx(i)!=0 || my(j)!=0))
+ z(ij) = ddot(n,x(ii),1,y(jj),1) #x[1,i] & y[1,j]
+ if(j<q){jj = jj + n; ij = ij + p}
+ }
+ ii = ii +n
+}
+return
+end
+
+subroutine rowmis(m,n,p,vec)
+integer n,p
+integer m(n,p); integer vec(1)
+do i = 1,n {
+ vec(i)=0
+# vec(i)=.false.
+ do j = 1,p {
+ if(m(i,j)!=0)vec(i) = 1
+ }
+}
+return
+end
+
+subroutine colmis(m,n,p,vec)
+integer n,p
+integer m(n,p); integer vec(1)
+do j = 1,p {
+ vec(j)=0
+ do i = 1,n {
+ if(m(i,j)!=0)vec(j) = 1
+ }
+}
+return
+end
+
+subroutine daxpy(n,da,dx,incx,dy,incy)
+double precision dx(1),dy(1),da
+integer i,incx,incy,m,mp1,n
+if (n>0)
+ if (da!=0.0d0)
+ if (incx!=1||incy!=1) {
+ ix = 1
+ iy = 1
+ if (incx<0)
+ ix = (-n+1)*incx+1
+ if (incy<0)
+ iy = (-n+1)*incy+1
+ do i = 1,n {
+ dy(iy) = dy(iy)+da*dx(ix)
+ ix = ix+incx
+ iy = iy+incy
+ }
+ }
+ else {
+ m = mod(n,4)
+ if (m!=0) {
+ do i = 1,m
+ dy(i) = dy(i)+da*dx(i)
+ if (n<4)
+ return
+ }
+ mp1 = m+1
+ do i = mp1,n,4 {
+ dy(i) = dy(i)+da*dx(i)
+ dy(i+1) = dy(i+1)+da*dx(i+1)
+ dy(i+2) = dy(i+2)+da*dx(i+2)
+ dy(i+3) = dy(i+3)+da*dx(i+3)
+ }
+ }
+return
+end
+
+
+
+subroutine dcopy(n,dx,incx,dy,incy)
+double precision dx(1),dy(1)
+integer i,incx,incy,ix,iy,m,mp1,n
+if (n>0)
+ if (incx!=1||incy!=1) {
+ ix = 1
+ iy = 1
+ if (incx<0)
+ ix = (-n+1)*incx+1
+ if (incy<0)
+ iy = (-n+1)*incy+1
+ do i = 1,n {
+ dy(iy) = dx(ix)
+ ix = ix+incx
+ iy = iy+incy
+ }
+ }
+ else {
+ m = mod(n,7)
+ if (m!=0) {
+ do i = 1,m
+ dy(i) = dx(i)
+ if (n<7)
+ return
+ }
+ mp1 = m+1
+ do i = mp1,n,7 {
+ dy(i) = dx(i)
+ dy(i+1) = dx(i+1)
+ dy(i+2) = dx(i+2)
+ dy(i+3) = dx(i+3)
+ dy(i+4) = dx(i+4)
+ dy(i+5) = dx(i+5)
+ dy(i+6) = dx(i+6)
+ }
+ }
+return
+end
+
+
+
+double precision function ddot(n,dx,incx,dy,incy)
+double precision dx(1),dy(1),dtemp
+integer i,incx,incy,ix,iy,m,mp1,n
+ddot = 0.0d0
+dtemp = 0.0d0
+if (n>0)
+ if (incx==1&&incy==1) {
+ m = mod(n,5)
+ if (m!=0) {
+ do i = 1,m
+ dtemp = dtemp+dx(i)*dy(i)
+ if (n<5)
+ go to 10
+ }
+ mp1 = m+1
+ do i = mp1,n,5
+ dtemp = dtemp+dx(i)*dy(i)+dx(i+1)*dy(i+1)+dx(i+2)*dy(i+2)+dx(i+3)*dy(i+3)+dx(i+4)*dy(i+4)
+ 10 ddot = dtemp
+ }
+ else {
+ ix = 1
+ iy = 1
+ if (incx<0)
+ ix = (-n+1)*incx+1
+ if (incy<0)
+ iy = (-n+1)*incy+1
+ do i = 1,n {
+ dtemp = dtemp+dx(ix)*dy(iy)
+ ix = ix+incx
+ iy = iy+incy
+ }
+ ddot = dtemp
+ }
+return
+end
+
+
+
+double precision function dnrm2(n,dx,incx)
+integer nst
+double precision dx(1),cutlo,cuthi,hitest,sum,xmax,zero,one
+data zero,one/0.0d0,1.0d0/
+data cutlo,cuthi/8.232d-11,1.304d19/
+if (n<=0)
+ dnrm2 = zero
+else {
+ nst = 20
+ sum = zero
+ nn = n*incx
+ i = 1
+ repeat {
+ if (nst == 20) {
+ goto 20
+ } else if (nst == 30) {
+ goto 30
+ } else if (nst == 40) {
+ goto 40
+ } else if (nst == 80) {
+ goto 80
+ }
+ 20 if (dabs(dx(i))>cutlo)
+ go to 50
+ nst = 30
+ xmax = zero
+ 30 if (dx(i)==zero)
+ go to 100
+ if (dabs(dx(i))>cutlo)
+ go to 50
+ nst = 40
+ go to 70
+ 40 if (dabs(dx(i))<=cutlo)
+ go to 80
+ sum = (sum*xmax)*xmax
+ 50 hitest = cuthi/float(n)
+ do j = i,nn,incx {
+ if (dabs(dx(j))>=hitest)
+ go to 60
+ sum = sum+dx(j)**2
+ }
+ break 1
+ 60 i = j
+ nst = 80
+ sum = (sum/dx(i))/dx(i)
+ 70 xmax = dabs(dx(i))
+ go to 90
+ 80 if (dabs(dx(i))>xmax) {
+ sum = one+sum*(xmax/dx(i))**2
+ xmax = dabs(dx(i))
+ go to 100
+ }
+ 90 sum = sum+(dx(i)/xmax)**2
+ 100 i = i+incx
+ if (i>nn)
+ go to 110
+ }
+ dnrm2 = dsqrt(sum)
+ return
+ 110 dnrm2 = xmax*dsqrt(sum)
+ }
+return
+end
+
+
+
+subroutine dscal(n,da,dx,incx)
+double precision da,dx(1)
+integer i,incx,m,mp1,n,nincx
+if (n>0)
+ if (incx!=1) {
+ nincx = n*incx
+ do i = 1,nincx,incx
+ dx(i) = da*dx(i)
+ }
+ else {
+ m = mod(n,5)
+ if (m!=0) {
+ do i = 1,m
+ dx(i) = da*dx(i)
+ if (n<5)
+ return
+ }
+ mp1 = m+1
+ do i = mp1,n,5 {
+ dx(i) = da*dx(i)
+ dx(i+1) = da*dx(i+1)
+ dx(i+2) = da*dx(i+2)
+ dx(i+3) = da*dx(i+3)
+ dx(i+4) = da*dx(i+4)
+ }
+ }
+return
+end
+
+
+
+subroutine dswap(n,dx,incx,dy,incy)
+double precision dx(1),dy(1),dtemp
+integer i,incx,incy,ix,iy,m,mp1,n
+if (n>0)
+ if (incx!=1||incy!=1) {
+ ix = 1
+ iy = 1
+ if (incx<0)
+ ix = (-n+1)*incx+1
+ if (incy<0)
+ iy = (-n+1)*incy+1
+ do i = 1,n {
+ dtemp = dx(ix)
+ dx(ix) = dy(iy)
+ dy(iy) = dtemp
+ ix = ix+incx
+ iy = iy+incy
+ }
+ }
+ else {
+ m = mod(n,3)
+ if (m!=0) {
+ do i = 1,m {
+ dtemp = dx(i)
+ dx(i) = dy(i)
+ dy(i) = dtemp
+ }
+ if (n<3)
+ return
+ }
+ mp1 = m+1
+ do i = mp1,n,3 {
+ dtemp = dx(i)
+ dx(i) = dy(i)
+ dy(i) = dtemp
+ dtemp = dx(i+1)
+ dx(i+1) = dy(i+1)
+ dy(i+1) = dtemp
+ dtemp = dx(i+2)
+ dx(i+2) = dy(i+2)
+ dy(i+2) = dtemp
+ }
+ }
+return
+end
+
+
+
+subroutine dshift(x,ldx,n,j,k)
+integer ldx,n,j,k
+double precision x(ldx,k),tt
+integer i,jj
+if (k>j)
+ do i = 1,n {
+ tt = x(i,j)
+ do jj = j+1,k
+ x(i,jj-1) = x(i,jj)
+ x(i,k) = tt
+ }
+return
+end
+
+
+
+subroutine rtod(dx,dy,n)
+real dx(1)
+double precision dy(1)
+integer i,m,mp1,n
+if (n>0) {
+ m = mod(n,7)
+ if (m!=0) {
+ do i = 1,m
+ dy(i) = dx(i)
+ if (n<7)
+ return
+ }
+ mp1 = m+1
+ do i = mp1,n,7 {
+ dy(i) = dx(i)
+ dy(i+1) = dx(i+1)
+ dy(i+2) = dx(i+2)
+ dy(i+3) = dx(i+3)
+ dy(i+4) = dx(i+4)
+ dy(i+5) = dx(i+5)
+ dy(i+6) = dx(i+6)
+ }
+ }
+return
+end
+
+
+
+subroutine dtor(dx,dy,n)
+double precision dx(1)
+real dy(1)
+integer i,m,mp1,n
+if (n>0) {
+ m = mod(n,7)
+ if (m!=0) {
+ do i = 1,m
+ dy(i) = dx(i)
+ if (n<7)
+ return
+ }
+ mp1 = m+1
+ do i = mp1,n,7 {
+ dy(i) = dx(i)
+ dy(i+1) = dx(i+1)
+ dy(i+2) = dx(i+2)
+ dy(i+3) = dx(i+3)
+ dy(i+4) = dx(i+4)
+ dy(i+5) = dx(i+5)
+ dy(i+6) = dx(i+6)
+ }
+ }
+return
+end
+
+
+
+subroutine drot(n,dx,incx,dy,incy,c,s)
+double precision dx(1),dy(1),dtemp,c,s
+integer i,incx,incy,ix,iy,n
+if (n>0)
+ if (incx==1&&incy==1)
+ do i = 1,n {
+ dtemp = c*dx(i)+s*dy(i)
+ dy(i) = c*dy(i)-s*dx(i)
+ dx(i) = dtemp
+ }
+ else {
+ ix = 1
+ iy = 1
+ if (incx<0)
+ ix = (-n+1)*incx+1
+ if (incy<0)
+ iy = (-n+1)*incy+1
+ do i = 1,n {
+ dtemp = c*dx(ix)+s*dy(iy)
+ dy(iy) = c*dy(iy)-s*dx(ix)
+ dx(ix) = dtemp
+ ix = ix+incx
+ iy = iy+incy
+ }
+ }
+return
+end
+
+
+
+subroutine drotg(da,db,c,s)
+double precision da,db,c,s,roe,scale,r,z
+roe = db
+if (dabs(da)>dabs(db))
+ roe = da
+scale = dabs(da)+dabs(db)
+if (scale==0.0d0) {
+ c = 1.0d0
+ s = 0.0d0
+ r = 0.0d0
+ }
+else {
+ r = scale*dsqrt((da/scale)**2+(db/scale)**2)
+ r = dsign(1.0d0,roe)*r
+ c = da/r
+ s = db/r
+ }
+z = 1.0d0
+if (dabs(da)>dabs(db))
+ z = s
+if (dabs(db)>=dabs(da)&&c!=0.0d0)
+ z = 1.0d0/c
+da = r
+db = z
+return
+end
+
+
+
+subroutine dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info)
+integer ldx,n,k,job,info
+double precision x(ldx,1),qraux(1),y(1),qy(1),qty(1),b(1),rsd(1),xb(1)
+integer i,j,jj,ju,kp1
+double precision ddot,t,temp
+logical cb,cqy,cqty,cr,cxb
+info = 0
+cqy = job/10000!=0
+cqty = mod(job,10000)!=0
+cb = mod(job,1000)/100!=0
+cr = mod(job,100)/10!=0
+cxb = mod(job,10)!=0
+ju = min0(k,n-1)
+if (ju==0) {
+ if (cqy)
+ qy(1) = y(1)
+ if (cqty)
+ qty(1) = y(1)
+ if (cxb)
+ xb(1) = y(1)
+ if (cb)
+ if (x(1,1)!=0.0d0)
+ b(1) = y(1)/x(1,1)
+ else
+ info = 1
+ if (cr)
+ rsd(1) = 0.0d0
+ }
+else {
+ if (cqy)
+ call dcopy(n,y,1,qy,1)
+ if (cqty)
+ call dcopy(n,y,1,qty,1)
+ if (cqy)
+ do jj = 1,ju {
+ j = ju-jj+1
+ if (qraux(j)!=0.0d0) {
+ temp = x(j,j)
+ x(j,j) = qraux(j)
+ t = -ddot(n-j+1,x(j,j),1,qy(j),1)/x(j,j)
+ call daxpy(n-j+1,t,x(j,j),1,qy(j),1)
+ x(j,j) = temp
+ }
+ }
+ if (cqty)
+ do j = 1,ju
+ if (qraux(j)!=0.0d0) {
+ temp = x(j,j)
+ x(j,j) = qraux(j)
+ t = -ddot(n-j+1,x(j,j),1,qty(j),1)/x(j,j)
+ call daxpy(n-j+1,t,x(j,j),1,qty(j),1)
+ x(j,j) = temp
+ }
+ if (cb)
+ call dcopy(k,qty,1,b,1)
+ kp1 = k+1
+ if (cxb)
+ call dcopy(k,qty,1,xb,1)
+ if (cr&&k<n)
+ call dcopy(n-k,qty(kp1),1,rsd(kp1),1)
+ if (cxb&&kp1<=n)
+ do i = kp1,n
+ xb(i) = 0.0d0
+ if (cr)
+ do i = 1,k
+ rsd(i) = 0.0d0
+ if (cb) {
+ do jj = 1,k {
+ j = k-jj+1
+ if (x(j,j)==0.0d0)
+ go to 130
+ b(j) = b(j)/x(j,j)
+ if (j!=1) {
+ t = -b(j)
+ call daxpy(j-1,t,x(1,j),1,b,1)
+ }
+ }
+ go to 140
+ 130 info = j
+ }
+ 140 if (cr||cxb)
+ do jj = 1,ju {
+ j = ju-jj+1
+ if (qraux(j)!=0.0d0) {
+ temp = x(j,j)
+ x(j,j) = qraux(j)
+ if (cr) {
+ t = -ddot(n-j+1,x(j,j),1,rsd(j),1)/x(j,j)
+ call daxpy(n-j+1,t,x(j,j),1,rsd(j),1)
+ }
+ if (cxb) {
+ t = -ddot(n-j+1,x(j,j),1,xb(j),1)/x(j,j)
+ call daxpy(n-j+1,t,x(j,j),1,xb(j),1)
+ }
+ x(j,j) = temp
+ }
+ }
+ }
+return
+end
+
+subroutine dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info)
+integer ldx,n,p,ldu,ldv,job,info
+double precision x(ldx,1),s(1),e(1),u(ldu,1),v(ldv,1),work(1)
+integer i,iter,j,jobu,k,kase,kk,l,ll,lls,lm1,lp1,ls,lu,m,maxit,mm,mm1,mp1,nct,nctp1,ncu,nrt,nrtp1
+double precision ddot,t
+double precision b,c,cs,el,emm1,f,g,dnrm2,scale,shift,sl,sm,sn,smm1,t1,test,ztest
+logical wantu,wantv
+maxit = 30
+wantu = .false.
+wantv = .false.
+jobu = mod(job,100)/10
+ncu = n
+if (jobu>1)
+ ncu = min0(n,p)
+if (jobu!=0)
+ wantu = .true.
+if (mod(job,10)!=0)
+ wantv = .true.
+info = 0
+nct = min0(n-1,p)
+nrt = max0(0,min0(p-2,n))
+lu = max0(nct,nrt)
+if (lu>=1)
+ do l = 1,lu {
+ lp1 = l+1
+ if (l<=nct) {
+ s(l) = dnrm2(n-l+1,x(l,l),1)
+ if (s(l)!=0.0d0) {
+ if (x(l,l)!=0.0d0)
+ s(l) = dsign(s(l),x(l,l))
+ call dscal(n-l+1,1.0d0/s(l),x(l,l),1)
+ x(l,l) = 1.0d0+x(l,l)
+ }
+ s(l) = -s(l)
+ }
+ if (p>=lp1)
+ do j = lp1,p {
+ if (l<=nct)
+ if (s(l)!=0.0d0) {
+ t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l)
+ call daxpy(n-l+1,t,x(l,l),1,x(l,j),1)
+ }
+ e(j) = x(l,j)
+ }
+ if (wantu&&l<=nct)
+ do i = l,n
+ u(i,l) = x(i,l)
+ if (l<=nrt) {
+ e(l) = dnrm2(p-l,e(lp1),1)
+ if (e(l)!=0.0d0) {
+ if (e(lp1)!=0.0d0)
+ e(l) = dsign(e(l),e(lp1))
+ call dscal(p-l,1.0d0/e(l),e(lp1),1)
+ e(lp1) = 1.0d0+e(lp1)
+ }
+ e(l) = -e(l)
+ if (lp1<=n&&e(l)!=0.0d0) {
+ do i = lp1,n
+ work(i) = 0.0d0
+ do j = lp1,p
+ call daxpy(n-l,e(j),x(lp1,j),1,work(lp1),1)
+ do j = lp1,p
+ call daxpy(n-l,-e(j)/e(lp1),work(lp1),1,x(lp1,j),1)
+ }
+ if (wantv)
+ do i = lp1,p
+ v(i,l) = e(i)
+ }
+ }
+m = min0(p,n+1)
+nctp1 = nct+1
+nrtp1 = nrt+1
+if (nct<p)
+ s(nctp1) = x(nctp1,nctp1)
+if (n<m)
+ s(m) = 0.0d0
+if (nrtp1<m)
+ e(nrtp1) = x(nrtp1,m)
+e(m) = 0.0d0
+if (wantu) {
+ if (ncu>=nctp1)
+ do j = nctp1,ncu {
+ do i = 1,n
+ u(i,j) = 0.0d0
+ u(j,j) = 1.0d0
+ }
+ if (nct>=1)
+ do ll = 1,nct {
+ l = nct-ll+1
+ if (s(l)==0.0d0) {
+ do i = 1,n
+ u(i,l) = 0.0d0
+ u(l,l) = 1.0d0
+ }
+ else {
+ lp1 = l+1
+ if (ncu>=lp1)
+ do j = lp1,ncu {
+ t = -ddot(n-l+1,u(l,l),1,u(l,j),1)/u(l,l)
+ call daxpy(n-l+1,t,u(l,l),1,u(l,j),1)
+ }
+ call dscal(n-l+1,-1.0d0,u(l,l),1)
+ u(l,l) = 1.0d0+u(l,l)
+ lm1 = l-1
+ if (lm1>=1)
+ do i = 1,lm1
+ u(i,l) = 0.0d0
+ }
+ }
+ }
+if (wantv)
+ do ll = 1,p {
+ l = p-ll+1
+ lp1 = l+1
+ if (l<=nrt)
+ if (e(l)!=0.0d0)
+ do j = lp1,p {
+ t = -ddot(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l)
+ call daxpy(p-l,t,v(lp1,l),1,v(lp1,j),1)
+ }
+ do i = 1,p
+ v(i,l) = 0.0d0
+ v(l,l) = 1.0d0
+ }
+mm = m
+iter = 0
+repeat {
+ if (m==0)
+ return
+ if (iter>=maxit)
+ break 1
+ do ll = 1,m {
+ l = m-ll
+ if (l==0)
+ break 1
+ test = dabs(s(l))+dabs(s(l+1))
+ ztest = test+dabs(e(l))
+ if (ztest==test)
+ go to 150
+ }
+ go to 160
+ 150 e(l) = 0.0d0
+ 160 if (l==m-1)
+ kase = 4
+ else {
+ lp1 = l+1
+ mp1 = m+1
+ do lls = lp1,mp1 {
+ ls = m-lls+lp1
+ if (ls==l)
+ break 1
+ test = 0.0d0
+ if (ls!=m)
+ test = test+dabs(e(ls))
+ if (ls!=l+1)
+ test = test+dabs(e(ls-1))
+ ztest = test+dabs(s(ls))
+ if (ztest==test)
+ go to 170
+ }
+ go to 180
+ 170 s(ls) = 0.0d0
+ 180 if (ls==l)
+ kase = 3
+ else if (ls==m)
+ kase = 1
+ else {
+ kase = 2
+ l = ls
+ }
+ }
+ l = l+1
+ switch(kase) {
+ case 1:
+ mm1 = m-1
+ f = e(m-1)
+ e(m-1) = 0.0d0
+ do kk = l,mm1 {
+ k = mm1-kk+l
+ t1 = s(k)
+ call drotg(t1,f,cs,sn)
+ s(k) = t1
+ if (k!=l) {
+ f = -sn*e(k-1)
+ e(k-1) = cs*e(k-1)
+ }
+ if (wantv)
+ call drot(p,v(1,k),1,v(1,m),1,cs,sn)
+ }
+ case 2:
+ f = e(l-1)
+ e(l-1) = 0.0d0
+ do k = l,m {
+ t1 = s(k)
+ call drotg(t1,f,cs,sn)
+ s(k) = t1
+ f = -sn*e(k)
+ e(k) = cs*e(k)
+ if (wantu)
+ call drot(n,u(1,k),1,u(1,l-1),1,cs,sn)
+ }
+ case 3:
+ scale = dmax1(dabs(s(m)),dabs(s(m-1)),dabs(e(m-1)),dabs(s(l)),dabs(e(l)))
+ sm = s(m)/scale
+ smm1 = s(m-1)/scale
+ emm1 = e(m-1)/scale
+ sl = s(l)/scale
+ el = e(l)/scale
+ b = ((smm1+sm)*(smm1-sm)+emm1**2)/2.0d0
+ c = (sm*emm1)**2
+ shift = 0.0d0
+ if (b!=0.0d0||c!=0.0d0) {
+ shift = dsqrt(b**2+c)
+ if (b<0.0d0)
+ shift = -shift
+ shift = c/(b+shift)
+ }
+ f = (sl+sm)*(sl-sm)+shift
+ g = sl*el
+ mm1 = m-1
+ do k = l,mm1 {
+ call drotg(f,g,cs,sn)
+ if (k!=l)
+ e(k-1) = f
+ f = cs*s(k)+sn*e(k)
+ e(k) = cs*e(k)-sn*s(k)
+ g = sn*s(k+1)
+ s(k+1) = cs*s(k+1)
+ if (wantv)
+ call drot(p,v(1,k),1,v(1,k+1),1,cs,sn)
+ call drotg(f,g,cs,sn)
+ s(k) = f
+ f = cs*e(k)+sn*s(k+1)
+ s(k+1) = -sn*e(k)+cs*s(k+1)
+ g = sn*e(k+1)
+ e(k+1) = cs*e(k+1)
+ if (wantu&&k<n)
+ call drot(n,u(1,k),1,u(1,k+1),1,cs,sn)
+ }
+ e(m-1) = f
+ iter = iter+1
+ case 4:
+ if (s(l)<0.0d0) {
+ s(l) = -s(l)
+ if (wantv)
+ call dscal(p,-1.0d0,v(1,l),1)
+ }
+ while (l!=mm) {
+ if (s(l)>=s(l+1))
+ break 1
+ t = s(l)
+ s(l) = s(l+1)
+ s(l+1) = t
+ if (wantv&&l<p)
+ call dswap(p,v(1,l),1,v(1,l+1),1)
+ if (wantu&&l<n)
+ call dswap(n,u(1,l),1,u(1,l+1),1)
+ l = l+1
+ }
+ iter = 0
+ m = m-1
+ }
+ }
+info = m
+return
+end
+
+subroutine dbksl(x,p,k,b,q,info)
+integer p,k,q,info
+double precision x(p,p),b(p,q)
+double precision t; integer j,l
+info = 0
+for(j=k; j>0; j = j-1) {
+ if (x(j,j)==0.0d0)
+ {info = j; break}
+ for(l=1; l<=q; l = l+1) {
+ b(j,l) = b(j,l)/x(j,j)
+ if (j!=1) {
+ t = -b(j,l)
+ call daxpy(j-1,t,x(1,j),1,b(1,l),1)
+ }
+ }
+}
+return
+end
+
+subroutine dtrsl(t,ldt,n,b,job,info)
+integer ldt,n,job,info
+double precision t(ldt,1),b(1)
+double precision ddot,temp
+integer which,j,jj
+# check for zero diagonal elements.
+do info = 1,n
+ if (t(info,info)==0.0d0)
+ return
+info = 0
+# determine the task and go to it.
+which = 1
+if (mod(job,10)!=0)
+ which = 2
+if (mod(job,100)/10!=0)
+ which = which+2
+switch(which) {
+ case 1:
+ b(1) = b(1)/t(1,1)
+ if (n>=2)
+ do j = 2,n {
+ temp = -b(j-1)
+ call daxpy(n-j+1,temp,t(j,j-1),1,b(j),1)
+ b(j) = b(j)/t(j,j)
+ }
+ case 2:
+ b(n) = b(n)/t(n,n)
+ if (n>=2)
+ do jj = 2,n {
+ j = n-jj+1
+ temp = -b(j+1)
+ call daxpy(j,temp,t(1,j+1),1,b(1),1)
+ b(j) = b(j)/t(j,j)
+ }
+ case 3:
+ b(n) = b(n)/t(n,n)
+ if (n>=2)
+ do jj = 2,n {
+ j = n-jj+1
+ b(j) = b(j)-ddot(jj-1,t(j+1,j),1,b(j+1),1)
+ b(j) = b(j)/t(j,j)
+ }
+ case 4:
+ b(1) = b(1)/t(1,1)
+ if (n>=2)
+ do j = 2,n {
+ b(j) = b(j)-ddot(j-1,t(1,j),1,b(1),1)
+ b(j) = b(j)/t(j,j)
+ }
+ }
+return
+end
diff --git a/man/anova.gam.Rd b/man/anova.gam.Rd
new file mode 100644
index 0000000..d3676a0
--- /dev/null
+++ b/man/anova.gam.Rd
@@ -0,0 +1,67 @@
+\name{anova.gam}
+\alias{anova.gam}
+\alias{summary.gam}
+\title{Analysis of Deviance for a Generalized Additive Model}
+\description{Produces an ANODEV table for a set of GAM models, or else a
+summary for a single GAM model}
+\usage{
+\method{anova}{gam}(object, \dots, test)
+\method{summary}{gam}(object, dispersion=NULL,\dots)
+}
+\arguments{
+ \item{object}{a fitted gam}
+ \item{\dots}{other fitted gams for \code{anova}}
+ \item{test}{a character string specifying the test statistic to be used.
+ Can be one of '"F"', '"Chisq"' or '"Cp"', with partial
+ matching allowed, or 'NULL' for no test.}
+ \item{dispersion}{a dispersion parameter to be used in computing
+ standard errors}
+ }
+\details{
+These are methods for the functions \code{anova} or \code{summary} for objects inheriting from class `gam'.
+See \code{\link{anova}} for the general behavior of this function
+and for the interpretation of `test'.
+
+
+When called with a single `gam' object, a special anova table for `gam'
+models is returned. This gives a breakdown of the degrees of freedom for
+all the terms in the model, separating the projection part and
+nonparametric part of each. For example, a term specified by `s()' is
+broken down into a single degree of freedom for its linear component,
+and the remainder for the nonparametric component. In addition, a type
+of score test is performed for each of the nonparametric terms. The
+nonparametric component is set to zero, and the linear part is updated,
+holding the other nonparametric terms fixed. This is done efficiently
+and simulataneously for all terms. }
+\author{
+ Written by Trevor Hastie, following closely the design in the
+ "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and
+ Hastie (1992).
+ }
+\references{
+ Hastie, T. J. (1992)
+ \emph{Generalized additive models.}
+ Chapter 7 of \emph{Statistical Models in S}
+ eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole.
+
+ Hastie, T. and Tibshirani, R. (1990)
+ \emph{Generalized Additive Models.}
+ London: Chapman and Hall.
+
+ Venables, W. N. and Ripley, B. D. (2002)
+ \emph{Modern Applied Statistics with S.}
+ New York: Springer.
+}
+
+\examples{
+data(gam.data)
+gam.object <- gam(y~s(x,6)+z,data=gam.data)
+anova(gam.object)
+gam.object2 <- update(gam.object, ~.-z)
+anova(gam.object, gam.object2, test="Chisq")
+}
+\keyword{models}
+\keyword{regression}
+\keyword{nonparametric}
+\keyword{smooth}
+
diff --git a/man/gam-internal.Rd b/man/gam-internal.Rd
new file mode 100644
index 0000000..3d6dc2a
--- /dev/null
+++ b/man/gam-internal.Rd
@@ -0,0 +1,39 @@
+\name{gam-internal}
+\title{Service functions and as yet undocumented functions for the gam library}
+\alias{.First.lib}
+\alias{[.smooth}
+\alias{all.wam}
+\alias{anova.gamlist}
+\alias{as.anova}
+\alias{as.data.frame.lo.smooth}
+\alias{assign.list}
+\alias{deviance.default}
+\alias{deviance.glm}
+\alias{deviance.lm}
+\alias{gamlist}
+\alias{gam.match}
+\alias{gam.nlchisq}
+\alias{gam.random}
+\alias{gam.scope}
+\alias{gam.slist}
+\alias{gam.sp}
+\alias{gam.wlist}
+\alias{gplot}
+\alias{gplot.default}
+\alias{gplot.factor}
+\alias{gplot.list}
+\alias{gplot.matrix}
+\alias{gplot.numeric}
+\alias{labels.gam}
+\alias{lo.wam}
+\alias{newdata.predict.gam}
+\alias{polylo}
+\alias{print.gam}
+\alias{print.gamex}
+\alias{print.summary.gam}
+\alias{random}
+\alias{s.wam}
+\alias{ylim.scale}
+\description{Internal gam functions}
+\author{Trevor Hastie}
+\keyword{internal}
diff --git a/man/gam.Rd b/man/gam.Rd
new file mode 100644
index 0000000..2906746
--- /dev/null
+++ b/man/gam.Rd
@@ -0,0 +1,258 @@
+\name{gam}
+\title{Fitting Generalized Additive Models}
+\alias{gam}
+\alias{gam.fit}
+\concept{nonparametric}
+\concept{additive}
+\concept{regression}
+\concept{logistic}
+\concept{log-linear}
+\concept{loglinear}
+\description{
+ \code{gam} is used to fit generalized additive models, specified by
+ giving a symbolic description of the additive predictor and a
+ description of the error distribution. \code{gam} uses the
+ \emph{backfitting algorithm} to combine different smoothing or
+ fitting methods. The methods currently supported are local regression
+ and smoothing splines.
+ }
+\usage{
+gam(formula, family = gaussian, data, weights, subset, na.action,
+ start, etastart, mustart, control = gam.control(\ldots),
+model=FALSE, method, x=FALSE, y=TRUE, \dots)
+
+gam.fit(x, y, smooth.frame, weights = rep(1,nobs), start = NULL,
+ etastart = NULL, mustart = NULL, offset = rep(0, nobs), family = gaussian(),
+ control = gam.control())
+}
+\arguments{
+
+ \item{formula}{a formula expression as for other regression models, of
+ the form \code{response ~ predictors}. See the documentation of
+ \code{lm} and \code{formula} for details. Built-in nonparametric
+smoothing terms are indicated by \code{s} for smoothing splines or
+\code{lo} for \code{loess} smooth terms. See the documentation for
+\code{s} and \code{lo} for their arguments. Additional smoothers can be
+added by creating the appropriate interface functions. Interactions with
+nonparametric smooth terms are not fully supported, but will not produce
+errors; they will simply produce the usual parametric interaction.}
+
+\item{family}{a description of the error distribution and link
+ function to be used in the model. This can be a character string
+ naming a family function, a family function or the result of a call
+ to a family function. (See \code{\link{family}} for details of
+ family functions.)}
+
+ \item{data}{an optional data frame containing the variables
+ in the model. If not found in \code{data}, the variables are taken
+ from \code{environment(formula)}, typically the environment from
+ which \code{gam} is called.}
+
+ \item{weights}{an optional vector of weights to be used
+ in the fitting process.}
+
+ \item{subset}{an optional vector specifying a subset of observations
+ to be used in the fitting process.}
+
+ \item{na.action}{a function which indicates what should happen
+ when the data contain \code{NA}s. The default is set by
+ the \code{na.action} setting of \code{\link{options}}, and is
+ \code{\link{na.fail}} if that is unset. The \dQuote{factory-fresh}
+ default is \code{\link{na.omit}}. A special method
+ \code{\link{na.gam.replace}} allows for mean-imputation of missing
+ values (assumes missing at random), and works gracefully with \code{gam}}
+
+ \item{start}{starting values for the parameters in the additive predictor.}
+
+ \item{etastart}{starting values for the additive predictor.}
+
+ \item{mustart}{starting values for the vector of means.}
+
+ \item{offset}{this can be used to specify an \emph{a priori}
+ known component to be included in the additive predictor
+ during fitting.}
+
+ \item{control}{a list of parameters for controlling the fitting
+ process. See the documentation for \code{\link{gam.control}}
+ for details. These can also be set as arguments to \code{gam()} itself.
+}
+
+ \item{model}{a logical value indicating whether \emph{model frame}
+ should be included as a component of the returned value.}
+
+ \item{method}{the method to be used in fitting the parametric part of
+ the model.
+ The default method \code{"glm.fit"} uses iteratively reweighted
+ least squares (IWLS). The only current alternative is
+ \code{"model.frame"} which returns the model frame and does no fitting.}
+
+ \item{x, y}{For \code{gam}:
+ logical values indicating whether the response
+ vector and model matrix used in the fitting process
+ should be returned as components of the returned value.
+
+ For \code{gam.fit}: \code{x} is a model matrix of dimension \code{n
+ * p}, and \code{y} is a vector of observations of length \code{n}.
+ }
+\item{smooth.frame}{for \code{gam.fit} only. This is essentially a
+ subset of the model frame corresponding to the smooth terms, and has
+ the ingredients needed for smoothing each variable in the backfitting
+ algorithm. The elements of this frame are produced by the formula
+ functions \code{lo} and \code{s}.}
+ \item{\dots}{further arguments passed to or from other methods.}
+ }
+
+\details{
+ The gam model is fit using the local scoring algorithm, which
+iteratively fits weighted additive models by backfitting. The
+backfitting algorithm is a Gauss-Seidel method for fitting additive
+models, by iteratively smoothing partial residuals. The algorithm
+separates the parametric from the nonparametric part of the fit, and
+fits the parametric part using weighted linear least squares within the
+backfitting algorithm. This version of \code{gam} remains faithful to
+the philosophy of GAM models as outlined in the references below.
+
+An object \code{gam.slist} (currently set to
+\code{c("lo","s","random")}) lists the smoothers supported by
+\code{gam}. Corresponding to each of these is a smoothing function
+\code{gam.lo}, \code{gam.s} etc that take particular arguments and
+produce particular output, custom built to serve as building blocks in
+the backfitting algorithm. This allows users to add their own smoothing
+methods. See the documentation for these methods for further information.
+In addition, the object \code{gam.wlist} (currently set to
+\code{c("s","lo")}) lists the smoothers for which efficient backfitters
+are provided. These are invoked if all the smoothing methods are of one
+kind (either all \code{"lo"} or all \code{"s"}).
+}
+\value{
+\code{gam} returns an object of class \code{gam}, which inherits from
+both \code{glm} and \code{lm}.
+
+Gam objects can be examined by \code{print}, \code{summary},
+\code{plot}, and \code{anova}. Components can be extracted using
+extractor functions \code{predict}, \code{fitted}, \code{residuals},
+\code{deviance}, \code{formula}, and \code{family}. Can be modified
+using \code{update}. It has all the components of a \code{glm} object,
+with a few more. This also means it can be queried, summarized etc by
+methods for \code{glm} and \code{lm} objects. Other generic functions
+that have methods for \code{gam} objects are \code{step} and
+\code{preplot}.
+
+The following components must be included in a legitimate `gam' object.
+The residuals, fitted values, coefficients and effects should be extracted
+by the generic functions of the same name, rather than
+by the \code{"$"} operator.
+The \code{family} function returns the entire family object used in the fitting, and \code{deviance} can be used to extract the deviance of the fit.
+
+\item{coefficients}{
+the coefficients of the parametric part of the \code{additive.predictors}, which multiply the
+columns of the model
+matrix.
+The names of the coefficients are the names of the
+single-degree-of-freedom effects (the columns of the
+model matrix).
+If the model is overdetermined there will
+be missing values in the coefficients corresponding to inestimable
+coefficients.
+}
+\item{additive.predictors}{
+the additive fit, given by the product of the model matrix and the coefficients, plus the columns of the \code{$smooth} component.
+}
+\item{fitted.values}{
+the fitted mean values, obtained by transforming the component \code{additive.predictors} using the inverse link function.
+}
+\item{smooth, nl.df, nl.chisq, var}{
+these four characterize the nonparametric aspect of the fit.
+\code{smooth} is a matrix of smooth terms, with a column corresponding to each smooth term in the model; if no smooth terms are in the \code{gam} model, all these components will be missing.
+Each column corresponds to the strictly nonparametric part of the term, while the parametric part is obtained from the model matrix.
+\code{nl.df} is a vector giving the approximate degrees of freedom for each column of \code{smooth}. For smoothing splines specified by \code{s(x)}, the approximate \code{df} will be the trace of the implicit smoother matrix minus 2.
+\code{nl.chisq} is a vector containing a type of score test for the removal of each of the columns of \code{smooth}.
+\code{var} is a matrix like \code{smooth}, containing the approximate pointwise variances for the columns of \code{smooth}.
+}
+\item{smooth.frame}{This is essentially a subset of the model frame
+ corresponding to the smooth terms, and has the ingredients needed for
+ making predictions from a \code{gam} object}
+\item{residuals}{
+the residuals from the final weighted additive fit; also known as
+residuals, these are typically not interpretable without rescaling by the weights.
+}
+\item{deviance}{
+up to a constant, minus twice the maximized log-likelihood. Similar to
+the residual sum of squares. Where sensible, the constant is chosen so that a
+ saturated model has deviance zero.
+}
+\item{null.deviance}{The deviance for the null model, comparable with
+ \code{deviance}. The null model will include the offset, and an
+ intercept if there is one in the model}
+\item{iter}{
+the number of local scoring
+iterations used to compute the estimates.
+}
+\item{family}{
+a three-element character vector giving the name of the family, the link, and the variance function; mainly for printing purposes.
+}
+\item{weights}{the \emph{working} weights, that is the weights
+ in the final iteration of the local scoring fit.}
+\item{prior.weights}{the case weights initially supplied.}
+\item{df.residual}{the residual degrees of freedom.}
+\item{df.null}{the residual degrees of freedom for the null model.}
+
+The object will also have the components of a \code{lm} object:
+\code{coefficients}, \code{residuals}, \code{fitted.values},
+\code{call}, \code{terms}, and some
+others involving the numerical fit. See \code{lm.object}.
+
+}
+
+
+\seealso{
+\code{\link{glm}}, \code{\link{family}}, \code{\link{lm}}.
+}
+\author{
+ Written by Trevor Hastie, following closely the design in the
+ "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and
+ Hastie (1992), and the philosophy in Hastie and Tibshirani (1991).
+ This version of \code{gam} is adapted from the S
+ version to match the \code{glm} and \code{lm} functions in R.
+
+ Note that this version of \code{gam} is different from the function
+with
+ the same name in the R library \code{mgcv}, which uses only smoothing
+ splines with a focus on automatic smoothing parameter selection via
+ GCV.
+
+ }
+\references{
+ Hastie, T. J. (1991)
+ \emph{Generalized additive models.}
+ Chapter 7 of \emph{Statistical Models in S}
+ eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole.
+
+ Hastie, T. and Tibshirani, R. (1990)
+ \emph{Generalized Additive Models.}
+ London: Chapman and Hall.
+
+ Venables, W. N. and Ripley, B. D. (2002)
+ \emph{Modern Applied Statistics with S.}
+ New York: Springer.
+}
+
+\examples{
+data(kyphosis)
+gam(Kyphosis ~ s(Age,4) + Number, family = binomial, data=kyphosis,
+trace=TRUE)
+data(airquality)
+gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data=airquality, na=na.gam.replace)
+gam(Kyphosis ~ poly(Age,2) + s(Start), data=kyphosis, family=binomial, subset=Number>2)
+data(gam.data)
+gam.object <- gam(y ~ s(x,6) + z,data=gam.data)
+summary(gam.object)
+plot(gam.object,se=TRUE)
+data(gam.newdata)
+predict(gam.object,type="terms",newdata=gam.newdata)
+}
+
+\keyword{models}
+\keyword{regression}
+\keyword{nonparametric}
+\keyword{smooth}
diff --git a/man/gam.control.Rd b/man/gam.control.Rd
new file mode 100644
index 0000000..ceb40cf
--- /dev/null
+++ b/man/gam.control.Rd
@@ -0,0 +1,43 @@
+\name{gam.control}
+\alias{gam.control}
+\title{Auxilliary for controlling GAM fitting}
+\description{Auxiliary function as user interface for 'gam' fitting. Typically
+ only used when calling 'gam' or 'gam.fit'.}
+\usage{
+gam.control(epsilon=1e-07, bf.epsilon = 1e-07, maxit=30, bf.maxit = 30, trace=FALSE,\ldots)
+}
+\arguments{
+\item{epsilon}{
+convergence threshold for local scoring iterations
+}
+\item{bf.epsilon}{
+convergence threshold for backfitting iterations
+}
+\item{maxit}{
+maximum number of local scoring iterations
+}
+\item{bf.maxit}{
+maximum number of backfitting iterations
+}
+\item{trace}{
+should iteration details be printed while \code{gam} is fitting the model.
+}
+\item{\ldots}{Placemark for additional arguments}
+}
+\value{
+a list is returned, consisting of the five parameters, conveniently packaged up to supply the \code{control} argument to \code{gam}. The values for \code{gam.control} can be supplied directly in a call to \code{gam}; these are then filtered through \code{gam.control} inside \code{gam}.
+}
+\references{
+ Hastie, T. J. (1992)
+ \emph{Generalized additive models.}
+ Chapter 7 of \emph{Statistical Models in S}
+ eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole.
+ }
+\examples{
+\dontrun{gam(formula, family, control = gam.control(bf.maxit=15))}
+\dontrun{gam(formula, family, bf.maxit = 15) # these are equivalent}
+}
+\keyword{models}
+\keyword{regression}
+\keyword{nonparametric}
+\keyword{smooth}
diff --git a/man/gam.data.Rd b/man/gam.data.Rd
new file mode 100644
index 0000000..ca5a0ea
--- /dev/null
+++ b/man/gam.data.Rd
@@ -0,0 +1,32 @@
+\name{gam.data}
+\alias{gam.data}
+\alias{gam.newdata}
+\docType{data}
+\title{Simulated dataset for gam}
+\description{
+A simple simulated dataset, used to test out the gam functions
+}
+\usage{
+data(gam.data)
+data(gam.newdata)
+}
+\format{
+ A data frame with 100 observations on the following 6 variables.
+ \describe{
+ \item{x}{a numeric vector - predictor}
+ \item{y}{a numeric vector - the response}
+ \item{z}{a numeric vector - noise predictor}
+ \item{f}{a numeric vector - true function}
+ \item{probf}{a numeric vector - probability function}
+ \item{ybin}{a numeric vector - binary response}
+ }
+}
+\details{
+This dataset is artificial, and is used to test out some of the features
+of gam.
+}
+\examples{
+data(gam.data)
+gam(y ~ s(x) + z, data=gam.data)
+}
+\keyword{datasets}
diff --git a/man/gam.exact.Rd b/man/gam.exact.Rd
new file mode 100644
index 0000000..3f61235
--- /dev/null
+++ b/man/gam.exact.Rd
@@ -0,0 +1,50 @@
+\name{gam.exact}
+\alias{gam.exact}
+\title{A method for gam producing asymptotically exact standard errors
+ for linear estimates}
+\description{This function is a "wrapper" for a gam object, and produces exact standard errors
+ for each linear term in the gam call (except for the intercept).}
+\usage{
+gam.exact(gam.obj)
+}
+\arguments{
+ \item{gam.obj}{a gam object}
+}
+\details{
+ Only standard errors for the linear terms are produced.
+There is a print method for the gamex class.
+}
+\value{
+ A list (of class gamex) containing a table of coefficients and a variance
+ covariance matrix for the linear terms in the formula of the gam call.
+ }
+\references{[1] Issues in Semiparametric Regression: A Case Study of Time Series Models
+ in Air Pollution and Mortality, Dominici F., McDermott A., Hastie T.J.,
+ \emph{JASA}, December 2004, 99(468), 938-948. See
+ \url{http://www-stat.stanford.edu/~hastie/Papers/dominiciR2.pdf}
+ }
+ \author{Aidan McDermott, Department of Biostatistics, Johns
+ Hopkins University. See \url{http://ihapss.biostat.jhsph.edu/software/gam.exact/gam.exact.htm}
+ Modified by Trevor Hastie for R}
+ \examples{
+set.seed(31)
+n <- 200
+x <- rnorm(n)
+y <- rnorm(n)
+a <- rep(1:10,length=n)
+b <- rnorm(n)
+z <- 1.4 + 2.1*a + 1.2*b + 0.2*sin(x/(3*max(x))) + 0.3*cos(y/(5*max(y))) + 0.5 * rnorm(n)
+dat <- data.frame(x,y,a,b,z,testit=b*2)
+### Model 1: Basic
+gam.o <- gam(z ~ a + b + s(x,3) + s(y,5), data=dat)
+coefficients(summary.glm(gam.o))
+gam.exact(gam.o)
+### Model 2: Poisson
+gam.o <- gam(round(abs(z)) ~ a + b + s(x,3) + s(y,5), data=dat,family=poisson)
+coefficients(summary.glm(gam.o))
+gam.exact(gam.o)
+}
+\keyword{models}
+\keyword{regression}
+\keyword{nonparametric}
+\keyword{smooth}
diff --git a/man/kyphosis.Rd b/man/kyphosis.Rd
new file mode 100644
index 0000000..f8d0260
--- /dev/null
+++ b/man/kyphosis.Rd
@@ -0,0 +1,26 @@
+\name{kyphosis}
+\alias{kyphosis}
+\docType{data}
+\title{A classic example dataset for GAMs}
+\description{
+Data on the results of a spinal operation "laminectomy" on children, to
+correct for a condition called "kyphosis"; see Hastie and
+Tibshirani (1990) for details}
+\usage{
+data(kyphosis)
+}
+\format{A data frame with 81 observations on the following 4 variables.
+ \describe{
+ \item{Kyphosis}{a response factor with levels \code{absent}
+ \code{present}.}
+ \item{Age}{of child in months, a numeric vector}
+ \item{Number}{of vertebra involved in the operation,a numeric vector}
+ \item{Start}{level of the operation, a numeric vector}
+ }
+}
+\source{
+ Hastie, T. and Tibshirani, R. (1990)
+ \emph{Generalized Additive Models.}
+ London: Chapman and Hall.
+}
+\keyword{datasets}
diff --git a/man/lo.Rd b/man/lo.Rd
new file mode 100644
index 0000000..297895b
--- /dev/null
+++ b/man/lo.Rd
@@ -0,0 +1,120 @@
+\name{lo}
+\alias{lo}
+\alias{gam.lo}
+\title{Specify a loess fit in a GAM formula}
+\description{A symbolic wrapper to indicate a smooth term in a formala
+ argument to gam}
+\usage{
+lo(\dots, span=0.5, degree=1)
+gam.lo(x, y, w, span, degree, ncols, xeval)
+}
+\arguments{
+\item{...}{
+the unspecified \code{\dots} can be a comma-separated list of numeric vectors, numeric matrix, or expressions that evaluate to either of these. If it is a list of vectors, they must all have the same length.}
+\item{span}{
+the number of observations in a neighborhood. This is the smoothing
+parameter for a \code{loess} fit. If specified, the full argument name
+\code{span} must be written.}
+\item{degree}{the degree of local polynomial to be fit; currently
+ restricted to be \code{1} or \code{2}. If specified, the full argument name
+\code{degree} must be written.}
+\item{x}{for \code{gam.lo}, the appropriate basis of polynomials
+ generated from the arguments to \code{lo}. These are also the
+ variables that receive linear coefficients in the GAM fit.}
+\item{y}{a response variable passed to \code{gam.lo} during backfitting}
+\item{w}{weights}
+\item{ncols}{for \code{gam.lo} the number of columns in \code{x} used as
+ the smoothing inputs to local regression. For example, if
+ \code{degree=2}, then \code{x} has two columns defining a degree-2
+ polynomial basis. Both are needed for the parameteric part of the fit,
+ but \code{ncol=1} telling the local regression routine that the first
+ column is the actually smoothing variable.}
+\item{xeval}{If this argument is present, then \code{gam.lo} produces a
+ prediction at \code{xeval}.}
+}
+\value{
+\code{lo} returns a numeric matrix. The simplest case is when there is a
+single argument to \code{lo} and \code{degree=1}; a one-column matrix is
+returned, consisting of a normalized version of the vector. If
+\code{degree=2} in this case, a two-column matrix is returned, consisting
+of a degree-2 polynomial basis. Similarly, if there are
+two arguments, or the single argument is a two-column matrix, either a
+two-column matrix is returned if \code{degree=1}, or a five-column matrix
+consisting of powers and products up to degree \code{2}. Any dimensional
+argument is allowed, but typically one or two vectors are used in
+practice.
+
+The matrix is endowed with a number of attributes; the matrix itself is
+used in the construction of the model matrix, while the attributes are
+needed for the backfitting algorithms \code{all.wam} (weighted additive
+model) or \code{lo.wam} (currently not implemented). Local-linear curve
+or surface fits reproduce linear responses, while local-quadratic fits
+reproduce quadratic curves or surfaces. These parts of the \code{loess}
+fit are computed exactly together with the other parametric linear parts
+
+When two or more smoothing variables are given, the user should make
+sure they are in a commensurable scale; \code{lo()} does no
+normalization. This can make a difference, since \code{lo()} uses a
+spherical (isotropic) neighborhood when establishing the nearest neighbors.
+
+
+Note that \code{lo} itself does no smoothing; it simply sets things up
+for \code{gam}; \code{gam.lo} does the actual smoothing.
+of the model.
+
+One important attribute is named \code{call}. For example, \code{lo(x)}
+has a call component
+\code{gam.lo(data[["lo(x)"]], z, w, span = 0.5, degree = 1, ncols = 1)}.
+This is an expression that gets evaluated repeatedly in \code{all.wam}
+(the backfitting algorithm).
+
+\code{gam.lo} returns an object with components
+\item{residuals}{The residuals from the smooth fit. Note that the
+ smoother removes the parametric part of the fit (using a linear fit
+ with the columns in \code{x}), so these residual represent the
+ nonlinear part of the fit.}
+\item{nl.df}{the nonlinear degrees of freedom}
+\item{var}{the pointwise variance for the nonlinear fit}
+
+When \code{gam.lo} is evaluated with an \code{xeval} argument, it returns a
+matrix of predictions.
+}
+\details{
+ A smoother in gam separates out the parametric part of the fit
+ from the non-parametric part. For local regression, the parametric
+ part of the fit is specified by the particular polynomial being fit
+ locally. The workhorse function \code{gam.lo} fits the local
+ polynomial, then strips off this parametric part. All the parametric
+ pieces from all the terms in the additive model are fit
+ simultaneously in one operation for each loop of the backfitting
+ algorithm.
+ }
+\seealso{
+\code{\link{s}}, \code{\link{bs}}, \code{\link{ns}}, \code{\link{poly}}, \code{\link{loess}}
+}
+\author{
+ Written by Trevor Hastie, following closely the design in the
+ "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and
+ Hastie (1992).
+ }
+\references{
+ Hastie, T. J. (1992)
+ \emph{Generalized additive models.}
+ Chapter 7 of \emph{Statistical Models in S}
+ eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole.
+
+ Hastie, T. and Tibshirani, R. (1990)
+ \emph{Generalized Additive Models.}
+ London: Chapman and Hall.
+}
+\examples{
+y ~ Age + lo(Start)
+ # fit Start using a loess smooth with a (default) span of 0.5.
+y ~ lo(Age) + lo(Start, Number)
+y ~ lo(Age, span=0.3) # the argument name span cannot be abbreviated.
+}
+\keyword{models}
+\keyword{regression}
+\keyword{nonparametric}
+\keyword{smooth}
+
diff --git a/man/na.gam.replace.Rd b/man/na.gam.replace.Rd
new file mode 100644
index 0000000..c90e620
--- /dev/null
+++ b/man/na.gam.replace.Rd
@@ -0,0 +1,46 @@
+\name{na.gam.replace}
+\alias{na.gam.replace}
+\title{Missing Data Filter for GAMs}
+\description{A method for dealing with missing values, friendly to GAM models.}
+\usage{
+na.gam.replace(frame)
+}
+\arguments{
+\item{frame}{
+a model or data frame
+}}
+\value{
+a model or data frame is returned, with the missing observations (NAs) replaced.
+The following rules are used. A factor with missing data is replaced by a new factor with one more level, labelled \code{"NA"}, which records the missing data.
+Ordered factors are treated similarly, except the result is an unordered factor.
+A missing numeric vector has its missing entires replaced by the mean of the non-missing entries. Similarly, a matrix with missing entries has each missing entry replace by the mean of its column.
+If \code{frame} is a model frame, the response variable can be identified, as can the weights (if present). Any rows for which the response or weight is missing are removed entirely from the model frame.
+
+
+The word \code{"gam"} in the name is relevant, because \code{gam()} makes special use of this filter. All columns of a model frame that were created by a call to \code{lo()} or \code{s()} have an attribute names \code{"NAs"} if NAs are present in their columns.
+Despite the replacement by means, these attributes remain on the object,
+and \code{gam()} takes appropriate action when smoothing against these
+columns. See section 7.3.2 in Hastie (1992)
+for more details.
+}
+\author{Trevor Hastie}
+
+\references{
+ Hastie, T. J. (1992)
+ \emph{Generalized additive models.}
+ Chapter 7 of \emph{Statistical Models in S}
+ eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole.
+}
+
+\examples{
+data(airquality)
+gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data=airquality, na=na.gam.replace)
+}
+\seealso{
+\code{\link{na.fail}}, \code{\link{na.omit}}, \code{\link{gam}}
+}
+\keyword{models}
+\keyword{regression}
+\keyword{nonparametric}
+\keyword{smooth}
+
diff --git a/man/plot.gam.Rd b/man/plot.gam.Rd
new file mode 100644
index 0000000..2f35af7
--- /dev/null
+++ b/man/plot.gam.Rd
@@ -0,0 +1,94 @@
+\name{plot.gam}
+\alias{plot.gam}
+\alias{preplot.gam}
+\alias{plot.preplot.gam}
+\title{Plot Components of a GAM Object}
+\description{A plot method for GAM objects, which can be used on GLM and
+ LM
+ objects as well. It focuses on terms (main-effects), and produces a
+ suitable plot for terms of different types}
+\usage{
+\method{plot}{gam}(x, residuals, rugplot, se, scale, ask = FALSE,terms,\dots)
+\method{preplot}{gam}(object, newdata, terms,\dots)
+}
+\arguments{
+\item{x}{
+a \code{gam} object, or a \code{preplot.gam} object. The first thing \code{plot.gam()} does is check if \code{x} has a component called \code{preplot}; if not, it computes one using \code{preplot.gam()}. Either way, it is this \code{preplot.gam} object that is required for plotting a \code{gam} object.
+}
+\item{object}{same as \code{x}}
+\item{residuals}{
+if \code{TRUE}, partial deviance residuals are plotted along with the fitted terms---default is \code{FALSE}. If \code{residuals} is a vector with the same length as each fitted term in \code{x}, then these are taken to be the overall residuals to be used for constructing the partial residuals.
+}
+\item{rugplot}{
+if \code{TRUE} (the default), a univariate histogram or \code{rugplot} is displayed along the base of each plot, showing the occurrence of each `x'; ties are broken by jittering.
+}
+\item{se}{
+if \code{TRUE}, upper and lower pointwise twice-standard-error curves are included for each plot. The default is \code{FALSE}.
+}
+\item{scale}{
+a lower limit for the number of units covered by the limits on the `y' for each plot. The default is \code{scale=0}, in which case each plot uses the range of the functions being plotted to create their \code{ylim}. By setting \code{scale} to be the maximum value of \code{diff(ylim)} for all the plots, then all subsequent plots will produced in the same vertical units. This is essential for comparing the importance of fitted terms in additive models.
+}
+\item{ask}{
+if \code{TRUE}, \code{plot.gam()} operates in interactive mode.
+}
+\item{newdata}{if supplied to \code{preplot.gam}, the preplot object is
+ based on them rather than the original.}
+\item{terms}{subsets of the terms can be selected}
+\item{\dots}{Additonal plotting arguments, not all of which will work
+ (like xlim)}
+}
+\value{
+a plot is produced for each of the terms in the object \code{x}. The function currently knows how to plot all main-effect functions of one or two predictors. So in particular, interactions are not plotted. An appropriate `x-y' is produced to display each of the terms, adorned with residuals, standard-error curves, and a rugplot, depending on the choice of options. The form of the plot is different, depending on whether the `x'-value for each plot is numeric, a factor, or a matrix.
+
+
+When \code{ask=TRUE}, rather than produce each plot sequentially, \code{plot.gam()} displays a menu listing all the terms that can be plotted, as well as switches for all the options.
+
+
+A \code{preplot.gam} object is a list of precomputed terms. Each such
+term (also a \code{preplot.gam} object) is a list with components
+\code{x}, \code{y} and others---the basic ingredients needed for each
+term plot. These are in turn handed to the specialized plotting function
+\code{gplot()}, which has methods for different classes of the leading
+\code{x} argument. In particular, a different plot is produced if
+\code{x} is numeric, a category or factor, a matrix, or a
+list. Experienced users can extend this range by creating more
+\code{gplot()} methods for other classes. Graphical parameters (see
+\code{\link{par}}) may also be supplied as arguments to this function.
+This function is a method for the generic function \code{plot()} for
+class \code{"gam"}.
+
+It can be invoked by calling \code{plot(x)} for an
+object \code{x} of the appropriate class, or directly by
+calling \code{plot.gam(x)} regardless of the
+class of the object.
+}
+\seealso{
+\code{\link{preplot}}, \code{\link{predict.gam}}
+}
+\author{
+ Written by Trevor Hastie, following closely the design in the
+ "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and
+ Hastie (1992).
+ }
+\references{
+ Hastie, T. J. (1992)
+ \emph{Generalized additive models.}
+ Chapter 7 of \emph{Statistical Models in S}
+ eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole.
+
+ Hastie, T. and Tibshirani, R. (1990)
+ \emph{Generalized Additive Models.}
+ London: Chapman and Hall.
+}
+\examples{
+data(gam.data)
+gam.object <- gam(y ~ s(x,6) + z,data=gam.data)
+plot(gam.object,se=TRUE)
+data(gam.newdata)
+preplot(gam.object,newdata=gam.newdata)
+}
+\keyword{models}
+\keyword{regression}
+\keyword{nonparametric}
+\keyword{smooth}
+
diff --git a/man/predict.gam.Rd b/man/predict.gam.Rd
new file mode 100644
index 0000000..4c85d58
--- /dev/null
+++ b/man/predict.gam.Rd
@@ -0,0 +1,95 @@
+\name{predict.gam}
+\alias{predict.gam}
+\title{Predict method for GAM fits}
+\description{Obtains predictions and optionally estimates standard errors of
+ those predictions from a fitted generalized additive model object.}
+\usage{
+predict.gam(object, newdata, type, dispersion, se.fit = FALSE,na.action, terms,\dots)
+}
+\arguments{
+\item{object}{
+a fitted \code{gam} object, or one of its inheritants, such as a \code{glm} or \code{lm} object.
+}
+\item{newdata}{
+a data frame containing the values at which predictions are required.
+This argument can be missing, in which case predictions are made at the same values used to compute the object.
+Only those predictors, referred to in the right side of the formula in object need be present by name in \code{newdata}.
+}
+\item{type}{
+type of predictions, with choices \code{"link"} (the default), \code{"response"}, or \code{"terms"}.
+The default produces predictions on the scale of the additive predictors, and with \code{newdata} missing, \code{predict} is simply an extractor function for this component of a \code{gam} object. If \code{"response"} is selected, the predictions are on the scale of the response, and are monotone transformations of the additive predictors, using the inverse link function. If \code{type="terms"} is selected, a matrix of predictions is produced, one column for each term in the model.
+}
+\item{se.fit}{
+if \code{TRUE}, pointwise standard errors are computed along with the predictions.
+}
+\item{dispersion}{the dispersion of the GLM fit to be assumed in computing
+ the standard errors. If omitted, that returned by 'summary'
+ applied to the object is used}
+\item{terms}{
+if \code{type="terms"}, the \code{terms=} argument can be used to specify which terms should be included; the default is \code{labels(object)}.
+}
+\item{na.action}{ function determining what should be done with missing values
+ in 'newdata'. The default is to predict 'NA'.}
+\item{\dots}{Placemark for additional arguments to predict}
+}
+\value{
+a vector or matrix of predictions, or a list consisting of the predictions and their standard errors if \code{se.fit = TRUE}.
+If \code{type="terms"}, a matrix of fitted terms is produced, with one column for each term in the model (or subset of these if the \code{terms=} argument is used). There is no column for the intercept, if present in the model, and each of the terms is centered so that their average over the original data is zero.
+The matrix of fitted terms has a \code{"constant"} attribute which, when added to the sum of these centered terms, gives the additive predictor.
+See the documentation of \code{predict} for more details on the components returned.
+
+When \code{newdata} are supplied, \code{predict.gam} simply invokes
+inheritance and gets \code{predict.glm} to produce the parametric part
+of the predictions. For each nonparametric term, \code{predict.gam} reconstructs the
+partial residuals and weights from the final iteration of the local
+scoring algorithm. The appropriate smoother is called for each term,
+with the appropriate \code{xeval} argument (see \code{\link{s}} or
+\code{\link{lo}}), and the prediction for that term is produced.
+
+The standard errors are based on an approximation given in Hastie
+(1992). Currently \code{predict.gam} does not produce standard errors for
+predictions at \code{newdata}.
+
+Warning: naive use of the generic
+\code{predict} can produce incorrect predictions when the \code{newdata}
+argument is used, if the formula in \code{object} involves
+transformations such as \code{sqrt(Age - min(Age))}.
+}
+\seealso{\code{\link{predict.glm}},
+\code{\link{fitted}}, \code{\link{expand.grid}}
+}
+\author{
+ Written by Trevor Hastie, following closely the design in the
+ "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and
+ Hastie (1992). This version of \code{predict.gam} is adapted from the S
+ version to match the corresponding predict methods for \code{glm} and
+ \code{lm} objects in R. The \code{safe.predict.gam} function in S is
+ no longer required, primarily because a safe prediction method is in
+ place for functions like \code{ns}, \code{bs}, and \code{poly}.
+ }
+\references{
+ Hastie, T. J. (1992)
+ \emph{Generalized additive models.}
+ Chapter 7 of \emph{Statistical Models in S}
+ eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole.
+
+ Hastie, T. and Tibshirani, R. (1990)
+ \emph{Generalized Additive Models.}
+ London: Chapman and Hall.
+
+ Venables, W. N. and Ripley, B. D. (2002)
+ \emph{Modern Applied Statistics with S.}
+ New York: Springer.
+}
+\examples{
+data(gam.data)
+gam.object <- gam(y ~ s(x,6) + z, data=gam.data)
+predict(gam.object) # extract the additive predictors
+data(gam.newdata)
+predict(gam.object, gam.newdata, type="terms")
+}
+
+\keyword{models}
+\keyword{regression}
+\keyword{nonparametric}
+\keyword{smooth}
diff --git a/man/s.Rd b/man/s.Rd
new file mode 100644
index 0000000..d5e63a3
--- /dev/null
+++ b/man/s.Rd
@@ -0,0 +1,89 @@
+\name{s}
+\alias{s}
+\alias{gam.s}
+\title{Specify a Smoothing Spline Fit in a GAM Formula}
+\description{A symbolic wrapper to indicate a smooth term in a formala
+ argument to gam}
+\usage{
+s(x, df=4, spar=1)
+gam.s(x, y, w, df, spar, xeval)
+}
+\arguments{
+\item{x}{
+the univariate predictor, or expression, that evaluates to a numeric vector.
+}
+
+\item{df}{ the target equivalent degrees of freedom, used as a smoothing
+parameter. The real smoothing parameter (\code{spar} below) is found
+such that \code{df=tr(S)-1}, where \code{S} is the implicit smoother
+matrix. Values for \code{df} should be greater than \code{1}, with
+\code{df=1} implying a linear fit. If both \code{df} and \code{spar} are
+supplied, the former takes precedence.}
+\item{spar}{
+can be used as smoothing parameter, with values typically in
+\code{(0,1]}. See \code{\link{smooth.spline}} for more details.}
+
+\item{y}{a response variable passed to \code{gam.s} during backfitting}
+\item{w}{weights}
+\item{xeval}{If this argument is present, then \code{gam.s} produces a
+ prediction at \code{xeval}.}
+}
+\value{
+
+\code{s} returns the vector \code{x}, endowed with a number of
+attributes. The vector itself is used in the construction of the model
+matrix, while the attributes are needed for the backfitting algorithms
+\code{all.wam} (weighted additive model) or \code{s.wam} (currently not
+implemented). Since smoothing splines reproduces linear fits, the linear
+part will be efficiently computed with the other parametric linear parts
+of the model.
+
+Note that \code{s} itself does no smoothing; it simply sets things up
+for \code{gam}.
+
+One important attribute is named \code{call}. For example, \code{s(x)}
+has a call component
+\code{gam.s(data[["s(x)"]], z, w, spar = 1, df = 4)}.
+This is an expression that gets evaluated repeatedly in \code{all.wam}
+(the backfitting algorithm).
+
+\code{gam.s} returns an object with components
+\item{residuals}{The residuals from the smooth fit. Note that the
+ smoother removes the parametric part of the fit (using a linear fit
+ in \code{x}), so these residual represent the
+ nonlinear part of the fit.}
+\item{nl.df}{the nonlinear degrees of freedom}
+\item{var}{the pointwise variance for the nonlinear fit}
+
+When \code{gam.s} is evaluated with an \code{xeval} argument, it returns a
+vector of predictions.
+}
+\seealso{
+\code{\link{lo}}, \code{\link{smooth.spline}}, \code{\link{bs}}, \code{\link{ns}}, \code{\link{poly}}
+}
+\author{
+ Written by Trevor Hastie, following closely the design in the
+ "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and
+ Hastie (1992).
+ }
+\references{
+ Hastie, T. J. (1992)
+ \emph{Generalized additive models.}
+ Chapter 7 of \emph{Statistical Models in S}
+ eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole.
+
+ Hastie, T. and Tibshirani, R. (1990)
+ \emph{Generalized Additive Models.}
+ London: Chapman and Hall.
+}
+\examples{
+# fit Start using a smoothing spline with 4 df.
+y ~ Age + s(Start, 4)
+# fit log(Start) using a smoothing spline with 5 df.
+y ~ Age + s(log(Start), df=5)
+}
+\keyword{models}
+\keyword{regression}
+\keyword{nonparametric}
+\keyword{smooth}
+
diff --git a/man/step.gam.Rd b/man/step.gam.Rd
new file mode 100644
index 0000000..c7d12c1
--- /dev/null
+++ b/man/step.gam.Rd
@@ -0,0 +1,86 @@
+\name{step.gam}
+\alias{step.gam}
+\title{Stepwise model builder for GAM}
+\description{Builds a GAM model in a step-wise fashion. For each "term"
+ there is an ordered list of alternatives, and the function traverses
+ these in a greedy fashion. Note: this is NOT a method for \code{step},
+which used to be a generic, so must be invoked with the full name.}
+\usage{
+step.gam(object, scope, scale, direction, trace = TRUE, keep, steps, \ldots)
+}
+\arguments{
+\item{object}{
+An object of class \code{gam} or any of it's inheritants.
+}
+\item{scope}{
+defines the range of models examined in the step-wise search. It is a list of formulas, with each formula corresponding to a term in the model. Each of these formulas specifies a "regimen" of candidate forms in which the particular term may enter the model. For example, a term formula might be
+~1+ Income + log(Income) + s(Income)
+This means that \code{Income} could either appear not at all, linearly, linearly in its logarithm, or as a smooth function estimated nonparametrically. A \code{1} in the formula allows the additional option of leaving the term out of the model entirely.
+Every term in the model is described by such a term formula, and the
+final model is built up by selecting a component from each
+formula.
+
+The supplied model \code{object} is used as the starting model, and hence there is the requirement that one term from each of the term formulas be present in \code{formula(object)}. This also implies that any terms in \code{formula(object)} not contained in any of the term formulas will be
+to be present in every model considered.
+}
+\item{scale}{
+an optional argument used in the definition of the AIC statistic used to evaluate models for selection. By default, the scaled Chi-squared statistic for the initial model is used, but if forward selection is to be performed, this is not necessarily a sound choice.
+}
+\item{direction}{
+The mode of step-wise search, can be one of \code{"both"}, \code{"backward"}, or \code{"forward"}, with a default of \code{"both"}. If \code{scope} is missing, the default for \code{direction} is "backward".
+}
+\item{trace}{
+If \code{TRUE}, information is printed during the running of \code{step.gam()}. This is an encouraging choice in general, since \code{step.gam()} can take some time to compute either for large models or when called with an an extensive \code{scope=} argument. A simple one line model summary is printed for each model visited in the search, and the selected model is noted at each step.
+}
+\item{keep}{
+A filter function whose input is a fitted \code{gam} object and the associated "AIC" statistic, and whose output is arbitrary. Typically \code{keep()} will select a subset of the components of the object and return them. The default is not to keep anything.
+}
+\item{steps}{
+The maximum number of steps to be considered. The default is 1000 (essentially as
+many as required). It is typically used to stop the process early.
+}
+\item{\dots}{Additional arguments to be passed on to \code{keep}}
+}
+\value{
+The step-wise-selected model is returned, with up to two additional components.
+There is an \code{"anova"} component corresponding to the steps taken in the search, as well as a \code{"keep"} component if the \code{keep=} argument was supplied in the call.
+
+
+We describe the most general setup, when \code{direction = "both"}.
+At any stage there is a current model comprising a single term from each of the term formulas supplied in the \code{scope=} argument.
+A series of models is fitted, each corrresponding to a formula obtained by moving each of the terms one step up or down in its regimen, relative to the formula of the current model.
+If the current value for any term is at either of the extreme ends of its regimen, only one rather than two steps can be considered.
+So if there are \code{p} term formulas, at most \code{2*p - 1} models are considered.
+A record is kept of all the models ever visited (hence the \code{-1} above), to avoid repetition.
+Once each of these models has been fit, the "best" model
+in terms of the AIC statistic is selected and defines the step.
+The entire process is repeated until either the maximum number of steps has been used, or until the AIC criterion can not be decreased by any of the eligible steps.
+}
+\seealso{
+\code{\link{step}},\code{\link{glm}}, \code{\link{gam}}, \code{\link{drop1}}, \code{\link{add1}}, \code{\link{anova.gam}}
+}
+\author{
+ Written by Trevor Hastie, following closely the design in the
+ "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and
+ Hastie (1992).
+ }
+\references{
+ Hastie, T. J. (1992)
+ \emph{Generalized additive models.}
+ Chapter 7 of \emph{Statistical Models in S}
+ eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole.
+
+ Hastie, T. and Tibshirani, R. (1990)
+ \emph{Generalized Additive Models.}
+ London: Chapman and Hall.
+}
+\examples{
+data(gam.data)
+gam.object <- gam(y~x+z, data=gam.data)
+step.object <-step.gam(gam.object, scope=list("x"=~1+x+s(x,4)+s(x,6)+s(x,12),"z"=~1+z+s(z,4)))
+}
+\keyword{models}
+\keyword{regression}
+\keyword{nonparametric}
+\keyword{smooth}
+
diff --git a/src/Makevars b/src/Makevars
new file mode 100644
index 0000000..cb6d3f0
--- /dev/null
+++ b/src/Makevars
@@ -0,0 +1,2 @@
+PKG_LIBS = $(BLAS_LIBS) $(FLIBS)
+
diff --git a/src/Makevars.win b/src/Makevars.win
new file mode 100644
index 0000000..34a28f2
--- /dev/null
+++ b/src/Makevars.win
@@ -0,0 +1 @@
+PKG_LIBS = $(BLAS_LIBS) $(FLIBS)
diff --git a/src/backfit.f b/src/backfit.f
new file mode 100644
index 0000000..4d027be
--- /dev/null
+++ b/src/backfit.f
@@ -0,0 +1,168 @@
+C Output from Public domain Ratfor, version 1.0
+ subroutine bakfit(x,npetc,y,w,which,spar,dof,match,nef, etal,s,eta
+ *,beta,var,tol, qr,qraux,qpivot,effect,work)
+ implicit double precision(a-h,o-z)
+ logical ifvar
+ integer npetc(7),iter
+ integer n,p,q,which(1),match(1),nef(1),nit,maxit,qrank,qpivot(1)
+ double precision x(1),y(1),w(1),spar(1),dof(1), etal(1),s(1),eta(1
+ *),beta(1),var(1),tol, qr(1),qraux(1),effect(1),work(1)
+ n=npetc(1)
+ p=npetc(2)
+ q=npetc(3)
+ ifvar=.false.
+ if(npetc(4).eq.1)then
+ ifvar=.true.
+ endif
+ maxit=npetc(6)
+ qrank=npetc(7)
+ do23002 i=1,q
+ work(i)=dof(i)
+23002 continue
+23003 continue
+ call backf1(x,n,p,y,w,q,which,spar,dof,match,nef, etal,s,eta,beta,
+ *var,ifvar,tol,nit,maxit, qr,qraux,qrank,qpivot,effect,work(q+1),wo
+ *rk(q+n+1), work(q+2*n+1),work(q+3*n+1),work(q+4*n+1))
+ npetc(7)=qrank
+ return
+ end
+ subroutine backf1(x,n,p,y,w,q,which,spar,dof,match,nef, etal,s,eta
+ *,beta,var,ifvar,tol,nit,maxit, qr,qraux,qrank,qpivot,effect,z,old,
+ *sqwt,sqwti,work)
+ implicit double precision(a-h,o-z)
+ logical ifvar
+ integer n,p,q,which(q),match(n,q),nef(q),nit,maxit,qrank,qpivot(p)
+ double precision x(n,p),y(n),w(n),spar(q),dof(q), etal(n),s(n,q),e
+ *ta(n),beta(p),var(n,q),tol, qr(n,p),qraux(p),effect(n),work(1)
+ double precision z(1),old(1),dwrss,ratio
+ double precision sqwt(n),sqwti(n)
+ logical anyzwt
+ double precision deltaf, normf,onedm7
+ integer job,info
+ onedm7=1d-7
+ job=1101
+ info=1
+ if(q.eq.0)then
+ maxit=1
+ endif
+ ratio=1d0
+ anyzwt=.false.
+ do23006 i=1,n
+ if(w(i).gt.0d0)then
+ sqwt(i)=dsqrt(w(i))
+ sqwti(i)=1d0/sqwt(i)
+ else
+ sqwt(i)=0d0
+ sqwti(i)=0d0
+ anyzwt=.true.
+ endif
+23006 continue
+23007 continue
+ if(qrank.eq.0)then
+ do23012 i=1,n
+ do23014 j=1,p
+ qr(i,j)=x(i,j)*sqwt(i)
+23014 continue
+23015 continue
+23012 continue
+23013 continue
+ do23016 j=1,p
+ qpivot(j)=j
+23016 continue
+23017 continue
+ call dqrdca(qr,n,n,p,qraux,qpivot,work,qrank,onedm7)
+ endif
+ do23018 i=1,n
+ eta(i)=0d0
+ j=1
+23020 if(.not.(j.le.q))goto 23022
+ eta(i)=eta(i)+s(i,j)
+23021 j=j+1
+ goto 23020
+23022 continue
+23018 continue
+23019 continue
+ nit=0
+23023 if((ratio .gt. tol ).and.(nit .lt. maxit))then
+ deltaf=0d0
+ nit=nit+1
+ do23025 i=1,n
+ z(i)=(y(i)-eta(i))*sqwt(i)
+ old(i)=etal(i)
+23025 continue
+23026 continue
+ call dqrsl(qr,n,n,qrank,qraux,z,work(1),effect(1),beta, work(1),et
+ *al,job,info)
+ do23027 i=1,n
+ etal(i)=etal(i)*sqwti(i)
+23027 continue
+23028 continue
+ k=1
+23029 if(.not.(k.le.q))goto 23031
+ j=which(k)
+ do23032 i=1,n
+ old(i)=s(i,k)
+ z(i)=y(i)-etal(i)-eta(i)+old(i)
+23032 continue
+23033 continue
+ if(nit.gt.1)then
+ dof(k)=0d0
+ endif
+ call splsm(x(1,j),z,w,n,match(1,k),nef(k),spar(k), dof(k),s(1,k),s
+ *0,var(1,k),ifvar,work)
+ do23036 i=1,n
+ eta(i)=eta(i)+s(i,k)-old(i)
+ etal(i)=etal(i)+s0
+23036 continue
+23037 continue
+ deltaf=deltaf+dwrss(n,old,s(1,k),w)
+23030 k=k+1
+ goto 23029
+23031 continue
+ normf=0d0
+ do23038 i=1,n
+ normf=normf+w(i)*eta(i)*eta(i)
+23038 continue
+23039 continue
+ if(normf.gt.0d0)then
+ ratio=dsqrt(deltaf/normf)
+ else
+ ratio = 0d0
+ endif
+ goto 23023
+ endif
+23024 continue
+ do23042 j=1,p
+ work(j)=beta(j)
+23042 continue
+23043 continue
+ do23044 j=1,p
+ beta(qpivot(j))=work(j)
+23044 continue
+23045 continue
+ if(anyzwt)then
+ do23048 i=1,n
+ if(w(i) .le. 0d0)then
+ etal(i)=0d0
+ do23052 j=1,p
+ etal(i)=etal(i)+beta(j)*x(i,j)
+23052 continue
+23053 continue
+ endif
+23048 continue
+23049 continue
+ endif
+ do23054 i=1,n
+ eta(i)=eta(i)+etal(i)
+23054 continue
+23055 continue
+ do23056 j=1,q
+ call unpck(n,nef(j),match(1,j),var(1,j),old)
+ do23058 i=1,n
+ var(i,j)=old(i)
+23058 continue
+23059 continue
+23056 continue
+23057 continue
+ return
+ end
diff --git a/src/backlo.f b/src/backlo.f
new file mode 100644
index 0000000..5a516c1
--- /dev/null
+++ b/src/backlo.f
@@ -0,0 +1,164 @@
+C Output from Public domain Ratfor, version 1.0
+ subroutine baklo(x,y,w,npetc,wddnfl,spatol,match, etal,s,eta,beta,
+ *var,dof, qr,qraux,qpivot,effect,iv,v,iwork,work)
+ implicit double precision(a-h,o-z)
+ integer n,p,q,nit,maxit,qrank
+ integer npetc(7),wddnfl(1),match(1),qpivot(1),iv(1),iwork(1)
+ double precision x(1),y(1),w(1),spatol(1), etal(1),s(1),eta(1),bet
+ *a(1),var(1),dof(1), qr(1),qraux(1),v(1),effect(1),work(1)
+ n=npetc(1)
+ p=npetc(2)
+ q=npetc(3)
+ maxit=npetc(5)
+ qrank=npetc(6)
+ call baklo0(x,n,p,y,w,q,wddnfl(1),wddnfl(q+1),wddnfl(2*q+1), spato
+ *l(1),wddnfl(3*q+1),dof,match,wddnfl(4*q+1), etal,s,eta,beta,var,sp
+ *atol(q+1), nit,maxit,qr,qraux,qrank,qpivot,effect, work(1),work(n+
+ *1),work(2*n+1),work(3*n+1), iv,wddnfl(5*q+1),wddnfl(6*q+1),v,wddnf
+ *l(7*q+1), iwork(1),work(4*n+1))
+ npetc(4)=nit
+ npetc(6)=qrank
+ return
+ end
+ subroutine baklo0(x,n,p,y,w,q,which,dwhich,pwhich,span,degree,dof,
+ *match,nef, etal,s,eta,beta,var,tol,nit,maxit, qr,qraux,qrank,qpivo
+ *t,effect,z,old,sqwt,sqwti, iv,liv,lv,v,nvmax,iwork,work)
+ implicit double precision(a-h,o-z)
+ integer n,p,q,which(q),dwhich(q),pwhich(q),degree(q),match(n,q),ne
+ *f(q),nit, maxit,qrank,qpivot(p),iv(1),liv(q),lv(q),nvmax(q),iwork(
+ *q)
+ double precision x(n,p),y(n),w(n),span(q),dof(q), etal(n),s(n,q),e
+ *ta(n),beta(p),var(n,q),tol, qr(n,p),qraux(p),v(1),effect(n),work(1
+ *)
+ double precision z(1),old(1),dwrss,ratio
+ double precision sqwt(n),sqwti(n)
+ logical anyzwt
+ double precision deltaf, normf,onedm7
+ integer job,info,slv,sliv,iw,j,dj,pj
+ onedm7=1d-7
+ job=1101
+ info=1
+ if(q.eq.0)then
+ maxit=1
+ endif
+ ratio=1d0
+ anyzwt=.false.
+ do23002 i=1,n
+ if(w(i).gt.0d0)then
+ sqwt(i)=dsqrt(w(i))
+ sqwti(i)=1d0/sqwt(i)
+ else
+ sqwt(i)=0d0
+ sqwti(i)=0d0
+ anyzwt=.true.
+ endif
+23002 continue
+23003 continue
+ if(qrank.eq.0)then
+ do23008 i=1,n
+ do23010 j=1,p
+ qr(i,j)=x(i,j)*sqwt(i)
+23010 continue
+23011 continue
+23008 continue
+23009 continue
+ do23012 j=1,p
+ qpivot(j)=j
+23012 continue
+23013 continue
+ call dqrdca(qr,n,n,p,qraux,qpivot,work,qrank,onedm7)
+ endif
+ do23014 i=1,n
+ eta(i)=0d0
+ j=1
+23016 if(.not.(j.le.q))goto 23018
+ eta(i)=eta(i)+s(i,j)
+23017 j=j+1
+ goto 23016
+23018 continue
+23014 continue
+23015 continue
+ nit=0
+23019 if((ratio .gt. tol ).and.(nit .lt. maxit))then
+ deltaf=0d0
+ nit=nit+1
+ do23021 i=1,n
+ z(i)=(y(i)-eta(i))*sqwt(i)
+ old(i)=etal(i)
+23021 continue
+23022 continue
+ call dqrsl(qr,n,n,qrank,qraux,z,work(1),effect(1),beta, work(1),et
+ *al,job,info)
+ do23023 i=1,n
+ etal(i)=etal(i)*sqwti(i)
+23023 continue
+23024 continue
+ sliv=1
+ slv=1
+ iw=5*n+1
+ k=1
+23025 if(.not.(k.le.q))goto 23027
+ j=which(k)
+ dj=dwhich(k)
+ pj=pwhich(k)
+ do23028 i=1,n
+ old(i)=s(i,k)
+ z(i)=y(i)-etal(i)-eta(i)+old(i)
+23028 continue
+23029 continue
+ call lo1(x(1,j),z,w,n,dj,pj,nvmax(k),span(k),degree(k),match(1,k),
+ * nef(k),nit,dof(k),s(1,k),var(1,k),work(iw), work(iw+pj+1),work(iw
+ *+nef(k)*dj+pj+1), work(iw+nef(k)*(dj+1)+pj+2),work(iw + nef(k)*(dj
+ *+2)+pj+2), work(iw+nef(k)*(dj+3)+pj+2),work(iw+nef(k)*(pj+dj+4)+pj
+ *+2), iwork(1),work(iw+nef(k)*(pj+dj+4)+4+2*pj), iv(sliv),liv(k),lv
+ *(k),v(slv), work(1) )
+ sliv=sliv+liv(k)
+ slv=slv+lv(k)
+ iw=iw+nef(k)*(pj+dj+4)+5+3*pj
+ do23030 i=1,n
+ eta(i)=eta(i)+s(i,k)-old(i)
+23030 continue
+23031 continue
+ deltaf=deltaf+dwrss(n,old,s(1,k),w)
+23026 k=k+1
+ goto 23025
+23027 continue
+ normf=0d0
+ do23032 i=1,n
+ normf=normf+w(i)*eta(i)*eta(i)
+23032 continue
+23033 continue
+ if(normf.gt.0d0)then
+ ratio=dsqrt(deltaf/normf)
+ else
+ ratio = 0d0
+ endif
+ goto 23019
+ endif
+23020 continue
+ do23036 j=1,p
+ work(j)=beta(j)
+23036 continue
+23037 continue
+ do23038 j=1,p
+ beta(qpivot(j))=work(j)
+23038 continue
+23039 continue
+ if(anyzwt)then
+ do23042 i=1,n
+ if(w(i) .le. 0d0)then
+ etal(i)=0d0
+ do23046 j=1,p
+ etal(i)=etal(i)+beta(j)*x(i,j)
+23046 continue
+23047 continue
+ endif
+23042 continue
+23043 continue
+ endif
+ do23048 i=1,n
+ eta(i)=eta(i)+etal(i)
+23048 continue
+23049 continue
+ return
+ end
diff --git a/src/bsplvd.f b/src/bsplvd.f
new file mode 100644
index 0000000..8d95f58
--- /dev/null
+++ b/src/bsplvd.f
@@ -0,0 +1,222 @@
+ subroutine bsplvd ( t, lent, k, x, left, a, dbiatx, nderiv )
+c -------- ------
+c implicit none
+
+C calculates value and deriv.s of all b-splines which do not vanish at x
+C calls bsplvb
+c
+c****** i n p u t ******
+c t the knot array, of length left+k (at least)
+c k the order of the b-splines to be evaluated
+c x the point at which these values are sought
+c left an integer indicating the left endpoint of the interval of
+c interest. the k b-splines whose support contains the interval
+c (t(left), t(left+1))
+c are to be considered.
+c a s s u m p t i o n - - - it is assumed that
+c t(left) < t(left+1)
+c division by zero will result otherwise (in b s p l v b ).
+c also, the output is as advertised only if
+c t(left) <= x <= t(left+1) .
+c nderiv an integer indicating that values of b-splines and their
+c derivatives up to but not including the nderiv-th are asked
+c for. ( nderiv is replaced internally by the integer in (1,k)
+c closest to it.)
+c
+c****** w o r k a r e a ******
+c a an array of order (k,k), to contain b-coeff.s of the derivat-
+c ives of a certain order of the k b-splines of interest.
+c
+c****** o u t p u t ******
+c dbiatx an array of order (k,nderiv). its entry (i,m) contains
+c value of (m-1)st derivative of (left-k+i)-th b-spline of
+c order k for knot sequence t , i=m,...,k; m=1,...,nderiv.
+c
+c****** m e t h o d ******
+c values at x of all the relevant b-splines of order k,k-1,...,
+c k+1-nderiv are generated via bsplvb and stored temporarily
+c in dbiatx . then, the b-coeffs of the required derivatives of the
+c b-splines of interest are generated by differencing, each from the
+c preceding one of lower order, and combined with the values of b-
+c splines of corresponding order in dbiatx to produce the desired
+c values.
+
+C Args
+ integer lent,k,left,nderiv
+ double precision t(lent),x, dbiatx(k,nderiv), a(k,k)
+C Locals
+ double precision factor,fkp1mm,sum
+ integer i,ideriv,il,j,jlow,jp1mid, kp1,kp1mm,ldummy,m,mhigh
+
+ mhigh = max0(min0(nderiv,k),1)
+c mhigh is usually equal to nderiv.
+ kp1 = k+1
+ call bsplvb(t,lent,kp1-mhigh,1,x,left,dbiatx)
+ if (mhigh .eq. 1) go to 99
+c the first column of dbiatx always contains the b-spline values
+c for the current order. these are stored in column k+1-current
+c order before bsplvb is called to put values for the next
+c higher order on top of it.
+ ideriv = mhigh
+ do 15 m=2,mhigh
+ jp1mid = 1
+ do 11 j=ideriv,k
+ dbiatx(j,ideriv) = dbiatx(jp1mid,1)
+ 11 jp1mid = jp1mid + 1
+ ideriv = ideriv - 1
+ call bsplvb(t,lent,kp1-ideriv,2,x,left,dbiatx)
+ 15 continue
+c
+c at this point, b(left-k+i, k+1-j)(x) is in dbiatx(i,j) for
+c i=j,...,k and j=1,...,mhigh ('=' nderiv). in particular, the
+c first column of dbiatx is already in final form. to obtain cor-
+c responding derivatives of b-splines in subsequent columns, gene-
+c rate their b-repr. by differencing, then evaluate at x.
+c
+ jlow = 1
+ do 20 i=1,k
+ do 19 j=jlow,k
+ 19 a(j,i) = 0e0
+ jlow = i
+ 20 a(i,i) = 1e0
+c at this point, a(.,j) contains the b-coeffs for the j-th of the
+c k b-splines of interest here.
+c
+ do 40 m=2,mhigh
+ kp1mm = kp1 - m
+ fkp1mm = dble(kp1mm)
+ il = left
+ i = k
+c
+c for j=1,...,k, construct b-coeffs of (m-1)st derivative of
+c b-splines from those for preceding derivative by differencing
+c and store again in a(.,j) . the fact that a(i,j) = 0 for
+c i < j is used.sed.
+ do 25 ldummy=1,kp1mm
+ factor = fkp1mm/(t(il+kp1mm) - t(il))
+c the assumption that t(left) < t(left+1) makes denominator
+c in factor nonzero.
+ do 24 j=1,i
+ 24 a(i,j) = (a(i,j) - a(i-1,j))*factor
+ il = il - 1
+ 25 i = i - 1
+c
+c for i=1,...,k, combine b-coeffs a(.,i) with b-spline values
+c stored in dbiatx(.,m) to get value of (m-1)st derivative of
+c i-th b-spline (of interest here) at x , and store in
+c dbiatx(i,m). storage of this value over the value of a b-spline
+c of order m there is safe since the remaining b-spline derivat-
+c ive of the same order do not use this value due to the fact
+c that a(j,i) = 0 for j < i .
+ 30 do 40 i=1,k
+ sum = 0.
+ jlow = max0(i,m)
+ do 35 j=jlow,k
+ 35 sum = a(j,i)*dbiatx(j,m) + sum
+ 40 dbiatx(i,m) = sum
+ 99 return
+ end
+
+ subroutine bsplvb ( t, lent,jhigh, index, x, left, biatx )
+c implicit none
+c -------------
+
+calculates the value of all possibly nonzero b-splines at x of order
+c
+c jout = dmax( jhigh , (j+1)*(index-1) )
+c
+c with knot sequence t .
+c
+c****** i n p u t ******
+c t.....knot sequence, of length left + jout , assumed to be nonde-
+c creasing.
+c a s s u m p t i o n : t(left) < t(left + 1)
+c d i v i s i o n b y z e r o will result if t(left) = t(left+1)
+c
+c jhigh,
+c index.....integers which determine the order jout = max(jhigh,
+c (j+1)*(index-1)) of the b-splines whose values at x are to
+c be returned. index is used to avoid recalculations when seve-
+c ral columns of the triangular array of b-spline values are nee-
+c ded (e.g., in bvalue or in bsplvd ). precisely,
+c if index = 1 ,
+c the calculation starts from scratch and the entire triangular
+c array of b-spline values of orders 1,2,...,jhigh is generated
+c order by order , i.e., column by column .
+c if index = 2 ,
+c only the b-spline values of order j+1, j+2, ..., jout are ge-
+c nerated, the assumption being that biatx , j , deltal , deltar
+c are, on entry, as they were on exit at the previous call.
+c in particular, if jhigh = 0, then jout = j+1, i.e., just
+c the next column of b-spline values is generated.
+c
+c w a r n i n g . . . the restriction jout <= jmax (= 20) is
+c imposed arbitrarily by the dimension statement for deltal and
+c deltar below, but is n o w h e r e c h e c k e d for .
+c
+c x.....the point at which the b-splines are to be evaluated.
+c left.....an integer chosen (usually) so that
+c t(left) <= x <= t(left+1) .
+c
+c****** o u t p u t ******
+c biatx.....array of length jout , with biatx(i) containing the val-
+c ue at x of the polynomial of order jout which agrees with
+c the b-spline b(left-jout+i,jout,t) on the interval (t(left),
+c t(left+1)) .
+c
+c****** m e t h o d ******
+c the recurrence relation
+c
+c x - t(i) t(i+j+1) - x
+c b(i,j+1)(x) = ----------- b(i,j)(x) + --------------- b(i+1,j)(x)
+c t(i+j)-t(i) t(i+j+1)-t(i+1)
+c
+c is used (repeatedly) to generate the
+c (j+1)-vector b(left-j,j+1)(x),...,b(left,j+1)(x)
+c from the j-vector b(left-j+1,j)(x),...,b(left,j)(x),
+c storing the new values in biatx over the old. the facts that
+c b(i,1) = 1 if t(i) <= x < t(i+1)
+c and that
+c b(i,j)(x) = 0 unless t(i) <= x < t(i+j)
+c are used. the particular organization of the calculations follows
+c algorithm (8) in chapter x of the text.
+c
+
+C Arguments
+ integer lent, jhigh, index, left
+ double precision t(lent),x, biatx(jhigh)
+c dimension t(left+jout), biatx(jout)
+c -----------------------------------
+c current fortran standard makes it impossible to specify the length of
+c t and of biatx precisely without the introduction of otherwise
+c superfluous additional arguments.
+
+C Local Variables
+ integer jmax
+ parameter(jmax = 20)
+ integer i,j,jp1
+ double precision deltal(jmax), deltar(jmax),saved,term
+
+ save j,deltal,deltar
+ data j/1/
+c
+ go to (10,20), index
+ 10 j = 1
+ biatx(1) = 1e0
+ if (j .ge. jhigh) go to 99
+c
+ 20 jp1 = j + 1
+ deltar(j) = t(left+j) - x
+ deltal(j) = x - t(left+1-j)
+ saved = 0e0
+ do 26 i=1,j
+ term = biatx(i)/(deltar(i) + deltal(jp1-i))
+ biatx(i) = saved + deltar(i)*term
+ 26 saved = deltal(jp1-i)*term
+ biatx(jp1) = saved
+ j = jp1
+ if (j .lt. jhigh) go to 20
+c
+ 99 return
+ end
+
diff --git a/src/bvalue.f b/src/bvalue.f
new file mode 100644
index 0000000..693fc03
--- /dev/null
+++ b/src/bvalue.f
@@ -0,0 +1,185 @@
+ double precision function bvalue(t,lent,bcoef,n,k,x,jderiv)
+
+c Calculates value at x of jderiv-th derivative of spline from B-repr.
+c The spline is taken to be continuous from the right.
+c
+C calls interv
+c
+c****** i n p u t ******
+c t, bcoef, n, k......forms the b-representation of the spline f to
+c be evaluated. specifically,
+c t.....knot sequence, of length n+k, assumed nondecreasing.
+c bcoef.....b-coefficient sequence, of length n .
+c n.....length of bcoef and dimension of s(k,t),
+c a s s u m e d positive .
+c k.....order of the spline .
+c
+c w a r n i n g . . . the restriction k <= kmax (=20) is imposed
+c arbitrarily by the dimension statement for aj, dm, dm below,
+c but is n o w h e r e c h e c k e d for.
+c however in R, this is only called from bvalus() with k=4 anyway!
+c
+c x.....the point at which to evaluate .
+c jderiv.....integer giving the order of the derivative to be evaluated
+c a s s u m e d to be zero or positive.
+c
+c****** o u t p u t ******
+c bvalue.....the value of the (jderiv)-th derivative of f at x .
+c
+c****** m e t h o d ******
+c the nontrivial knot interval (t(i),t(i+1)) containing x is lo-
+c cated with the aid of interv(). the k b-coeffs of f relevant for
+c this interval are then obtained from bcoef (or taken to be zero if
+c not explicitly available) and are then differenced jderiv times to
+c obtain the b-coeffs of (d^jderiv)f relevant for that interval.
+c precisely, with j = jderiv, we have from x.(12) of the text that
+c
+c (d^j)f = sum ( bcoef(.,j)*b(.,k-j,t) )
+c
+c where
+c / bcoef(.), , j .eq. 0
+c /
+c bcoef(.,j) = / bcoef(.,j-1) - bcoef(.-1,j-1)
+c / ----------------------------- , j > 0
+c / (t(.+k-j) - t(.))/(k-j)
+c
+c then, we use repeatedly the fact that
+c
+c sum ( a(.)*b(.,m,t)(x) ) = sum ( a(.,x)*b(.,m-1,t)(x) )
+c with
+c (x - t(.))*a(.) + (t(.+m-1) - x)*a(.-1)
+c a(.,x) = ---------------------------------------
+c (x - t(.)) + (t(.+m-1) - x)
+c
+c to write (d^j)f(x) eventually as a linear combination of b-splines
+c of order 1 , and the coefficient for b(i,1,t)(x) must then
+c be the desired number (d^j)f(x). (see x.(17)-(19) of text).
+c
+C Arguments
+ integer lent, n,k, jderiv
+ DOUBLE precision t(*),bcoef(n),x
+c dimension t(n+k)
+c current fortran standard makes it impossible to specify the length of
+c t precisely without the introduction of otherwise superfluous
+c additional arguments.
+
+C Local Variables
+ integer kmax
+ parameter(kmax = 20)
+
+ DOUBLE precision aj(kmax),dm(kmax),dp(kmax),fkmj
+
+ integer i,ilo,imk,j,jc,jcmin,jcmax,jj,km1,kmj,mflag,nmi, jdrvp1
+c
+ integer interv
+ external interv
+
+c initialize
+ data i/1/
+
+ bvalue = 0.
+ if (jderiv .ge. k) go to 99
+c
+c *** find i s.t. 1 <= i < n+k and t(i) < t(i+1) and
+c t(i) <= x < t(i+1) . if no such i can be found, x lies
+c outside the support of the spline f and bvalue = 0.
+c {this case is handled in the calling R code}
+c (the asymmetry in this choice of i makes f rightcontinuous)
+ if( (x.ne.t(n+1)) .or. (t(n+1).ne.t(n+k)) ) then
+ i = interv ( t, n+k, x, 0, 0, i, mflag)
+ if (mflag .ne. 0) then
+ call rwarn("bvalue() mflag != 0: should never happen!")
+ go to 99
+ endif
+ else
+ i = n
+ endif
+
+c *** if k = 1 (and jderiv = 0), bvalue = bcoef(i).
+ km1 = k - 1
+ if (km1 .le. 0) then
+ bvalue = bcoef(i)
+ go to 99
+ endif
+c
+c *** store the k b-spline coefficients relevant for the knot interval
+c (t(i),t(i+1)) in aj(1),...,aj(k) and compute dm(j) = x - t(i+1-j),
+c dp(j) = t(i+j) - x, j=1,...,k-1 . set any of the aj not obtainable
+c from input to zero. set any t.s not obtainable equal to t(1) or
+c to t(n+k) appropriately.
+ jcmin = 1
+ imk = i - k
+ if (imk .ge. 0) then
+ 8 do 9 j=1,km1
+ dm(j) = x - t(i+1-j)
+ 9 continue
+ else
+ jcmin = 1 - imk
+ do 5 j=1,i
+ dm(j) = x - t(i+1-j)
+ 5 continue
+ do 6 j=i,km1
+ aj(k-j) = 0.
+ dm(j) = dm(i)
+ 6 continue
+ endif
+c
+ jcmax = k
+ nmi = n - i
+ if (nmi .ge. 0) then
+ do 19 j=1,km1
+C the following if() happens; e.g. in pp <- predict(cars.spl, xx)
+c - if( (i+j) .gt. lent) write(6,9911) i+j,lent
+c - 9911 format(' i+j, lent ',2(i6,1x))
+ dp(j) = t(i+j) - x
+ 19 continue
+ else
+ jcmax = k + nmi
+ do 15 j=1,jcmax
+ dp(j) = t(i+j) - x
+ 15 continue
+ do 16 j=jcmax,km1
+ aj(j+1) = 0.
+ dp(j) = dp(jcmax)
+ 16 continue
+ endif
+
+c
+ do 21 jc=jcmin,jcmax
+ aj(jc) = bcoef(imk + jc)
+ 21 continue
+c
+c *** difference the coefficients jderiv times.
+ if (jderiv .ge. 1) then
+ do 23 j=1,jderiv
+ kmj = k-j
+ fkmj = dble(kmj)
+ ilo = kmj
+ do 24 jj=1,kmj
+ aj(jj) = ((aj(jj+1) - aj(jj))/(dm(ilo) + dp(jj)))*fkmj
+ ilo = ilo - 1
+ 24 continue
+ 23 continue
+ endif
+
+c
+c *** compute value at x in (t(i),t(i+1)) of jderiv-th derivative,
+c given its relevant b-spline coeffs in aj(1),...,aj(k-jderiv).
+
+ 30 if (jderiv .ne. km1) then
+ jdrvp1 = jderiv + 1
+ do 33 j=jdrvp1,km1
+ kmj = k-j
+ ilo = kmj
+ do 34 jj=1,kmj
+ aj(jj) = (aj(jj+1)*dm(ilo) + aj(jj)*dp(jj)) /
+ * (dm(ilo)+dp(jj))
+ ilo = ilo - 1
+ 34 continue
+ 33 continue
+ endif
+
+ 39 bvalue = aj(1)
+c
+ 99 return
+ end
diff --git a/src/bvalus.f b/src/bvalus.f
new file mode 100644
index 0000000..8d78ced
--- /dev/null
+++ b/src/bvalus.f
@@ -0,0 +1,14 @@
+ subroutine bvalus(n,knot,coef,nk,x,s,order)
+C Args
+ integer n, nk, order
+ double precision knot(*),coef(*),x(*),s(*)
+C Local
+ double precision bvalue
+ integer i
+
+ do 10 i=1,n
+ s(i)=bvalue(knot,n+4,coef,nk,4,x(i),order)
+C ---- typo corrected from gamfit
+ 10 continue
+ return
+ end
diff --git a/src/linear.f b/src/linear.f
new file mode 100644
index 0000000..d927aca
--- /dev/null
+++ b/src/linear.f
@@ -0,0 +1,2926 @@
+C Output from Public domain Ratfor, version 1.01
+ subroutine dqrls(x,dx,pivot,qraux,y,dy,beta,res,qt,tol,scrtch,rank
+ *)
+ integer pivot(1),dx(2),dy(2),rank
+ double precision x(1), qraux(1), y(1), beta(1),res(1),qt(1),tol(1)
+ *, scrtch(1)
+ integer n,p,q,kn,kp,k,info
+ n=dx(1)
+ p=dx(2)
+ q=dy(2)
+ call dqrdca(x,n,n,p,qraux,pivot,scrtch,rank,tol(1))
+ kn=1
+ kp=1
+ if(rank.gt.0)then
+ k=1
+23002 if(.not.(k.le.q))goto 23004
+ call dqrsl(x,n,n,rank,qraux,y(kn),scrtch,qt(kn),beta(kp), res(kn),
+ *scrtch,00110,info)
+ kn = kn+n
+ kp=kp+p
+23003 k=k+1
+ goto 23002
+23004 continue
+ endif
+ return
+ end
+ subroutine dqrsl1(qr,dq,qra,rank,y,k,qy,qb,job,info)
+ double precision qr(1),qra(1),y(1),qy(1),qb(1)
+ integer dq(2),job,k,rank
+ integer n,kn,kb,j
+ double precision ourqty(1), ourqy(1), ourb(1), ourrsd(1), ourxb(1)
+ ourqty(1) = 0d0
+ ourqy(1) = 0d0
+ ourb(1) = 0d0
+ ourrsd(1) = 0d0
+ ourxb(1) = 0d0
+ n = dq(1)
+ kn = 1
+ kb = 1
+ I23005=(job)
+ goto 23005
+23007 continue
+ j=0
+23008 if(.not.(j.lt.k))goto 23010
+ call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),qy(kn),ourqty,ourb,ourrsd
+ *,ourxb,job,info)
+ kn = kn +n
+23009 j = j+1
+ goto 23008
+23010 continue
+ goto 23006
+23011 continue
+ j=0
+23012 if(.not.(j.lt.k))goto 23014
+ call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),ourqy,qy(kn),ourb,ourrsd,
+ *ourxb,job,info)
+ kn = kn +n
+23013 j = j+1
+ goto 23012
+23014 continue
+ goto 23006
+23015 continue
+ j=0
+23016 if(.not.(j.lt.k))goto 23018
+ call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),ourqy,qy(kn),qb(kb),ourrs
+ *d,ourxb,job,info)
+ kn = kn +n
+ kb = kb +rank
+23017 j = j+1
+ goto 23016
+23018 continue
+ goto 23006
+23019 continue
+ j=0
+23020 if(.not.(j.lt.k))goto 23022
+ call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),ourqy,qy(kn),ourb,qb(kn),
+ *ourxb,job,info)
+ kn = kn +n
+23021 j = j+1
+ goto 23020
+23022 continue
+ goto 23006
+23023 continue
+ j=0
+23024 if(.not.(j.lt.k))goto 23026
+ call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),ourqy,qy(kn),ourb,ourrsd,
+ *qb(kn),job,info)
+ kn = kn +n
+23025 j = j+1
+ goto 23024
+23026 continue
+ goto 23006
+23027 continue
+ info = -1
+ goto 23006
+23005 continue
+ if (I23005.eq.1)goto 23023
+ if (I23005.eq.10)goto 23019
+ if (I23005.eq.100)goto 23015
+ if (I23005.eq.1000)goto 23011
+ if (I23005.eq.10000)goto 23007
+ goto 23027
+23006 continue
+ return
+ end
+ subroutine dqr(x,dx,pivot,qraux,tol,scrtch,rank)
+ integer pivot(1),dx(2),rank
+ double precision x(1), qraux(1), tol(1), scrtch(1)
+ integer n,p
+ n=dx(1)
+ p=dx(2)
+ call dqrdca(x,n,n,p,qraux,pivot,scrtch,rank,tol(1))
+ return
+ end
+ subroutine dqrdca(x,ldx,n,p,qraux,jpvt,work,rank,eps)
+ integer ldx,n,p,rank
+ integer jpvt(1)
+ double precision x(ldx,1),qraux(1),work(1),eps
+ integer j,jj,jp,l,lup,curpvt
+ double precision dnrm2,tt
+ double precision ddot,nrmxl,t,ww
+ do23028 j=1,p
+ qraux(j) = dnrm2(n,x(1,j),1)
+ work(j) = qraux(j)
+ work(j+p) = qraux(j)
+23028 continue
+23029 continue
+ l=1
+ lup = min0(n,p)
+ curpvt = p
+23030 if(l.le.lup)then
+ qraux(l) = 0.0d0
+ nrmxl = dnrm2(n-l+1,x(l,l),1)
+ t = work(l+p)
+ if(t .gt. 0.)then
+ t = nrmxl/t
+ endif
+ if(t .lt. eps)then
+ call dshift(x,ldx,n,l,curpvt)
+ jp = jpvt(l)
+ t=qraux(l)
+ tt=work(l)
+ ww = work(l+p)
+ j=l+1
+23036 if(.not.(j.le.curpvt))goto 23038
+ jj=j-1
+ jpvt(jj)=jpvt(j)
+ qraux(jj)=qraux(j)
+ work(jj)=work(j)
+ work(jj+p) = work(j+p)
+23037 j=j+1
+ goto 23036
+23038 continue
+ jpvt(curpvt)=jp
+ qraux(curpvt)=t
+ work(curpvt)=tt
+ work(curpvt+p) = ww
+ curpvt=curpvt-1
+ if(lup.gt.curpvt)then
+ lup=curpvt
+ endif
+ else
+ if(l.eq.n)then
+ goto 23031
+ endif
+ if(x(l,l).ne.0.0d0)then
+ nrmxl = dsign(nrmxl,x(l,l))
+ endif
+ call dscal(n-l+1,1.0d0/nrmxl,x(l,l),1)
+ x(l,l) = 1.0d0+x(l,l)
+ j=l+1
+23045 if(.not.(j.le.curpvt))goto 23047
+ t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l)
+ call daxpy(n-l+1,t,x(l,l),1,x(l,j),1)
+ if(qraux(j).ne.0.0d0)then
+ tt = 1.0d0-(dabs(x(l,j))/qraux(j))**2
+ tt = dmax1(tt,0.0d0)
+ t = tt
+ tt = 1.0d0+0.05d0*tt*(qraux(j)/work(j))**2
+ if(tt.ne.1.0d0)then
+ qraux(j) = qraux(j)*dsqrt(t)
+ else
+ qraux(j) = dnrm2(n-l,x(l+1,j),1)
+ work(j) = qraux(j)
+ endif
+ endif
+23046 j=j+1
+ goto 23045
+23047 continue
+ qraux(l) = x(l,l)
+ x(l,l) = -nrmxl
+ l=l+1
+ endif
+ goto 23030
+ endif
+23031 continue
+ rank = lup
+ return
+ end
+ subroutine dchdc(a,lda,p,work,jpvt,job,info)
+ integer lda,p,jpvt(p),job,info
+ double precision a(lda,p),work(p)
+ integer pu,pl,plp1,j,jp,jt,k,kb,km1,kp1,l,maxl
+ double precision temp
+ double precision maxdia
+ logical swapk,negk
+ pl = 1
+ pu = 0
+ info = p
+ if(job.ne.0)then
+ do23054 k = 1,p
+ swapk = jpvt(k).gt.0
+ negk = jpvt(k).lt.0
+ jpvt(k) = k
+ if(negk)then
+ jpvt(k) = -jpvt(k)
+ endif
+ if(swapk)then
+ if(k.ne.pl)then
+ call dswap(pl-1,a(1,k),1,a(1,pl),1)
+ temp = a(k,k)
+ a(k,k) = a(pl,pl)
+ a(pl,pl) = temp
+ plp1 = pl+1
+ if(p.ge.plp1)then
+ do23064 j = plp1,p
+ if(j.lt.k)then
+ temp = a(pl,j)
+ a(pl,j) = a(j,k)
+ a(j,k) = temp
+ else
+ if(j.ne.k)then
+ temp = a(k,j)
+ a(k,j) = a(pl,j)
+ a(pl,j) = temp
+ endif
+ endif
+23064 continue
+23065 continue
+ endif
+ jpvt(k) = jpvt(pl)
+ jpvt(pl) = k
+ endif
+ pl = pl+1
+ endif
+23054 continue
+23055 continue
+ pu = p
+ if(p.ge.pl)then
+ do23072 kb = pl,p
+ k = p-kb+pl
+ if(jpvt(k).lt.0)then
+ jpvt(k) = -jpvt(k)
+ if(pu.ne.k)then
+ call dswap(k-1,a(1,k),1,a(1,pu),1)
+ temp = a(k,k)
+ a(k,k) = a(pu,pu)
+ a(pu,pu) = temp
+ kp1 = k+1
+ if(p.ge.kp1)then
+ do23080 j = kp1,p
+ if(j.lt.pu)then
+ temp = a(k,j)
+ a(k,j) = a(j,pu)
+ a(j,pu) = temp
+ else
+ if(j.ne.pu)then
+ temp = a(k,j)
+ a(k,j) = a(pu,j)
+ a(pu,j) = temp
+ endif
+ endif
+23080 continue
+23081 continue
+ endif
+ jt = jpvt(k)
+ jpvt(k) = jpvt(pu)
+ jpvt(pu) = jt
+ endif
+ pu = pu-1
+ endif
+23072 continue
+23073 continue
+ endif
+ endif
+ do23086 k = 1,p
+ maxdia = a(k,k)
+ kp1 = k+1
+ maxl = k
+ if(k.ge.pl.and.k.lt.pu)then
+ do23090 l = kp1,pu
+ if(a(l,l).gt.maxdia)then
+ maxdia = a(l,l)
+ maxl = l
+ endif
+23090 continue
+23091 continue
+ endif
+ if(maxdia.le.0.0d0)then
+ go to 10
+ endif
+ if(k.ne.maxl)then
+ km1 = k-1
+ call dswap(km1,a(1,k),1,a(1,maxl),1)
+ a(maxl,maxl) = a(k,k)
+ a(k,k) = maxdia
+ jp = jpvt(maxl)
+ jpvt(maxl) = jpvt(k)
+ jpvt(k) = jp
+ endif
+ work(k) = dsqrt(a(k,k))
+ a(k,k) = work(k)
+ if(p.ge.kp1)then
+ do23100 j = kp1,p
+ if(k.ne.maxl)then
+ if(j.lt.maxl)then
+ temp = a(k,j)
+ a(k,j) = a(j,maxl)
+ a(j,maxl) = temp
+ else
+ if(j.ne.maxl)then
+ temp = a(k,j)
+ a(k,j) = a(maxl,j)
+ a(maxl,j) = temp
+ endif
+ endif
+ endif
+ a(k,j) = a(k,j)/work(k)
+ work(j) = a(k,j)
+ temp = -a(k,j)
+ call daxpy(j-k,temp,work(kp1),1,a(kp1,j),1)
+23100 continue
+23101 continue
+ endif
+23086 continue
+23087 continue
+ return
+10 info = k-1
+ return
+ end
+ double precision function epslon(x)
+ double precision x
+ double precision a,b,c,eps
+ a = 4.0d0/3.0d0
+23108 continue
+ b = a-1.0d0
+ c = b+b+b
+ eps = dabs(c-1.0d0)
+23109 if(.not.(eps.ne.0.0d0))goto 23108
+23110 continue
+ epslon = eps*dabs(x)
+ return
+ end
+ double precision function pythag(a,b)
+ double precision a,b
+ double precision p,r,s,t,u
+ p = dmax1(dabs(a),dabs(b))
+ if(p.ne.0.0d0)then
+ r = (dmin1(dabs(a),dabs(b))/p)**2
+23113 continue
+ t = 4.0d0+r
+ if(t.eq.4.0d0)then
+ goto 23115
+ endif
+ s = r/t
+ u = 1.0d0+2.0d0*s
+ p = u*p
+ r = (s/u)**2*r
+23114 goto 23113
+23115 continue
+ endif
+ pythag = p
+ return
+ end
+ subroutine rg(nm,n,a,wr,wi,matz,z,iv1,fv1,ierr)
+ integer n,nm,is1,is2,ierr,matz
+ double precision a(nm,n),wr(n),wi(n),z(nm,n),fv1(n)
+ integer iv1(n)
+ if(n.gt.nm)then
+ ierr = 10*n
+ else
+ call balanc(nm,n,a,is1,is2,fv1)
+ call elmhes(nm,n,is1,is2,a,iv1)
+ if(matz.eq.0)then
+ call hqr(nm,n,is1,is2,a,wr,wi,ierr)
+ else
+ call eltran(nm,n,is1,is2,a,iv1,z)
+ call hqr2(nm,n,is1,is2,a,wr,wi,z,ierr)
+ if(ierr.eq.0)then
+ call balbak(nm,n,is1,is2,fv1,n,z)
+ endif
+ endif
+ endif
+ return
+ end
+ subroutine chol(a,p,work,jpvt,job,info)
+ integer p,jpvt(1),job,info(1)
+ double precision a(p,1),work(1)
+ integer i,j
+ j =2
+23124 if(.not.(j.le.p))goto 23126
+ i=1
+23127 if(.not.(i.lt.j))goto 23129
+ if(a(i,j).ne.a(j,i))then
+ info(1) = -1
+ return
+ endif
+23128 i = i+1
+ goto 23127
+23129 continue
+23125 j = j+1
+ goto 23124
+23126 continue
+ call dchdc(a,p,p,work,jpvt,job,info(1))
+ j =2
+23132 if(.not.(j.le.p))goto 23134
+ i=1
+23135 if(.not.(i.lt.j))goto 23137
+ a(j,i) = 0.
+23136 i = i+1
+ goto 23135
+23137 continue
+23133 j = j+1
+ goto 23132
+23134 continue
+ return
+ end
+ subroutine crs(x,dmx,matz,w,z,fv1,fv2,ierr)
+ double precision x(1),w(1),z(1),fv1(1),fv2(1)
+ integer dmx(2),nx,nv,ierr,matz
+ nx=dmx(1)
+ nv=dmx(2)
+ call rs(nx,nv,x,w,matz,z,fv1,fv2,ierr)
+ return
+ end
+ subroutine dqrls2(x,dx,pivot,qraux,y,dy,beta,res,qt,scrtch,eps)
+ integer pivot(1),dx(2),dy(2)
+ double precision x(1), qraux(1), y(1), beta(1),res(1),qt(1), scrtc
+ *h(1),eps
+ integer n,p,q,kn,kp,k,info,rank
+ n=dx(1)
+ p=dx(2)
+ q=dy(2)
+ call dqrdca(x,n,n,p,qraux,pivot,scrtch,rank,eps)
+ kn=1
+ kp=1
+ k=1
+23138 if(.not.(k.le.q))goto 23140
+ call dqrsl(x,n,n,p,qraux,y(kn),scrtch,qt(kn),beta(kp), res(kn),scr
+ *tch,00110,info)
+ kn = kn+n
+ kp=kp+p
+23139 k=k+1
+ goto 23138
+23140 continue
+ return
+ end
+ subroutine dsvdc1(x,dmx,job,work,e,s,u,v,info)
+ double precision x(1),work(1),s(1),e(1),u(1),v(1)
+ integer dmx(2),nx,nv,job,info
+ nx=dmx(1)
+ nv=dmx(2)
+ call dsvdc(x,nx,nx,nv,s,e,u,nx,v,nv,work,job,info)
+ return
+ end
+ subroutine balanc(nm,n,a,low,igh,scale)
+ integer i,j,k,l,m,n,nm,igh,low,iexc
+ double precision a(nm,n),scale(n)
+ double precision c,f,g,r,s,b2,radix
+ logical noconv
+ radix = 16.0d0
+ b2 = radix*radix
+ k = 1
+ l = n
+23141 continue
+ j=l
+23144 if(.not.(j.gt.0))goto 23146
+ do23147 i = 1,l
+ if(i.ne.j)then
+ if(a(j,i).ne.0.0d0)then
+ goto 23145
+ endif
+ endif
+23147 continue
+23148 continue
+ go to 10
+23145 j=j-1
+ goto 23144
+23146 continue
+ go to 20
+10 m = l
+ iexc = 1
+23153 continue
+ scale(m) = j
+ if(j.ne.m)then
+ do23158 i = 1,l
+ f = a(i,j)
+ a(i,j) = a(i,m)
+ a(i,m) = f
+23158 continue
+23159 continue
+ do23160 i = k,n
+ f = a(j,i)
+ a(j,i) = a(m,i)
+ a(m,i) = f
+23160 continue
+23161 continue
+ endif
+ I23162=(iexc)
+ goto 23162
+23164 continue
+ if(l.eq.1)then
+ go to 40
+ endif
+ l = l-1
+ goto 23155
+ goto 23163
+23167 continue
+ k = k+1
+20 do23168 j = k,l
+ do23170 i = k,l
+ if(i.ne.j)then
+ if(a(i,j).ne.0.0d0)then
+ goto 23168
+ endif
+ endif
+23170 continue
+23171 continue
+ go to 30
+23168 continue
+23169 continue
+ goto 23143
+30 m = k
+ iexc = 2
+ goto 23163
+23162 continue
+ if (I23162.eq.1)goto 23164
+ if (I23162.eq.2)goto 23167
+23163 continue
+23154 goto 23153
+23155 continue
+23142 goto 23141
+23143 continue
+ do23176 i = k,l
+ scale(i) = 1.0d0
+23176 continue
+23177 continue
+23178 continue
+ noconv = .false.
+ do23181 i = k,l
+ c = 0.0d0
+ r = 0.0d0
+ do23183 j = k,l
+ if(j.ne.i)then
+ c = c+dabs(a(j,i))
+ r = r+dabs(a(i,j))
+ endif
+23183 continue
+23184 continue
+ if(c.ne.0.0d0.and.r.ne.0.0d0)then
+ g = r/radix
+ f = 1.0d0
+ s = c+r
+23189 if(c.lt.g)then
+ f = f*radix
+ c = c*b2
+ goto 23189
+ endif
+23190 continue
+ g = r*radix
+23191 if(c.ge.g)then
+ f = f/radix
+ c = c/b2
+ goto 23191
+ endif
+23192 continue
+ if((c+r)/f.lt.0.95d0*s)then
+ g = 1.0d0/f
+ scale(i) = scale(i)*f
+ noconv = .true.
+ do23195 j = k,n
+ a(i,j) = a(i,j)*g
+23195 continue
+23196 continue
+ do23197 j = 1,l
+ a(j,i) = a(j,i)*f
+23197 continue
+23198 continue
+ endif
+ endif
+23181 continue
+23182 continue
+23179 if(.not.(.not.noconv))goto 23178
+23180 continue
+40 low = k
+ igh = l
+ return
+ end
+ subroutine balbak(nm,n,low,igh,scale,m,z)
+ integer i,j,k,m,n,ii,nm,igh,low
+ double precision scale(n),z(nm,m)
+ double precision s
+ if(m.ne.0)then
+ if(igh.ne.low)then
+ do23203 i = low,igh
+ s = scale(i)
+ do23205 j = 1,m
+ z(i,j) = z(i,j)*s
+23205 continue
+23206 continue
+23203 continue
+23204 continue
+ endif
+ do23207 ii = 1,n
+ i = ii
+ if(i.lt.low.or.i.gt.igh)then
+ if(i.lt.low)then
+ i = low-ii
+ endif
+ k = scale(i)
+ if(k.ne.i)then
+ do23215 j = 1,m
+ s = z(i,j)
+ z(i,j) = z(k,j)
+ z(k,j) = s
+23215 continue
+23216 continue
+ endif
+ endif
+23207 continue
+23208 continue
+ endif
+ return
+ end
+ subroutine elmhes(nm,n,low,igh,a,int)
+ integer i,j,m,n,la,nm,igh,kp1,low,mm1,mp1
+ double precision a(nm,n)
+ double precision x,y
+ integer int(igh)
+ la = igh-1
+ kp1 = low+1
+ if(la.ge.kp1)then
+ do23219 m = kp1,la
+ mm1 = m-1
+ x = 0.0d0
+ i = m
+ do23221 j = m,igh
+ if(dabs(a(j,mm1)).gt.dabs(x))then
+ x = a(j,mm1)
+ i = j
+ endif
+23221 continue
+23222 continue
+ int(m) = i
+ if(i.ne.m)then
+ do23227 j = mm1,n
+ y = a(i,j)
+ a(i,j) = a(m,j)
+ a(m,j) = y
+23227 continue
+23228 continue
+ do23229 j = 1,igh
+ y = a(j,i)
+ a(j,i) = a(j,m)
+ a(j,m) = y
+23229 continue
+23230 continue
+ endif
+ if(x.ne.0.0d0)then
+ mp1 = m+1
+ do23233 i = mp1,igh
+ y = a(i,mm1)
+ if(y.ne.0.0d0)then
+ y = y/x
+ a(i,mm1) = y
+ do23237 j = m,n
+ a(i,j) = a(i,j)-y*a(m,j)
+23237 continue
+23238 continue
+ do23239 j = 1,igh
+ a(j,m) = a(j,m)+y*a(j,i)
+23239 continue
+23240 continue
+ endif
+23233 continue
+23234 continue
+ endif
+23219 continue
+23220 continue
+ endif
+ return
+ end
+ subroutine eltran(nm,n,low,igh,a,int,z)
+ integer i,j,n,kl,mp,nm,igh,low,mp1
+ double precision a(nm,igh),z(nm,n)
+ integer int(igh)
+ do23241 j = 1,n
+ do23243 i = 1,n
+ z(i,j) = 0.0d0
+23243 continue
+23244 continue
+ z(j,j) = 1.0d0
+23241 continue
+23242 continue
+ kl = igh-low-1
+ if(kl.ge.1)then
+ mp = igh-1
+23247 if(.not.(mp .gt. low))goto 23249
+ mp1 = mp+1
+ do23250 i = mp1,igh
+ z(i,mp) = a(i,mp-1)
+23250 continue
+23251 continue
+ i = int(mp)
+ if(i.ne.mp)then
+ do23254 j = mp,igh
+ z(mp,j) = z(i,j)
+ z(i,j) = 0.0d0
+23254 continue
+23255 continue
+ z(i,mp) = 1.0d0
+ endif
+23248 mp = mp -1
+ goto 23247
+23249 continue
+ endif
+ return
+ end
+ subroutine hqr(nm,n,low,igh,h,wr,wi,ierr)
+ integer i,j,k,l,m,n,en,mm,na,nm,igh,itn,its,low,mp2,enm2,ierr
+ double precision h(nm,n),wr(n),wi(n)
+ double precision p,q,r,s,t,w,x,y,zz,norm,tst1,tst2
+ logical notlas
+ ierr = 0
+ norm = 0.0d0
+ k = 1
+ do23256 i = 1,n
+ do23258 j = k,n
+ norm = norm+dabs(h(i,j))
+23258 continue
+23259 continue
+ k = i
+ if(i.lt.low.or.i.gt.igh)then
+ wr(i) = h(i,i)
+ wi(i) = 0.0d0
+ endif
+23256 continue
+23257 continue
+ en = igh
+ t = 0.0d0
+ itn = 30*n
+23262 continue
+ if(en.lt.low)then
+ return
+ endif
+ its = 0
+ na = en-1
+ enm2 = na-1
+23267 continue
+ l=en
+23270 if(.not.(l .gt. low))goto 23272
+ s = dabs(h(l-1,l-1))+dabs(h(l,l))
+ if(s.eq.0.0d0)then
+ s = norm
+ endif
+ tst1 = s
+ tst2 = tst1+dabs(h(l,l-1))
+ if(tst2.eq.tst1)then
+ goto 23272
+ endif
+23271 l = l-1
+ goto 23270
+23272 continue
+ x = h(en,en)
+ if(l.eq.en)then
+ go to 50
+ endif
+ y = h(na,na)
+ w = h(en,na)*h(na,en)
+ if(l.eq.na)then
+ goto 23269
+ endif
+ if(itn.eq.0)then
+ goto 23264
+ endif
+ if(its.eq.10.or.its.eq.20)then
+ t = t+x
+ do23285 i = low,en
+ h(i,i) = h(i,i)-x
+23285 continue
+23286 continue
+ s = dabs(h(en,na))+dabs(h(na,enm2))
+ x = 0.75d0*s
+ y = x
+ w = -0.4375d0*s*s
+ endif
+ its = its+1
+ itn = itn-1
+ do23287 mm = l,enm2
+ m = enm2+l-mm
+ zz = h(m,m)
+ r = x-zz
+ s = y-zz
+ p = (r*s-w)/h(m+1,m)+h(m,m+1)
+ q = h(m+1,m+1)-zz-r-s
+ r = h(m+2,m+1)
+ s = dabs(p)+dabs(q)+dabs(r)
+ p = p/s
+ q = q/s
+ r = r/s
+ if(m.eq.l)then
+ goto 23288
+ endif
+ tst1 = dabs(p)*(dabs(h(m-1,m-1))+dabs(zz)+dabs(h(m+1,m+1)))
+ tst2 = tst1+dabs(h(m,m-1))*(dabs(q)+dabs(r))
+ if(tst2.eq.tst1)then
+ goto 23288
+ endif
+23287 continue
+23288 continue
+ mp2 = m+2
+ do23293 i = mp2,en
+ h(i,i-2) = 0.0d0
+ if(i.ne.mp2)then
+ h(i,i-3) = 0.0d0
+ endif
+23293 continue
+23294 continue
+ do23297 k = m,na
+ notlas = k.ne.na
+ if(k.ne.m)then
+ p = h(k,k-1)
+ q = h(k+1,k-1)
+ r = 0.0d0
+ if(notlas)then
+ r = h(k+2,k-1)
+ endif
+ x = dabs(p)+dabs(q)+dabs(r)
+ if(x.eq.0.0d0)then
+ goto 23297
+ endif
+ p = p/x
+ q = q/x
+ r = r/x
+ endif
+ s = dsign(dsqrt(p*p+q*q+r*r),p)
+ if(k.ne.m)then
+ h(k,k-1) = -s*x
+ else
+ if(l.ne.m)then
+ h(k,k-1) = -h(k,k-1)
+ endif
+ endif
+ p = p+s
+ x = p/s
+ y = q/s
+ zz = r/s
+ q = q/p
+ r = r/p
+ if(.not.notlas)then
+ do23311 j = k,n
+ p = h(k,j)+q*h(k+1,j)
+ h(k,j) = h(k,j)-p*x
+ h(k+1,j) = h(k+1,j)-p*y
+23311 continue
+23312 continue
+ j = min0(en,k+3)
+ do23313 i = 1,j
+ p = x*h(i,k)+y*h(i,k+1)
+ h(i,k) = h(i,k)-p
+ h(i,k+1) = h(i,k+1)-p*q
+23313 continue
+23314 continue
+ else
+ do23315 j = k,n
+ p = h(k,j)+q*h(k+1,j)+r*h(k+2,j)
+ h(k,j) = h(k,j)-p*x
+ h(k+1,j) = h(k+1,j)-p*y
+ h(k+2,j) = h(k+2,j)-p*zz
+23315 continue
+23316 continue
+ j = min0(en,k+3)
+ do23317 i = 1,j
+ p = x*h(i,k)+y*h(i,k+1)+zz*h(i,k+2)
+ h(i,k) = h(i,k)-p
+ h(i,k+1) = h(i,k+1)-p*q
+ h(i,k+2) = h(i,k+2)-p*r
+23317 continue
+23318 continue
+ endif
+23297 continue
+23298 continue
+23268 goto 23267
+23269 continue
+ p = (y-x)/2.0d0
+ q = p*p+w
+ zz = dsqrt(dabs(q))
+ x = x+t
+ if(q.lt.0.0d0)then
+ wr(na) = x+p
+ wr(en) = x+p
+ wi(na) = zz
+ wi(en) = -zz
+ else
+ zz = p+dsign(zz,p)
+ wr(na) = x+zz
+ wr(en) = wr(na)
+ if(zz.ne.0.0d0)then
+ wr(en) = x-w/zz
+ endif
+ wi(na) = 0.0d0
+ wi(en) = 0.0d0
+ endif
+ en = enm2
+ goto 23263
+50 wr(en) = x+t
+ wi(en) = 0.0d0
+ en = na
+23263 goto 23262
+23264 continue
+ ierr = en
+ return
+ end
+ subroutine hqr2(nm,n,low,igh,h,wr,wi,z,ierr)
+ integer i,j,k,l,m,n,en,ii,jj,ll,mm,na,nm,nn,igh,itn,its,low,mp2,en
+ *m2,ierr
+ double precision h(nm,n),wr(n),wi(n),z(nm,n)
+ double precision p,q,r,s,t,w,x,y,ra,sa,vi,vr,zz,norm,tst1,tst2
+ logical notlas
+ ierr = 0
+ norm = 0.0d0
+ k = 1
+ do23323 i = 1,n
+ do23325 j = k,n
+ norm = norm+dabs(h(i,j))
+23325 continue
+23326 continue
+ k = i
+ if(i.lt.low.or.i.gt.igh)then
+ wr(i) = h(i,i)
+ wi(i) = 0.0d0
+ endif
+23323 continue
+23324 continue
+ en = igh
+ t = 0.0d0
+ itn = 30*n
+23329 continue
+ if(en.lt.low)then
+ go to 70
+ endif
+ its = 0
+ na = en-1
+ enm2 = na-1
+23334 continue
+ do23337 ll = low,en
+ l = en+low-ll
+ if(l.eq.low)then
+ goto 23338
+ endif
+ s = dabs(h(l-1,l-1))+dabs(h(l,l))
+ if(s.eq.0.0d0)then
+ s = norm
+ endif
+ tst1 = s
+ tst2 = tst1+dabs(h(l,l-1))
+ if(tst2.eq.tst1)then
+ goto 23338
+ endif
+23337 continue
+23338 continue
+ x = h(en,en)
+ if(l.eq.en)then
+ go to 60
+ endif
+ y = h(na,na)
+ w = h(en,na)*h(na,en)
+ if(l.eq.na)then
+ goto 23336
+ endif
+ if(itn.eq.0)then
+ goto 23331
+ endif
+ if(its.eq.10.or.its.eq.20)then
+ t = t+x
+ do23353 i = low,en
+ h(i,i) = h(i,i)-x
+23353 continue
+23354 continue
+ s = dabs(h(en,na))+dabs(h(na,enm2))
+ x = 0.75d0*s
+ y = x
+ w = -0.4375d0*s*s
+ endif
+ its = its+1
+ itn = itn-1
+ do23355 mm = l,enm2
+ m = enm2+l-mm
+ zz = h(m,m)
+ r = x-zz
+ s = y-zz
+ p = (r*s-w)/h(m+1,m)+h(m,m+1)
+ q = h(m+1,m+1)-zz-r-s
+ r = h(m+2,m+1)
+ s = dabs(p)+dabs(q)+dabs(r)
+ p = p/s
+ q = q/s
+ r = r/s
+ if(m.eq.l)then
+ goto 23356
+ endif
+ tst1 = dabs(p)*(dabs(h(m-1,m-1))+dabs(zz)+dabs(h(m+1,m+1)))
+ tst2 = tst1+dabs(h(m,m-1))*(dabs(q)+dabs(r))
+ if(tst2.eq.tst1)then
+ goto 23356
+ endif
+23355 continue
+23356 continue
+ mp2 = m+2
+ do23361 i = mp2,en
+ h(i,i-2) = 0.0d0
+ if(i.ne.mp2)then
+ h(i,i-3) = 0.0d0
+ endif
+23361 continue
+23362 continue
+ do23365 k = m,na
+ notlas = k.ne.na
+ if(k.ne.m)then
+ p = h(k,k-1)
+ q = h(k+1,k-1)
+ r = 0.0d0
+ if(notlas)then
+ r = h(k+2,k-1)
+ endif
+ x = dabs(p)+dabs(q)+dabs(r)
+ if(x.eq.0.0d0)then
+ goto 23365
+ endif
+ p = p/x
+ q = q/x
+ r = r/x
+ endif
+ s = dsign(dsqrt(p*p+q*q+r*r),p)
+ if(k.ne.m)then
+ h(k,k-1) = -s*x
+ else
+ if(l.ne.m)then
+ h(k,k-1) = -h(k,k-1)
+ endif
+ endif
+ p = p+s
+ x = p/s
+ y = q/s
+ zz = r/s
+ q = q/p
+ r = r/p
+ if(.not.notlas)then
+ do23379 j = k,n
+ p = h(k,j)+q*h(k+1,j)
+ h(k,j) = h(k,j)-p*x
+ h(k+1,j) = h(k+1,j)-p*y
+23379 continue
+23380 continue
+ j = min0(en,k+3)
+ do23381 i = 1,j
+ p = x*h(i,k)+y*h(i,k+1)
+ h(i,k) = h(i,k)-p
+ h(i,k+1) = h(i,k+1)-p*q
+23381 continue
+23382 continue
+ do23383 i = low,igh
+ p = x*z(i,k)+y*z(i,k+1)
+ z(i,k) = z(i,k)-p
+ z(i,k+1) = z(i,k+1)-p*q
+23383 continue
+23384 continue
+ else
+ do23385 j = k,n
+ p = h(k,j)+q*h(k+1,j)+r*h(k+2,j)
+ h(k,j) = h(k,j)-p*x
+ h(k+1,j) = h(k+1,j)-p*y
+ h(k+2,j) = h(k+2,j)-p*zz
+23385 continue
+23386 continue
+ j = min0(en,k+3)
+ do23387 i = 1,j
+ p = x*h(i,k)+y*h(i,k+1)+zz*h(i,k+2)
+ h(i,k) = h(i,k)-p
+ h(i,k+1) = h(i,k+1)-p*q
+ h(i,k+2) = h(i,k+2)-p*r
+23387 continue
+23388 continue
+ do23389 i = low,igh
+ p = x*z(i,k)+y*z(i,k+1)+zz*z(i,k+2)
+ z(i,k) = z(i,k)-p
+ z(i,k+1) = z(i,k+1)-p*q
+ z(i,k+2) = z(i,k+2)-p*r
+23389 continue
+23390 continue
+ endif
+23365 continue
+23366 continue
+23335 goto 23334
+23336 continue
+ p = (y-x)/2.0d0
+ q = p*p+w
+ zz = dsqrt(dabs(q))
+ h(en,en) = x+t
+ x = h(en,en)
+ h(na,na) = y+t
+ if(q.lt.0.0d0)then
+ wr(na) = x+p
+ wr(en) = x+p
+ wi(na) = zz
+ wi(en) = -zz
+ else
+ zz = p+dsign(zz,p)
+ wr(na) = x+zz
+ wr(en) = wr(na)
+ if(zz.ne.0.0d0)then
+ wr(en) = x-w/zz
+ endif
+ wi(na) = 0.0d0
+ wi(en) = 0.0d0
+ x = h(en,na)
+ s = dabs(x)+dabs(zz)
+ p = x/s
+ q = zz/s
+ r = dsqrt(p*p+q*q)
+ p = p/r
+ q = q/r
+ do23395 j = na,n
+ zz = h(na,j)
+ h(na,j) = q*zz+p*h(en,j)
+ h(en,j) = q*h(en,j)-p*zz
+23395 continue
+23396 continue
+ do23397 i = 1,en
+ zz = h(i,na)
+ h(i,na) = q*zz+p*h(i,en)
+ h(i,en) = q*h(i,en)-p*zz
+23397 continue
+23398 continue
+ do23399 i = low,igh
+ zz = z(i,na)
+ z(i,na) = q*zz+p*z(i,en)
+ z(i,en) = q*z(i,en)-p*zz
+23399 continue
+23400 continue
+ endif
+ en = enm2
+ goto 23330
+60 h(en,en) = x+t
+ wr(en) = h(en,en)
+ wi(en) = 0.0d0
+ en = na
+23330 goto 23329
+23331 continue
+ ierr = en
+ return
+70 if(norm.ne.0.0d0)then
+ do23403 nn = 1,n
+ en = n+1-nn
+ p = wr(en)
+ q = wi(en)
+ na = en-1
+ if(q.lt.0)then
+ m = na
+ if(dabs(h(en,na)).le.dabs(h(na,en)))then
+ call cdiv(0.0d0,-h(na,en),h(na,na)-p,q,h(na,na),h(na,en))
+ else
+ h(na,na) = q/h(en,na)
+ h(na,en) = -(h(en,en)-p)/h(en,na)
+ endif
+ h(en,na) = 0.0d0
+ h(en,en) = 1.0d0
+ enm2 = na-1
+ if(enm2.ne.0)then
+ do23411 ii = 1,enm2
+ i = na-ii
+ w = h(i,i)-p
+ ra = 0.0d0
+ sa = 0.0d0
+ do23413 j = m,en
+ ra = ra+h(i,j)*h(j,na)
+ sa = sa+h(i,j)*h(j,en)
+23413 continue
+23414 continue
+ if(wi(i).lt.0.0d0)then
+ zz = w
+ r = ra
+ s = sa
+ else
+ m = i
+ if(wi(i).eq.0.0d0)then
+ call cdiv(-ra,-sa,w,q,h(i,na),h(i,en))
+ else
+ x = h(i,i+1)
+ y = h(i+1,i)
+ vr = (wr(i)-p)*(wr(i)-p)+wi(i)*wi(i)-q*q
+ vi = (wr(i)-p)*2.0d0*q
+ if(vr.eq.0.0d0.and.vi.eq.0.0d0)then
+ tst1 = norm*(dabs(w)+dabs(q)+dabs(x)+dabs(y)+dabs(zz))
+ vr = tst1
+23421 continue
+ vr = 0.01d0*vr
+ tst2 = tst1+vr
+23422 if(.not.(tst2.le.tst1))goto 23421
+23423 continue
+ endif
+ call cdiv(x*r-zz*ra+q*sa,x*s-zz*sa-q*ra,vr,vi,h(i,na),h(i,en))
+ if(dabs(x).le.dabs(zz)+dabs(q))then
+ call cdiv(-r-y*h(i,na),-s-y*h(i,en),zz,q,h(i+1,na),h(i+1,en))
+ else
+ h(i+1,na) = (-ra-w*h(i,na)+q*h(i,en))/x
+ h(i+1,en) = (-sa-w*h(i,en)-q*h(i,na))/x
+ endif
+ endif
+ t = dmax1(dabs(h(i,na)),dabs(h(i,en)))
+ if(t.ne.0.0d0)then
+ tst1 = t
+ tst2 = tst1+1.0d0/tst1
+ if(tst2.le.tst1)then
+ do23430 j = i,en
+ h(j,na) = h(j,na)/t
+ h(j,en) = h(j,en)/t
+23430 continue
+23431 continue
+ endif
+ endif
+ endif
+23411 continue
+23412 continue
+ endif
+ else
+ if(q.eq.0)then
+ m = en
+ h(en,en) = 1.0d0
+ if(na.ne.0)then
+ do23436 ii = 1,na
+ i = en-ii
+ w = h(i,i)-p
+ r = 0.0d0
+ do23438 j = m,en
+ r = r+h(i,j)*h(j,en)
+23438 continue
+23439 continue
+ if(wi(i).lt.0.0d0)then
+ zz = w
+ s = r
+ else
+ m = i
+ if(wi(i).ne.0.0d0)then
+ x = h(i,i+1)
+ y = h(i+1,i)
+ q = (wr(i)-p)*(wr(i)-p)+wi(i)*wi(i)
+ t = (x*s-zz*r)/q
+ h(i,en) = t
+ if(dabs(x).le.dabs(zz))then
+ h(i+1,en) = (-s-y*t)/zz
+ else
+ h(i+1,en) = (-r-w*t)/x
+ endif
+ else
+ t = w
+ if(t.eq.0.0d0)then
+ tst1 = norm
+ t = tst1
+23448 continue
+ t = 0.01d0*t
+ tst2 = norm+t
+23449 if(.not.(tst2.le.tst1))goto 23448
+23450 continue
+ endif
+ h(i,en) = -r/t
+ endif
+ t = dabs(h(i,en))
+ if(t.ne.0.0d0)then
+ tst1 = t
+ tst2 = tst1+1.0d0/tst1
+ if(tst2.le.tst1)then
+ do23455 j = i,en
+ h(j,en) = h(j,en)/t
+23455 continue
+23456 continue
+ endif
+ endif
+ endif
+23436 continue
+23437 continue
+ endif
+ endif
+ endif
+23403 continue
+23404 continue
+ do23457 i = 1,n
+ if(i.lt.low.or.i.gt.igh)then
+ do23461 j = i,n
+ z(i,j) = h(i,j)
+23461 continue
+23462 continue
+ endif
+23457 continue
+23458 continue
+ do23463 jj = low,n
+ j = n+low-jj
+ m = min0(j,igh)
+ do23465 i = low,igh
+ zz = 0.0d0
+ do23467 k = low,m
+ zz = zz+z(i,k)*h(k,j)
+23467 continue
+23468 continue
+ z(i,j) = zz
+23465 continue
+23466 continue
+23463 continue
+23464 continue
+ endif
+ return
+ end
+ subroutine cdiv(ar,ai,br,bi,cr,ci)
+ double precision ar,ai,br,bi,cr,ci
+ double precision s,ars,ais,brs,bis
+ s = dabs(br)+dabs(bi)
+ ars = ar/s
+ ais = ai/s
+ brs = br/s
+ bis = bi/s
+ s = brs**2+bis**2
+ cr = (ars*brs+ais*bis)/s
+ ci = (ais*brs-ars*bis)/s
+ return
+ end
+ subroutine rs(nm,n,a,w,matz,z,fv1,fv2,ierr)
+ integer n,nm,ierr,matz
+ double precision a(nm,n),w(n),z(nm,n),fv1(n),fv2(n)
+ if(n.gt.nm)then
+ ierr = 10*n
+ else
+ if(matz.ne.0)then
+ call tred2(nm,n,a,w,fv1,z)
+ call tql2(nm,n,w,fv1,z,ierr)
+ else
+ call tred1(nm,n,a,w,fv1,fv2)
+ call tqlrat(n,w,fv2,ierr)
+ endif
+ endif
+ return
+ end
+ subroutine tql2(nm,n,d,e,z,ierr)
+ integer i,j,k,l,m,n,ii,l1,l2,nm,mml,ierr
+ double precision d(n),e(n),z(nm,n)
+ double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag
+ ierr = 0
+ if(n.ne.1)then
+ do23475 i = 2,n
+ e(i-1) = e(i)
+23475 continue
+23476 continue
+ f = 0.0d0
+ tst1 = 0.0d0
+ e(n) = 0.0d0
+ do23477 l = 1,n
+ j = 0
+ h = dabs(d(l))+dabs(e(l))
+ if(tst1.lt.h)then
+ tst1 = h
+ endif
+ do23481 m = l,n
+ tst2 = tst1+dabs(e(m))
+ if(tst2.eq.tst1)then
+ goto 23482
+ endif
+23481 continue
+23482 continue
+ if(m.ne.l)then
+23487 continue
+ if(j.eq.30)then
+ go to 10
+ endif
+ j = j+1
+ l1 = l+1
+ l2 = l1+1
+ g = d(l)
+ p = (d(l1)-g)/(2.0d0*e(l))
+ r = pythag(p,1.0d0)
+ d(l) = e(l)/(p+dsign(r,p))
+ d(l1) = e(l)*(p+dsign(r,p))
+ dl1 = d(l1)
+ h = g-d(l)
+ if(l2.le.n)then
+ do23494 i = l2,n
+ d(i) = d(i)-h
+23494 continue
+23495 continue
+ endif
+ f = f+h
+ p = d(m)
+ c = 1.0d0
+ c2 = c
+ el1 = e(l1)
+ s = 0.0d0
+ mml = m-l
+ do23496 ii = 1,mml
+ c3 = c2
+ c2 = c
+ s2 = s
+ i = m-ii
+ g = c*e(i)
+ h = c*p
+ r = pythag(p,e(i))
+ e(i+1) = s*r
+ s = e(i)/r
+ c = p/r
+ p = c*d(i)-s*g
+ d(i+1) = h+s*(c*g+s*d(i))
+ do23498 k = 1,n
+ h = z(k,i+1)
+ z(k,i+1) = s*z(k,i)+c*h
+ z(k,i) = c*z(k,i)-s*h
+23498 continue
+23499 continue
+23496 continue
+23497 continue
+ p = -s*s2*c3*el1*e(l)/dl1
+ e(l) = s*p
+ d(l) = c*p
+ tst2 = tst1+dabs(e(l))
+23488 if(.not.(tst2.le.tst1))goto 23487
+23489 continue
+ endif
+ d(l) = d(l)+f
+23477 continue
+23478 continue
+ do23500 ii = 2,n
+ i = ii-1
+ k = i
+ p = d(i)
+ do23502 j = ii,n
+ if(d(j).lt.p)then
+ k = j
+ p = d(j)
+ endif
+23502 continue
+23503 continue
+ if(k.ne.i)then
+ d(k) = d(i)
+ d(i) = p
+ do23508 j = 1,n
+ p = z(j,i)
+ z(j,i) = z(j,k)
+ z(j,k) = p
+23508 continue
+23509 continue
+ endif
+23500 continue
+23501 continue
+ return
+10 ierr = l
+ endif
+ return
+ end
+ subroutine tqlrat(n,d,e2,ierr)
+ integer i,j,l,m,n,ii,l1,mml,ierr
+ double precision d(n),e2(n)
+ double precision b,c,f,g,h,p,r,s,t,epslon,pythag
+ ierr = 0
+ if(n.ne.1)then
+ do23512 i = 2,n
+ e2(i-1) = e2(i)
+23512 continue
+23513 continue
+ f = 0.0d0
+ t = 0.0d0
+ e2(n) = 0.0d0
+ do23514 l = 1,n
+ j = 0
+ h = dabs(d(l))+dsqrt(e2(l))
+ if(t.le.h)then
+ t = h
+ b = epslon(t)
+ c = b*b
+ endif
+ do23518 m = l,n
+ if(e2(m).le.c)then
+ goto 23519
+ endif
+23518 continue
+23519 continue
+ if(m.ne.l)then
+23524 continue
+ if(j.eq.30)then
+ go to 20
+ endif
+ j = j+1
+ l1 = l+1
+ s = dsqrt(e2(l))
+ g = d(l)
+ p = (d(l1)-g)/(2.0d0*s)
+ r = pythag(p,1.0d0)
+ d(l) = s/(p+dsign(r,p))
+ h = g-d(l)
+ do23529 i = l1,n
+ d(i) = d(i)-h
+23529 continue
+23530 continue
+ f = f+h
+ g = d(m)
+ if(g.eq.0.0d0)then
+ g = b
+ endif
+ h = g
+ s = 0.0d0
+ mml = m-l
+ do23533 ii = 1,mml
+ i = m-ii
+ p = g*h
+ r = p+e2(i)
+ e2(i+1) = s*r
+ s = e2(i)/r
+ d(i+1) = h+s*(h+d(i))
+ g = d(i)-e2(i)/g
+ if(g.eq.0.0d0)then
+ g = b
+ endif
+ h = g*p/r
+23533 continue
+23534 continue
+ e2(l) = s*g
+ d(l) = h
+ if(h.eq.0.0d0)then
+ goto 23526
+ endif
+ if(dabs(e2(l)).le.dabs(c/h))then
+ goto 23526
+ endif
+ e2(l) = h*e2(l)
+23525 if(.not.(e2(l).eq.0.0d0))goto 23524
+23526 continue
+ endif
+ p = d(l)+f
+ if(l.ne.1)then
+ do23543 ii = 2,l
+ i = l+2-ii
+ if(p.ge.d(i-1))then
+ go to 10
+ endif
+ d(i) = d(i-1)
+23543 continue
+23544 continue
+ endif
+ i = 1
+10 d(i) = p
+23514 continue
+23515 continue
+ return
+20 ierr = l
+ endif
+ return
+ end
+ subroutine tred1(nm,n,a,d,e,e2)
+ integer i,j,k,l,n,ii,nm,jp1
+ double precision a(nm,n),d(n),e(n),e2(n)
+ double precision f,g,h,scale
+ do23547 i = 1,n
+ d(i) = a(n,i)
+ a(n,i) = a(i,i)
+23547 continue
+23548 continue
+ do23549 ii = 1,n
+ i = n+1-ii
+ l = i-1
+ h = 0.0d0
+ scale = 0.0d0
+ if(l.ge.1)then
+ do23553 k = 1,l
+ scale = scale+dabs(d(k))
+23553 continue
+23554 continue
+ if(scale.eq.0.0d0)then
+ do23557 j = 1,l
+ d(j) = a(l,j)
+ a(l,j) = a(i,j)
+ a(i,j) = 0.0d0
+23557 continue
+23558 continue
+ else
+ do23559 k = 1,l
+ d(k) = d(k)/scale
+ h = h+d(k)*d(k)
+23559 continue
+23560 continue
+ e2(i) = scale*scale*h
+ f = d(l)
+ g = -dsign(dsqrt(h),f)
+ e(i) = scale*g
+ h = h-f*g
+ d(l) = f-g
+ if(l.ne.1)then
+ do23563 j = 1,l
+ e(j) = 0.0d0
+23563 continue
+23564 continue
+ do23565 j = 1,l
+ f = d(j)
+ g = e(j)+a(j,j)*f
+ jp1 = j+1
+ if(l.ge.jp1)then
+ do23569 k = jp1,l
+ g = g+a(k,j)*d(k)
+ e(k) = e(k)+a(k,j)*f
+23569 continue
+23570 continue
+ endif
+ e(j) = g
+23565 continue
+23566 continue
+ f = 0.0d0
+ do23571 j = 1,l
+ e(j) = e(j)/h
+ f = f+e(j)*d(j)
+23571 continue
+23572 continue
+ h = f/(h+h)
+ do23573 j = 1,l
+ e(j) = e(j)-h*d(j)
+23573 continue
+23574 continue
+ do23575 j = 1,l
+ f = d(j)
+ g = e(j)
+ do23577 k = j,l
+ a(k,j) = a(k,j)-f*e(k)-g*d(k)
+23577 continue
+23578 continue
+23575 continue
+23576 continue
+ endif
+ do23579 j = 1,l
+ f = d(j)
+ d(j) = a(l,j)
+ a(l,j) = a(i,j)
+ a(i,j) = f*scale
+23579 continue
+23580 continue
+ goto 23549
+ endif
+ endif
+ e(i) = 0.0d0
+ e2(i) = 0.0d0
+23549 continue
+23550 continue
+ return
+ end
+ subroutine tred2(nm,n,a,d,e,z)
+ integer i,j,k,l,n,ii,nm,jp1
+ double precision a(nm,n),d(n),e(n),z(nm,n)
+ double precision f,g,h,hh,scale
+ do23581 i = 1,n
+ do23583 j = i,n
+ z(j,i) = a(j,i)
+23583 continue
+23584 continue
+ d(i) = a(n,i)
+23581 continue
+23582 continue
+ if(n.ne.1)then
+ do23587 ii = 2,n
+ i = n+2-ii
+ l = i-1
+ h = 0.0d0
+ scale = 0.0d0
+ if(l.ge.2)then
+ do23591 k = 1,l
+ scale = scale+dabs(d(k))
+23591 continue
+23592 continue
+ if(scale.ne.0.0d0)then
+ do23595 k = 1,l
+ d(k) = d(k)/scale
+ h = h+d(k)*d(k)
+23595 continue
+23596 continue
+ f = d(l)
+ g = -dsign(dsqrt(h),f)
+ e(i) = scale*g
+ h = h-f*g
+ d(l) = f-g
+ do23597 j = 1,l
+ e(j) = 0.0d0
+23597 continue
+23598 continue
+ do23599 j = 1,l
+ f = d(j)
+ z(j,i) = f
+ g = e(j)+z(j,j)*f
+ jp1 = j+1
+ if(l.ge.jp1)then
+ do23603 k = jp1,l
+ g = g+z(k,j)*d(k)
+ e(k) = e(k)+z(k,j)*f
+23603 continue
+23604 continue
+ endif
+ e(j) = g
+23599 continue
+23600 continue
+ f = 0.0d0
+ do23605 j = 1,l
+ e(j) = e(j)/h
+ f = f+e(j)*d(j)
+23605 continue
+23606 continue
+ hh = f/(h+h)
+ do23607 j = 1,l
+ e(j) = e(j)-hh*d(j)
+23607 continue
+23608 continue
+ do23609 j = 1,l
+ f = d(j)
+ g = e(j)
+ do23611 k = j,l
+ z(k,j) = z(k,j)-f*e(k)-g*d(k)
+23611 continue
+23612 continue
+ d(j) = z(l,j)
+ z(i,j) = 0.0d0
+23609 continue
+23610 continue
+ go to 10
+ endif
+ endif
+ e(i) = d(l)
+ do23613 j = 1,l
+ d(j) = z(l,j)
+ z(i,j) = 0.0d0
+ z(j,i) = 0.0d0
+23613 continue
+23614 continue
+10 d(i) = h
+23587 continue
+23588 continue
+ do23615 i = 2,n
+ l = i-1
+ z(n,l) = z(l,l)
+ z(l,l) = 1.0d0
+ h = d(i)
+ if(h.ne.0.0d0)then
+ do23619 k = 1,l
+ d(k) = z(k,i)/h
+23619 continue
+23620 continue
+ do23621 j = 1,l
+ g = 0.0d0
+ do23623 k = 1,l
+ g = g+z(k,i)*z(k,j)
+23623 continue
+23624 continue
+ do23625 k = 1,l
+ z(k,j) = z(k,j)-g*d(k)
+23625 continue
+23626 continue
+23621 continue
+23622 continue
+ endif
+ do23627 k = 1,l
+ z(k,i) = 0.0d0
+23627 continue
+23628 continue
+23615 continue
+23616 continue
+ endif
+ do23629 i = 1,n
+ d(i) = z(n,i)
+ z(n,i) = 0.0d0
+23629 continue
+23630 continue
+ z(n,n) = 1.0d0
+ e(1) = 0.0d0
+ return
+ end
+ subroutine dmatp(x,dx,y,dy,z)
+ integer dx(2),dy(2)
+ double precision x(1), y(1),z(1),ddot
+ integer n,p,q,i,j
+ n=dx(1)
+ p=dx(2)
+ q=dy(2)
+ do23631 i = 1,n
+ jj = 1
+ ij = i
+ do23633 j = 1, q
+ z(ij) = ddot(p,x(i),n,y(jj),1)
+ if(j.lt.q)then
+ jj = jj + p
+ ij = ij + n
+ endif
+23633 continue
+23634 continue
+23631 continue
+23632 continue
+ return
+ end
+ subroutine dmatpt(x,dx,y,dy,z)
+ integer dx(2),dy(2)
+ double precision x(1), y(1),z(1),ddot
+ integer n,p,q,i,j,ii
+ n=dx(1)
+ p=dx(2)
+ q=dy(2)
+ ii=1
+ do23637 i = 1,p
+ jj = 1
+ ij = i
+ do23639 j = 1, q
+ z(ij) = ddot(n,x(ii),1,y(jj),1)
+ if(j.lt.q)then
+ jj = jj + n
+ ij = ij + p
+ endif
+23639 continue
+23640 continue
+ ii = ii +n
+23637 continue
+23638 continue
+ return
+ end
+ subroutine matpm(x,dx,mmx,mx,y,dy,mmy,my,z)
+ integer dx(2),dy(2)
+ integer mmx(1), mmy(1)
+ integer mx(1), my(1)
+ double precision x(1), y(1),z(1),ddot
+ integer n,p,q,i,j
+ n=dx(1)
+ p=dx(2)
+ q=dy(2)
+ call rowmis(mmx,dx(1),dx(2),mx)
+ call colmis(mmy,dy(1),dy(2),my)
+ do23643 i = 1,n
+ jj = 1
+ ij = i
+ do23645 j = 1, q
+ if(.not.(mx(i).ne.0 .or. my(j).ne.0))then
+ z(ij) = ddot(p,x(i),n,y(jj),1)
+ endif
+ if(j.lt.q)then
+ jj = jj + p
+ ij = ij + n
+ endif
+23645 continue
+23646 continue
+23643 continue
+23644 continue
+ return
+ end
+ subroutine matptm(x,dx,mmx,mx,y,dy,mmy,my,z)
+ integer dx(2),dy(2)
+ integer mmx(1), mmy(1)
+ integer mx(1), my(1)
+ double precision x(1), y(1),z(1),ddot
+ integer n,p,q,i,j
+ call colmis(mmx,dx(1),dx(2),mx)
+ call colmis(mmy,dy(1),dy(2),my)
+ n=dx(1)
+ p=dx(2)
+ q=dy(2)
+ ii=1
+ do23651 i = 1,p
+ jj = 1
+ ij = i
+ do23653 j = 1, q
+ if(.not.(mx(i).ne.0 .or. my(j).ne.0))then
+ z(ij) = ddot(n,x(ii),1,y(jj),1)
+ endif
+ if(j.lt.q)then
+ jj = jj + n
+ ij = ij + p
+ endif
+23653 continue
+23654 continue
+ ii = ii +n
+23651 continue
+23652 continue
+ return
+ end
+ subroutine rowmis(m,n,p,vec)
+ integer n,p
+ integer m(n,p)
+ integer vec(1)
+ do23659 i = 1,n
+ vec(i)=0
+ do23661 j = 1,p
+ if(m(i,j).ne.0)then
+ vec(i) = 1
+ endif
+23661 continue
+23662 continue
+23659 continue
+23660 continue
+ return
+ end
+ subroutine colmis(m,n,p,vec)
+ integer n,p
+ integer m(n,p)
+ integer vec(1)
+ do23665 j = 1,p
+ vec(j)=0
+ do23667 i = 1,n
+ if(m(i,j).ne.0)then
+ vec(j) = 1
+ endif
+23667 continue
+23668 continue
+23665 continue
+23666 continue
+ return
+ end
+ subroutine daxpy(n,da,dx,incx,dy,incy)
+ double precision dx(1),dy(1),da
+ integer i,incx,incy,m,mp1,n
+ if(n.gt.0)then
+ if(da.ne.0.0d0)then
+ if(incx.ne.1.or.incy.ne.1)then
+ ix = 1
+ iy = 1
+ if(incx.lt.0)then
+ ix = (-n+1)*incx+1
+ endif
+ if(incy.lt.0)then
+ iy = (-n+1)*incy+1
+ endif
+ do23681 i = 1,n
+ dy(iy) = dy(iy)+da*dx(ix)
+ ix = ix+incx
+ iy = iy+incy
+23681 continue
+23682 continue
+ else
+ m = mod(n,4)
+ if(m.ne.0)then
+ do23685 i = 1,m
+ dy(i) = dy(i)+da*dx(i)
+23685 continue
+23686 continue
+ if(n.lt.4)then
+ return
+ endif
+ endif
+ mp1 = m+1
+ do23689 i = mp1,n,4
+ dy(i) = dy(i)+da*dx(i)
+ dy(i+1) = dy(i+1)+da*dx(i+1)
+ dy(i+2) = dy(i+2)+da*dx(i+2)
+ dy(i+3) = dy(i+3)+da*dx(i+3)
+23689 continue
+23690 continue
+ endif
+ endif
+ endif
+ return
+ end
+ subroutine dcopy(n,dx,incx,dy,incy)
+ double precision dx(1),dy(1)
+ integer i,incx,incy,ix,iy,m,mp1,n
+ if(n.gt.0)then
+ if(incx.ne.1.or.incy.ne.1)then
+ ix = 1
+ iy = 1
+ if(incx.lt.0)then
+ ix = (-n+1)*incx+1
+ endif
+ if(incy.lt.0)then
+ iy = (-n+1)*incy+1
+ endif
+ do23699 i = 1,n
+ dy(iy) = dx(ix)
+ ix = ix+incx
+ iy = iy+incy
+23699 continue
+23700 continue
+ else
+ m = mod(n,7)
+ if(m.ne.0)then
+ do23703 i = 1,m
+ dy(i) = dx(i)
+23703 continue
+23704 continue
+ if(n.lt.7)then
+ return
+ endif
+ endif
+ mp1 = m+1
+ do23707 i = mp1,n,7
+ dy(i) = dx(i)
+ dy(i+1) = dx(i+1)
+ dy(i+2) = dx(i+2)
+ dy(i+3) = dx(i+3)
+ dy(i+4) = dx(i+4)
+ dy(i+5) = dx(i+5)
+ dy(i+6) = dx(i+6)
+23707 continue
+23708 continue
+ endif
+ endif
+ return
+ end
+ double precision function ddot(n,dx,incx,dy,incy)
+ double precision dx(1),dy(1),dtemp
+ integer i,incx,incy,ix,iy,m,mp1,n
+ ddot = 0.0d0
+ dtemp = 0.0d0
+ if(n.gt.0)then
+ if(incx.eq.1.and.incy.eq.1)then
+ m = mod(n,5)
+ if(m.ne.0)then
+ do23715 i = 1,m
+ dtemp = dtemp+dx(i)*dy(i)
+23715 continue
+23716 continue
+ if(n.lt.5)then
+ go to 10
+ endif
+ endif
+ mp1 = m+1
+ do23719 i = mp1,n,5
+ dtemp = dtemp+dx(i)*dy(i)+dx(i+1)*dy(i+1)+dx(i+2)*dy(i+2)+dx(i+3)*
+ *dy(i+3)+dx(i+4)*dy(i+4)
+23719 continue
+23720 continue
+10 ddot = dtemp
+ else
+ ix = 1
+ iy = 1
+ if(incx.lt.0)then
+ ix = (-n+1)*incx+1
+ endif
+ if(incy.lt.0)then
+ iy = (-n+1)*incy+1
+ endif
+ do23725 i = 1,n
+ dtemp = dtemp+dx(ix)*dy(iy)
+ ix = ix+incx
+ iy = iy+incy
+23725 continue
+23726 continue
+ ddot = dtemp
+ endif
+ endif
+ return
+ end
+ double precision function dnrm2(n,dx,incx)
+ integer nst
+ double precision dx(1),cutlo,cuthi,hitest,sum,xmax,zero,one
+ data zero,one/0.0d0,1.0d0/
+ data cutlo,cuthi/8.232d-11,1.304d19/
+ if(n.le.0)then
+ dnrm2 = zero
+ else
+ nst = 20
+ sum = zero
+ nn = n*incx
+ i = 1
+23729 continue
+ if(nst .eq. 20)then
+ goto 20
+ else
+ if(nst .eq. 30)then
+ goto 30
+ else
+ if(nst .eq. 40)then
+ goto 40
+ else
+ if(nst .eq. 80)then
+ goto 80
+ endif
+ endif
+ endif
+ endif
+20 if(dabs(dx(i)).gt.cutlo)then
+ go to 50
+ endif
+ nst = 30
+ xmax = zero
+30 if(dx(i).eq.zero)then
+ go to 100
+ endif
+ if(dabs(dx(i)).gt.cutlo)then
+ go to 50
+ endif
+ nst = 40
+ go to 70
+40 if(dabs(dx(i)).le.cutlo)then
+ go to 80
+ endif
+ sum = (sum*xmax)*xmax
+50 hitest = cuthi/float(n)
+ do23748 j = i,nn,incx
+ if(dabs(dx(j)).ge.hitest)then
+ go to 60
+ endif
+ sum = sum+dx(j)**2
+23748 continue
+23749 continue
+ goto 23731
+60 i = j
+ nst = 80
+ sum = (sum/dx(i))/dx(i)
+70 xmax = dabs(dx(i))
+ go to 90
+80 if(dabs(dx(i)).gt.xmax)then
+ sum = one+sum*(xmax/dx(i))**2
+ xmax = dabs(dx(i))
+ go to 100
+ endif
+90 sum = sum+(dx(i)/xmax)**2
+100 i = i+incx
+ if(i.gt.nn)then
+ go to 110
+ endif
+23730 goto 23729
+23731 continue
+ dnrm2 = dsqrt(sum)
+ return
+110 dnrm2 = xmax*dsqrt(sum)
+ endif
+ return
+ end
+ subroutine dscal(n,da,dx,incx)
+ double precision da,dx(1)
+ integer i,incx,m,mp1,n,nincx
+ if(n.gt.0)then
+ if(incx.ne.1)then
+ nincx = n*incx
+ do23760 i = 1,nincx,incx
+ dx(i) = da*dx(i)
+23760 continue
+23761 continue
+ else
+ m = mod(n,5)
+ if(m.ne.0)then
+ do23764 i = 1,m
+ dx(i) = da*dx(i)
+23764 continue
+23765 continue
+ if(n.lt.5)then
+ return
+ endif
+ endif
+ mp1 = m+1
+ do23768 i = mp1,n,5
+ dx(i) = da*dx(i)
+ dx(i+1) = da*dx(i+1)
+ dx(i+2) = da*dx(i+2)
+ dx(i+3) = da*dx(i+3)
+ dx(i+4) = da*dx(i+4)
+23768 continue
+23769 continue
+ endif
+ endif
+ return
+ end
+ subroutine dswap(n,dx,incx,dy,incy)
+ double precision dx(1),dy(1),dtemp
+ integer i,incx,incy,ix,iy,m,mp1,n
+ if(n.gt.0)then
+ if(incx.ne.1.or.incy.ne.1)then
+ ix = 1
+ iy = 1
+ if(incx.lt.0)then
+ ix = (-n+1)*incx+1
+ endif
+ if(incy.lt.0)then
+ iy = (-n+1)*incy+1
+ endif
+ do23778 i = 1,n
+ dtemp = dx(ix)
+ dx(ix) = dy(iy)
+ dy(iy) = dtemp
+ ix = ix+incx
+ iy = iy+incy
+23778 continue
+23779 continue
+ else
+ m = mod(n,3)
+ if(m.ne.0)then
+ do23782 i = 1,m
+ dtemp = dx(i)
+ dx(i) = dy(i)
+ dy(i) = dtemp
+23782 continue
+23783 continue
+ if(n.lt.3)then
+ return
+ endif
+ endif
+ mp1 = m+1
+ do23786 i = mp1,n,3
+ dtemp = dx(i)
+ dx(i) = dy(i)
+ dy(i) = dtemp
+ dtemp = dx(i+1)
+ dx(i+1) = dy(i+1)
+ dy(i+1) = dtemp
+ dtemp = dx(i+2)
+ dx(i+2) = dy(i+2)
+ dy(i+2) = dtemp
+23786 continue
+23787 continue
+ endif
+ endif
+ return
+ end
+ subroutine dshift(x,ldx,n,j,k)
+ integer ldx,n,j,k
+ double precision x(ldx,k),tt
+ integer i,jj
+ if(k.gt.j)then
+ do23790 i = 1,n
+ tt = x(i,j)
+ do23792 jj = j+1,k
+ x(i,jj-1) = x(i,jj)
+23792 continue
+23793 continue
+ x(i,k) = tt
+23790 continue
+23791 continue
+ endif
+ return
+ end
+ subroutine rtod(dx,dy,n)
+ real dx(1)
+ double precision dy(1)
+ integer i,m,mp1,n
+ if(n.gt.0)then
+ m = mod(n,7)
+ if(m.ne.0)then
+ do23798 i = 1,m
+ dy(i) = dx(i)
+23798 continue
+23799 continue
+ if(n.lt.7)then
+ return
+ endif
+ endif
+ mp1 = m+1
+ do23802 i = mp1,n,7
+ dy(i) = dx(i)
+ dy(i+1) = dx(i+1)
+ dy(i+2) = dx(i+2)
+ dy(i+3) = dx(i+3)
+ dy(i+4) = dx(i+4)
+ dy(i+5) = dx(i+5)
+ dy(i+6) = dx(i+6)
+23802 continue
+23803 continue
+ endif
+ return
+ end
+ subroutine dtor(dx,dy,n)
+ double precision dx(1)
+ real dy(1)
+ integer i,m,mp1,n
+ if(n.gt.0)then
+ m = mod(n,7)
+ if(m.ne.0)then
+ do23808 i = 1,m
+ dy(i) = dx(i)
+23808 continue
+23809 continue
+ if(n.lt.7)then
+ return
+ endif
+ endif
+ mp1 = m+1
+ do23812 i = mp1,n,7
+ dy(i) = dx(i)
+ dy(i+1) = dx(i+1)
+ dy(i+2) = dx(i+2)
+ dy(i+3) = dx(i+3)
+ dy(i+4) = dx(i+4)
+ dy(i+5) = dx(i+5)
+ dy(i+6) = dx(i+6)
+23812 continue
+23813 continue
+ endif
+ return
+ end
+ subroutine drot(n,dx,incx,dy,incy,c,s)
+ double precision dx(1),dy(1),dtemp,c,s
+ integer i,incx,incy,ix,iy,n
+ if(n.gt.0)then
+ if(incx.eq.1.and.incy.eq.1)then
+ do23818 i = 1,n
+ dtemp = c*dx(i)+s*dy(i)
+ dy(i) = c*dy(i)-s*dx(i)
+ dx(i) = dtemp
+23818 continue
+23819 continue
+ else
+ ix = 1
+ iy = 1
+ if(incx.lt.0)then
+ ix = (-n+1)*incx+1
+ endif
+ if(incy.lt.0)then
+ iy = (-n+1)*incy+1
+ endif
+ do23824 i = 1,n
+ dtemp = c*dx(ix)+s*dy(iy)
+ dy(iy) = c*dy(iy)-s*dx(ix)
+ dx(ix) = dtemp
+ ix = ix+incx
+ iy = iy+incy
+23824 continue
+23825 continue
+ endif
+ endif
+ return
+ end
+ subroutine drotg(da,db,c,s)
+ double precision da,db,c,s,roe,scale,r,z
+ roe = db
+ if(dabs(da).gt.dabs(db))then
+ roe = da
+ endif
+ scale = dabs(da)+dabs(db)
+ if(scale.eq.0.0d0)then
+ c = 1.0d0
+ s = 0.0d0
+ r = 0.0d0
+ else
+ r = scale*dsqrt((da/scale)**2+(db/scale)**2)
+ r = dsign(1.0d0,roe)*r
+ c = da/r
+ s = db/r
+ endif
+ z = 1.0d0
+ if(dabs(da).gt.dabs(db))then
+ z = s
+ endif
+ if(dabs(db).ge.dabs(da).and.c.ne.0.0d0)then
+ z = 1.0d0/c
+ endif
+ da = r
+ db = z
+ return
+ end
+ subroutine dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info)
+ integer ldx,n,k,job,info
+ double precision x(ldx,1),qraux(1),y(1),qy(1),qty(1),b(1),rsd(1),x
+ *b(1)
+ integer i,j,jj,ju,kp1
+ double precision ddot,t,temp
+ logical cb,cqy,cqty,cr,cxb
+ info = 0
+ cqy = job/10000.ne.0
+ cqty = mod(job,10000).ne.0
+ cb = mod(job,1000)/100.ne.0
+ cr = mod(job,100)/10.ne.0
+ cxb = mod(job,10).ne.0
+ ju = min0(k,n-1)
+ if(ju.eq.0)then
+ if(cqy)then
+ qy(1) = y(1)
+ endif
+ if(cqty)then
+ qty(1) = y(1)
+ endif
+ if(cxb)then
+ xb(1) = y(1)
+ endif
+ if(cb)then
+ if(x(1,1).ne.0.0d0)then
+ b(1) = y(1)/x(1,1)
+ else
+ info = 1
+ endif
+ endif
+ if(cr)then
+ rsd(1) = 0.0d0
+ endif
+ else
+ if(cqy)then
+ call dcopy(n,y,1,qy,1)
+ endif
+ if(cqty)then
+ call dcopy(n,y,1,qty,1)
+ endif
+ if(cqy)then
+ do23854 jj = 1,ju
+ j = ju-jj+1
+ if(qraux(j).ne.0.0d0)then
+ temp = x(j,j)
+ x(j,j) = qraux(j)
+ t = -ddot(n-j+1,x(j,j),1,qy(j),1)/x(j,j)
+ call daxpy(n-j+1,t,x(j,j),1,qy(j),1)
+ x(j,j) = temp
+ endif
+23854 continue
+23855 continue
+ endif
+ if(cqty)then
+ do23860 j = 1,ju
+ if(qraux(j).ne.0.0d0)then
+ temp = x(j,j)
+ x(j,j) = qraux(j)
+ t = -ddot(n-j+1,x(j,j),1,qty(j),1)/x(j,j)
+ call daxpy(n-j+1,t,x(j,j),1,qty(j),1)
+ x(j,j) = temp
+ endif
+23860 continue
+23861 continue
+ endif
+ if(cb)then
+ call dcopy(k,qty,1,b,1)
+ endif
+ kp1 = k+1
+ if(cxb)then
+ call dcopy(k,qty,1,xb,1)
+ endif
+ if(cr.and.k.lt.n)then
+ call dcopy(n-k,qty(kp1),1,rsd(kp1),1)
+ endif
+ if(cxb.and.kp1.le.n)then
+ do23872 i = kp1,n
+ xb(i) = 0.0d0
+23872 continue
+23873 continue
+ endif
+ if(cr)then
+ do23876 i = 1,k
+ rsd(i) = 0.0d0
+23876 continue
+23877 continue
+ endif
+ if(cb)then
+ do23880 jj = 1,k
+ j = k-jj+1
+ if(x(j,j).eq.0.0d0)then
+ go to 130
+ endif
+ b(j) = b(j)/x(j,j)
+ if(j.ne.1)then
+ t = -b(j)
+ call daxpy(j-1,t,x(1,j),1,b,1)
+ endif
+23880 continue
+23881 continue
+ go to 140
+130 info = j
+ endif
+140 if(cr.or.cxb)then
+ do23888 jj = 1,ju
+ j = ju-jj+1
+ if(qraux(j).ne.0.0d0)then
+ temp = x(j,j)
+ x(j,j) = qraux(j)
+ if(cr)then
+ t = -ddot(n-j+1,x(j,j),1,rsd(j),1)/x(j,j)
+ call daxpy(n-j+1,t,x(j,j),1,rsd(j),1)
+ endif
+ if(cxb)then
+ t = -ddot(n-j+1,x(j,j),1,xb(j),1)/x(j,j)
+ call daxpy(n-j+1,t,x(j,j),1,xb(j),1)
+ endif
+ x(j,j) = temp
+ endif
+23888 continue
+23889 continue
+ endif
+ endif
+ return
+ end
+ subroutine dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info)
+ integer ldx,n,p,ldu,ldv,job,info
+ double precision x(ldx,1),s(1),e(1),u(ldu,1),v(ldv,1),work(1)
+ integer i,iter,j,jobu,k,kase,kk,l,ll,lls,lm1,lp1,ls,lu,m,maxit,mm,
+ *mm1,mp1,nct,nctp1,ncu,nrt,nrtp1
+ double precision ddot,t
+ double precision b,c,cs,el,emm1,f,g,dnrm2,scale,shift,sl,sm,sn,smm
+ *1,t1,test,ztest
+ logical wantu,wantv
+ maxit = 30
+ wantu = .false.
+ wantv = .false.
+ jobu = mod(job,100)/10
+ ncu = n
+ if(jobu.gt.1)then
+ ncu = min0(n,p)
+ endif
+ if(jobu.ne.0)then
+ wantu = .true.
+ endif
+ if(mod(job,10).ne.0)then
+ wantv = .true.
+ endif
+ info = 0
+ nct = min0(n-1,p)
+ nrt = max0(0,min0(p-2,n))
+ lu = max0(nct,nrt)
+ if(lu.ge.1)then
+ do23904 l = 1,lu
+ lp1 = l+1
+ if(l.le.nct)then
+ s(l) = dnrm2(n-l+1,x(l,l),1)
+ if(s(l).ne.0.0d0)then
+ if(x(l,l).ne.0.0d0)then
+ s(l) = dsign(s(l),x(l,l))
+ endif
+ call dscal(n-l+1,1.0d0/s(l),x(l,l),1)
+ x(l,l) = 1.0d0+x(l,l)
+ endif
+ s(l) = -s(l)
+ endif
+ if(p.ge.lp1)then
+ do23914 j = lp1,p
+ if(l.le.nct)then
+ if(s(l).ne.0.0d0)then
+ t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l)
+ call daxpy(n-l+1,t,x(l,l),1,x(l,j),1)
+ endif
+ endif
+ e(j) = x(l,j)
+23914 continue
+23915 continue
+ endif
+ if(wantu.and.l.le.nct)then
+ do23922 i = l,n
+ u(i,l) = x(i,l)
+23922 continue
+23923 continue
+ endif
+ if(l.le.nrt)then
+ e(l) = dnrm2(p-l,e(lp1),1)
+ if(e(l).ne.0.0d0)then
+ if(e(lp1).ne.0.0d0)then
+ e(l) = dsign(e(l),e(lp1))
+ endif
+ call dscal(p-l,1.0d0/e(l),e(lp1),1)
+ e(lp1) = 1.0d0+e(lp1)
+ endif
+ e(l) = -e(l)
+ if(lp1.le.n.and.e(l).ne.0.0d0)then
+ do23932 i = lp1,n
+ work(i) = 0.0d0
+23932 continue
+23933 continue
+ do23934 j = lp1,p
+ call daxpy(n-l,e(j),x(lp1,j),1,work(lp1),1)
+23934 continue
+23935 continue
+ do23936 j = lp1,p
+ call daxpy(n-l,-e(j)/e(lp1),work(lp1),1,x(lp1,j),1)
+23936 continue
+23937 continue
+ endif
+ if(wantv)then
+ do23940 i = lp1,p
+ v(i,l) = e(i)
+23940 continue
+23941 continue
+ endif
+ endif
+23904 continue
+23905 continue
+ endif
+ m = min0(p,n+1)
+ nctp1 = nct+1
+ nrtp1 = nrt+1
+ if(nct.lt.p)then
+ s(nctp1) = x(nctp1,nctp1)
+ endif
+ if(n.lt.m)then
+ s(m) = 0.0d0
+ endif
+ if(nrtp1.lt.m)then
+ e(nrtp1) = x(nrtp1,m)
+ endif
+ e(m) = 0.0d0
+ if(wantu)then
+ if(ncu.ge.nctp1)then
+ do23952 j = nctp1,ncu
+ do23954 i = 1,n
+ u(i,j) = 0.0d0
+23954 continue
+23955 continue
+ u(j,j) = 1.0d0
+23952 continue
+23953 continue
+ endif
+ if(nct.ge.1)then
+ do23958 ll = 1,nct
+ l = nct-ll+1
+ if(s(l).eq.0.0d0)then
+ do23962 i = 1,n
+ u(i,l) = 0.0d0
+23962 continue
+23963 continue
+ u(l,l) = 1.0d0
+ else
+ lp1 = l+1
+ if(ncu.ge.lp1)then
+ do23966 j = lp1,ncu
+ t = -ddot(n-l+1,u(l,l),1,u(l,j),1)/u(l,l)
+ call daxpy(n-l+1,t,u(l,l),1,u(l,j),1)
+23966 continue
+23967 continue
+ endif
+ call dscal(n-l+1,-1.0d0,u(l,l),1)
+ u(l,l) = 1.0d0+u(l,l)
+ lm1 = l-1
+ if(lm1.ge.1)then
+ do23970 i = 1,lm1
+ u(i,l) = 0.0d0
+23970 continue
+23971 continue
+ endif
+ endif
+23958 continue
+23959 continue
+ endif
+ endif
+ if(wantv)then
+ do23974 ll = 1,p
+ l = p-ll+1
+ lp1 = l+1
+ if(l.le.nrt)then
+ if(e(l).ne.0.0d0)then
+ do23980 j = lp1,p
+ t = -ddot(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l)
+ call daxpy(p-l,t,v(lp1,l),1,v(lp1,j),1)
+23980 continue
+23981 continue
+ endif
+ endif
+ do23982 i = 1,p
+ v(i,l) = 0.0d0
+23982 continue
+23983 continue
+ v(l,l) = 1.0d0
+23974 continue
+23975 continue
+ endif
+ mm = m
+ iter = 0
+23984 continue
+ if(m.eq.0)then
+ return
+ endif
+ if(iter.ge.maxit)then
+ goto 23986
+ endif
+ do23991 ll = 1,m
+ l = m-ll
+ if(l.eq.0)then
+ goto 23992
+ endif
+ test = dabs(s(l))+dabs(s(l+1))
+ ztest = test+dabs(e(l))
+ if(ztest.eq.test)then
+ go to 150
+ endif
+23991 continue
+23992 continue
+ go to 160
+150 e(l) = 0.0d0
+160 if(l.eq.m-1)then
+ kase = 4
+ else
+ lp1 = l+1
+ mp1 = m+1
+ do23999 lls = lp1,mp1
+ ls = m-lls+lp1
+ if(ls.eq.l)then
+ goto 24000
+ endif
+ test = 0.0d0
+ if(ls.ne.m)then
+ test = test+dabs(e(ls))
+ endif
+ if(ls.ne.l+1)then
+ test = test+dabs(e(ls-1))
+ endif
+ ztest = test+dabs(s(ls))
+ if(ztest.eq.test)then
+ go to 170
+ endif
+23999 continue
+24000 continue
+ go to 180
+170 s(ls) = 0.0d0
+180 if(ls.eq.l)then
+ kase = 3
+ else
+ if(ls.eq.m)then
+ kase = 1
+ else
+ kase = 2
+ l = ls
+ endif
+ endif
+ endif
+ l = l+1
+ I24013=(kase)
+ goto 24013
+24015 continue
+ mm1 = m-1
+ f = e(m-1)
+ e(m-1) = 0.0d0
+ do24016 kk = l,mm1
+ k = mm1-kk+l
+ t1 = s(k)
+ call drotg(t1,f,cs,sn)
+ s(k) = t1
+ if(k.ne.l)then
+ f = -sn*e(k-1)
+ e(k-1) = cs*e(k-1)
+ endif
+ if(wantv)then
+ call drot(p,v(1,k),1,v(1,m),1,cs,sn)
+ endif
+24016 continue
+24017 continue
+ goto 24014
+24022 continue
+ f = e(l-1)
+ e(l-1) = 0.0d0
+ do24023 k = l,m
+ t1 = s(k)
+ call drotg(t1,f,cs,sn)
+ s(k) = t1
+ f = -sn*e(k)
+ e(k) = cs*e(k)
+ if(wantu)then
+ call drot(n,u(1,k),1,u(1,l-1),1,cs,sn)
+ endif
+24023 continue
+24024 continue
+ goto 24014
+24027 continue
+ scale = dmax1(dabs(s(m)),dabs(s(m-1)),dabs(e(m-1)),dabs(s(l)),dabs
+ *(e(l)))
+ sm = s(m)/scale
+ smm1 = s(m-1)/scale
+ emm1 = e(m-1)/scale
+ sl = s(l)/scale
+ el = e(l)/scale
+ b = ((smm1+sm)*(smm1-sm)+emm1**2)/2.0d0
+ c = (sm*emm1)**2
+ shift = 0.0d0
+ if(b.ne.0.0d0.or.c.ne.0.0d0)then
+ shift = dsqrt(b**2+c)
+ if(b.lt.0.0d0)then
+ shift = -shift
+ endif
+ shift = c/(b+shift)
+ endif
+ f = (sl+sm)*(sl-sm)+shift
+ g = sl*el
+ mm1 = m-1
+ do24032 k = l,mm1
+ call drotg(f,g,cs,sn)
+ if(k.ne.l)then
+ e(k-1) = f
+ endif
+ f = cs*s(k)+sn*e(k)
+ e(k) = cs*e(k)-sn*s(k)
+ g = sn*s(k+1)
+ s(k+1) = cs*s(k+1)
+ if(wantv)then
+ call drot(p,v(1,k),1,v(1,k+1),1,cs,sn)
+ endif
+ call drotg(f,g,cs,sn)
+ s(k) = f
+ f = cs*e(k)+sn*s(k+1)
+ s(k+1) = -sn*e(k)+cs*s(k+1)
+ g = sn*e(k+1)
+ e(k+1) = cs*e(k+1)
+ if(wantu.and.k.lt.n)then
+ call drot(n,u(1,k),1,u(1,k+1),1,cs,sn)
+ endif
+24032 continue
+24033 continue
+ e(m-1) = f
+ iter = iter+1
+ goto 24014
+24040 continue
+ if(s(l).lt.0.0d0)then
+ s(l) = -s(l)
+ if(wantv)then
+ call dscal(p,-1.0d0,v(1,l),1)
+ endif
+ endif
+24045 if(l.ne.mm)then
+ if(s(l).ge.s(l+1))then
+ goto 24046
+ endif
+ t = s(l)
+ s(l) = s(l+1)
+ s(l+1) = t
+ if(wantv.and.l.lt.p)then
+ call dswap(p,v(1,l),1,v(1,l+1),1)
+ endif
+ if(wantu.and.l.lt.n)then
+ call dswap(n,u(1,l),1,u(1,l+1),1)
+ endif
+ l = l+1
+ goto 24045
+ endif
+24046 continue
+ iter = 0
+ m = m-1
+ goto 24014
+24013 continue
+ if (I24013.eq.1)goto 24015
+ if (I24013.eq.2)goto 24022
+ if (I24013.eq.3)goto 24027
+ if (I24013.eq.4)goto 24040
+24014 continue
+23985 goto 23984
+23986 continue
+ info = m
+ return
+ end
+ subroutine dbksl(x,p,k,b,q,info)
+ integer p,k,q,info
+ double precision x(p,p),b(p,q)
+ double precision t
+ integer j,l
+ info = 0
+ j=k
+24053 if(.not.(j.gt.0))goto 24055
+ if(x(j,j).eq.0.0d0)then
+ info = j
+ goto 24055
+ endif
+ l=1
+24058 if(.not.(l.le.q))goto 24060
+ b(j,l) = b(j,l)/x(j,j)
+ if(j.ne.1)then
+ t = -b(j,l)
+ call daxpy(j-1,t,x(1,j),1,b(1,l),1)
+ endif
+24059 l = l+1
+ goto 24058
+24060 continue
+24054 j = j-1
+ goto 24053
+24055 continue
+ return
+ end
+ subroutine dtrsl(t,ldt,n,b,job,info)
+ integer ldt,n,job,info
+ double precision t(ldt,1),b(1)
+ double precision ddot,temp
+ integer which,j,jj
+ do24063 info = 1,n
+ if(t(info,info).eq.0.0d0)then
+ return
+ endif
+24063 continue
+24064 continue
+ info = 0
+ which = 1
+ if(mod(job,10).ne.0)then
+ which = 2
+ endif
+ if(mod(job,100)/10.ne.0)then
+ which = which+2
+ endif
+ I24071=(which)
+ goto 24071
+24073 continue
+ b(1) = b(1)/t(1,1)
+ if(n.ge.2)then
+ do24076 j = 2,n
+ temp = -b(j-1)
+ call daxpy(n-j+1,temp,t(j,j-1),1,b(j),1)
+ b(j) = b(j)/t(j,j)
+24076 continue
+24077 continue
+ endif
+ goto 24072
+24078 continue
+ b(n) = b(n)/t(n,n)
+ if(n.ge.2)then
+ do24081 jj = 2,n
+ j = n-jj+1
+ temp = -b(j+1)
+ call daxpy(j,temp,t(1,j+1),1,b(1),1)
+ b(j) = b(j)/t(j,j)
+24081 continue
+24082 continue
+ endif
+ goto 24072
+24083 continue
+ b(n) = b(n)/t(n,n)
+ if(n.ge.2)then
+ do24086 jj = 2,n
+ j = n-jj+1
+ b(j) = b(j)-ddot(jj-1,t(j+1,j),1,b(j+1),1)
+ b(j) = b(j)/t(j,j)
+24086 continue
+24087 continue
+ endif
+ goto 24072
+24088 continue
+ b(1) = b(1)/t(1,1)
+ if(n.ge.2)then
+ do24091 j = 2,n
+ b(j) = b(j)-ddot(j-1,t(1,j),1,b(1),1)
+ b(j) = b(j)/t(j,j)
+24091 continue
+24092 continue
+ endif
+ goto 24072
+24071 continue
+ if (I24071.eq.1)goto 24073
+ if (I24071.eq.2)goto 24078
+ if (I24071.eq.3)goto 24083
+ if (I24071.eq.4)goto 24088
+24072 continue
+ return
+ end
diff --git a/src/lo.f b/src/lo.f
new file mode 100644
index 0000000..7e124ff
--- /dev/null
+++ b/src/lo.f
@@ -0,0 +1,234 @@
+C Output from Public domain Ratfor, version 1.0
+ subroutine lo0(x,y,w,n,d,p,nvmax,span,degree,match,nef,dof,s,var,
+ *beta,iv,liv,lv,v,iwork,work)
+ integer n,d,p,nvmax,degree,match(1),nef,liv,lv,iv(liv),iwork(1)
+ double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),v(lv),work(
+ *1)
+ double precision beta(p+1)
+ integer qrank
+ call lo1(x,y,w,n,d,p,nvmax,span,degree,match,nef,0,dof,s,var,beta,
+ * work(1),work(nef*d+1),work(nef*(d+1)+2),work(nef*(d+2)+2), work(n
+ *ef*(d+3)+2),qrank,iwork(1),work(nef*(p+d+4)+3+p), iv,liv,lv,v, wor
+ *k(nef*(p+d+4)+4+2*p) )
+ return
+ end
+ subroutine lo1(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,v
+ *ar,beta, xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux, iv,liv,lv,v,
+ * work)
+ integer n,d,p,nvmax,degree,match(1),nef,nit,qrank,qpivot(p+1)
+ integer iv(liv),liv,lv
+ double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),beta(p+1),
+ *xin(nef,d),win(nef+1),sqwin(nef),sqwini(nef),xqr(nef,p+1), qraux(p
+ *+1),v(lv), work(1)
+ call lo2(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,var,bet
+ *a, xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux, iv,liv,lv,v, work(
+ *1),work(nef+2),work(2*nef+3),work(3*nef+4))
+ return
+ end
+ subroutine lo2(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,v
+ *ar,beta, xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux, iv,liv,lv,v,
+ * levout,sout,yin,work)
+ integer n,d,p,nvmax,degree,match(1),nef,nit,qrank,qpivot(p+1)
+ integer iv(liv),liv,lv
+ double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),beta(p+1),
+ *xin(nef,d),win(nef+1),sqwin(nef),sqwini(nef),xqr(nef,p+1), qraux(p
+ *+1),v(lv), levout(nef+1), sout(nef+1),yin(nef+1),work(1)
+ double precision junk, onedm7
+ integer job, info
+ logical setlf, ifvar
+ job=110
+ info=1
+ ifvar=.true.
+ onedm7=1d-7
+ if(nit.le.1)then
+ call pck(n,nef,match,w,win)
+ do23002 i=1,nef
+ if(win(i).gt.0d0)then
+ sqwin(i)=dsqrt(win(i))
+ sqwini(i)=1d0/sqwin(i)
+ else
+ sqwin(i)=1d-5
+ sqwini(i)=1d5
+ endif
+23002 continue
+23003 continue
+ do23006 i=1,n
+ k=match(i)
+ if(k.le.nef)then
+ do23010 j=1,d
+ xin(k,j)=x(i,j)
+23010 continue
+23011 continue
+ j=d+1
+23012 if(.not.(j.le.p))goto 23014
+ xqr(k,j+1)=x(i,j)
+23013 j=j+1
+ goto 23012
+23014 continue
+ endif
+23006 continue
+23007 continue
+ do23015 i=1,nef
+ xqr(i,1)=sqwin(i)
+ do23017 j=1,d
+ xqr(i,j+1)=xin(i,j)*sqwin(i)
+23017 continue
+23018 continue
+ j=d+2
+23019 if(.not.(j.le.p+1))goto 23021
+ xqr(i,j)=xqr(i,j)*sqwin(i)
+23020 j=j+1
+ goto 23019
+23021 continue
+23015 continue
+23016 continue
+ j=1
+23022 if(.not.(j.le.p+1))goto 23024
+ qpivot(j)=j
+23023 j=j+1
+ goto 23022
+23024 continue
+ call dqrdca(xqr,nef,nef,p+1,qraux,qpivot,work,qrank,onedm7)
+ setlf = (nit.eq.1)
+ call lowesd(106,iv,liv,lv,v,d,nef,span,degree,nvmax,setlf)
+ v(2)=span/5d0
+ endif
+ do23025 i=1,n
+ work(i)=y(i)*w(i)
+23025 continue
+23026 continue
+ call pck(n,nef,match,work,yin)
+ do23027 i=1,nef
+ yin(i)=yin(i)*sqwini(i)*sqwini(i)
+23027 continue
+23028 continue
+ if(nit.le.1)then
+ call lowesb(xin,yin,win,levout,ifvar,iv,liv,lv,v)
+ else
+ call lowesr(yin,iv,liv,lv,v)
+ endif
+ call lowese(iv,liv,lv,v,nef,xin,sout)
+ do23031 i=1,nef
+ sout(i)=sout(i)*sqwin(i)
+23031 continue
+23032 continue
+ call dqrsl(xqr,nef,nef,qrank,qraux,sout,work(1),work(1),beta, sout
+ *,work(1),job,info)
+ do23033 i=1,nef
+ sout(i)=sout(i)*sqwini(i)
+23033 continue
+23034 continue
+ if(nit.le.1)then
+ job=10000
+ j=1
+23037 if(.not.(j.le.p+1))goto 23039
+ do23040 i=1,nef
+ work(i)=0d0
+23040 continue
+23041 continue
+ work(j)=1d0
+ call dqrsl(xqr,nef,nef,qrank,qraux,work,var,junk,junk, junk,junk,j
+ *ob,info)
+ do23042 i=1,nef
+ levout(i)=levout(i) - var(i)**2
+23042 continue
+23043 continue
+23038 j=j+1
+ goto 23037
+23039 continue
+ dof=0d0
+ do23044 i=1,nef
+ if(win(i).gt.0d0)then
+ levout(i)=levout(i)/win(i)
+ else
+ levout(i)=0d0
+ endif
+23044 continue
+23045 continue
+ do23048 i=1,nef
+ dof=dof+levout(i)*win(i)
+23048 continue
+23049 continue
+ call unpck(n,nef,match,levout,var)
+ j=1
+23050 if(.not.(j.le.p+1))goto 23052
+ work(j)=beta(j)
+23051 j=j+1
+ goto 23050
+23052 continue
+ j=1
+23053 if(.not.(j.le.p+1))goto 23055
+ beta(qpivot(j))=work(j)
+23054 j=j+1
+ goto 23053
+23055 continue
+ endif
+ call unpck(n,nef,match,sout,s)
+ return
+ end
+ subroutine pck(n,p,match,x,xbar)
+ integer match(n),p,n
+ double precision x(n),xbar(n)
+ do23056 i=1,p
+ xbar(i)=0d0
+23056 continue
+23057 continue
+ do23058 i=1,n
+ xbar(match(i))=xbar(match(i))+x(i)
+23058 continue
+23059 continue
+ return
+ end
+ subroutine suff(n,p,match,x,y,w,xbar,ybar,wbar,work)
+ integer match(n),p,n
+ double precision x(n),xbar(n),y(n),ybar(n),w(n),wbar(n),work(n)
+ call pck(n,p,match,w,wbar)
+ do23060 i=1,n
+ xbar(match(i))=x(i)
+23060 continue
+23061 continue
+ do23062 i=1,n
+ work(i)=y(i)*w(i)
+23062 continue
+23063 continue
+ call pck(n,p,match,work,ybar)
+ do23064 i=1,p
+ if(wbar(i).gt.0d0)then
+ ybar(i)=ybar(i)/wbar(i)
+ else
+ ybar(i)=0d0
+ endif
+23064 continue
+23065 continue
+ return
+ end
+ subroutine unpck(n,p,match,xbar,x)
+ integer match(n),p,n
+ double precision x(n),xbar(p+1)
+ if(p.lt.n)then
+ xbar(p+1)=0d0
+ endif
+ do23070 i = 1,n
+ x(i)=xbar(match(i))
+23070 continue
+23071 continue
+ return
+ end
+ double precision function dwrss(n,y,eta,w)
+ integer n
+ double precision y(n),w(n),wtot,wsum,work,eta(n)
+ wsum=0d0
+ wtot=0d0
+ do23072 i = 1,n
+ work=y(i)-eta(i)
+ wsum=wsum+w(i)*work*work
+ wtot=wtot+w(i)
+23072 continue
+23073 continue
+ if(wtot .gt. 0d0)then
+ dwrss=wsum/wtot
+ else
+ dwrss=0d0
+ endif
+ return
+ end
diff --git a/src/loessc.c b/src/loessc.c
new file mode 100644
index 0000000..b956c95
--- /dev/null
+++ b/src/loessc.c
@@ -0,0 +1,796 @@
+/*
+
+ * The authors of this software are Cleveland, Grosse, and Shyu.
+
+ * Copyright (c) 1989, 1992 by AT&T.
+
+ * Permission to use, copy, modify, and distribute this software for any
+
+ * purpose without fee is hereby granted, provided that this entire notice
+
+ * is included in all copies of any software which is or includes a copy
+
+ * or modification of this software and in all copies of the supporting
+
+ * documentation for such software.
+
+ * THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED
+
+ * WARRANTY. IN PARTICULAR, NEITHER THE AUTHORS NOR AT&T MAKE ANY
+
+ * REPRESENTATION OR WARRANTY OF ANY KIND CONCERNING THE MERCHANTABILITY
+
+ * OF THIS SOFTWARE OR ITS FITNESS FOR ANY PARTICULAR PURPOSE.
+
+ */
+
+
+
+/*
+
+ * Altered by B.D. Ripley to use F77_*, declare routines before use.
+
+ *
+
+ * 'protoize'd to ANSI C headers; indented: M.Maechler
+
+ */
+
+
+
+#include <string.h>
+
+#include <R.h>
+
+
+
+/* Forward declarations */
+
+static
+
+void loess_workspace(Sint *d, Sint *n, double *span, Sint *degree,
+
+ Sint *nonparametric, Sint *drop_square,
+
+ Sint *sum_drop_sqr, Sint *setLf);
+
+static
+
+void loess_prune(Sint *parameter, Sint *a,
+
+ double *xi, double *vert, double *vval);
+
+static
+
+void loess_grow (Sint *parameter, Sint *a,
+
+ double *xi, double *vert, double *vval);
+
+
+
+/* These (and many more) are in ./loessf.f : */
+
+void F77_NAME(lowesa)();
+
+void F77_NAME(lowesb)();
+
+void F77_NAME(lowesc)();
+
+void F77_NAME(lowesd)();
+
+void F77_NAME(lowese)();
+
+void F77_NAME(lowesf)();
+
+void F77_NAME(lowesl)();
+
+void F77_NAME(ehg169)();
+
+void F77_NAME(ehg196)();
+
+/* exported (for loessf.f) : */
+
+void F77_SUB(ehg182)(int *i);
+
+void F77_SUB(ehg183a)(char *s, int *nc,int *i,int *n,int *inc);
+
+void F77_SUB(ehg184a)(char *s, int *nc, double *x, int *n, int *inc);
+
+
+
+
+
+
+
+#undef min
+
+#undef max
+
+
+
+#define min(x,y) ((x) < (y) ? (x) : (y))
+
+#define max(x,y) ((x) > (y) ? (x) : (y))
+
+#define GAUSSIAN 1
+
+#define SYMMETRIC 0
+
+
+
+static Sint *iv, liv, lv, tau;
+
+static double *v;
+
+
+
+/* these are set in an earlier call to loess_workspace or loess_grow */
+
+static void loess_free(void)
+
+{
+
+ Free(v);
+
+ Free(iv);
+
+}
+
+
+
+void
+
+loess_raw(double *y, double *x, double *weights, double *robust, Sint *d,
+
+ Sint *n, double *span, Sint *degree, Sint *nonparametric,
+
+ Sint *drop_square, Sint *sum_drop_sqr, double *cell,
+
+ char **surf_stat, double *surface, Sint *parameter,
+
+ Sint *a, double *xi, double *vert, double *vval, double *diagonal,
+
+ double *trL, double *one_delta, double *two_delta, Sint *setLf)
+
+{
+
+ Sint zero = 0, one = 1, two = 2, nsing, i, k;
+
+ double *hat_matrix, *LL;
+
+
+
+ *trL = 0;
+
+
+
+ loess_workspace(d, n, span, degree, nonparametric, drop_square,
+
+ sum_drop_sqr, setLf);
+
+ v[1] = *cell;/* = v(2) in Fortran (!) */
+
+ if(!strcmp(*surf_stat, "interpolate/none")) {
+
+ F77_CALL(lowesb)(x, y, robust, &zero, &zero, iv, &liv, &lv, v);
+
+ F77_CALL(lowese)(iv, &liv, &lv, v, n, x, surface);
+
+ loess_prune(parameter, a, xi, vert, vval);
+
+ }
+
+ else if (!strcmp(*surf_stat, "direct/none")) {
+
+ F77_CALL(lowesf)(x, y, robust, iv, &liv, &lv, v, n, x,
+
+ &zero, &zero, surface);
+
+ }
+
+ else if (!strcmp(*surf_stat, "interpolate/1.approx")) {
+
+ F77_CALL(lowesb)(x, y, weights, diagonal, &one, iv, &liv, &lv, v);
+
+ F77_CALL(lowese)(iv, &liv, &lv, v, n, x, surface);
+
+ nsing = iv[29];
+
+ for(i = 0; i < (*n); i++) *trL = *trL + diagonal[i];
+
+ F77_CALL(lowesa)(trL, n, d, &tau, &nsing, one_delta, two_delta);
+
+ loess_prune(parameter, a, xi, vert, vval);
+
+ }
+
+ else if (!strcmp(*surf_stat, "interpolate/2.approx")) {
+
+ F77_CALL(lowesb)(x, y, robust, &zero, &zero, iv, &liv, &lv, v);
+
+ F77_CALL(lowese)(iv, &liv, &lv, v, n, x, surface);
+
+ nsing = iv[29];
+
+ F77_CALL(ehg196)(&tau, d, span, trL);
+
+ F77_CALL(lowesa)(trL, n, d, &tau, &nsing, one_delta, two_delta);
+
+ loess_prune(parameter, a, xi, vert, vval);
+
+ }
+
+ else if (!strcmp(*surf_stat, "direct/approximate")) {
+
+ F77_CALL(lowesf)(x, y, weights, iv, &liv, &lv, v, n, x,
+
+ diagonal, &one, surface);
+
+ nsing = iv[29];
+
+ for(i = 0; i < (*n); i++) *trL = *trL + diagonal[i];
+
+ F77_CALL(lowesa)(trL, n, d, &tau, &nsing, one_delta, two_delta);
+
+ }
+
+ else if (!strcmp(*surf_stat, "interpolate/exact")) {
+
+ hat_matrix = (double *) R_alloc((*n)*(*n), sizeof(double));
+
+ LL = (double *) R_alloc((*n)*(*n), sizeof(double));
+
+ F77_CALL(lowesb)(x, y, weights, diagonal, &one, iv, &liv, &lv, v);
+
+ F77_CALL(lowesl)(iv, &liv, &lv, v, n, x, hat_matrix);
+
+ F77_CALL(lowesc)(n, hat_matrix, LL, trL, one_delta, two_delta);
+
+ F77_CALL(lowese)(iv, &liv, &lv, v, n, x, surface);
+
+ loess_prune(parameter, a, xi, vert, vval);
+
+ }
+
+ else if (!strcmp(*surf_stat, "direct/exact")) {
+
+ hat_matrix = (double *) R_alloc((*n)*(*n), sizeof(double));
+
+ LL = (double *) R_alloc((*n)*(*n), sizeof(double));
+
+ F77_CALL(lowesf)(x, y, weights, iv, liv, lv, v, n, x,
+
+ hat_matrix, &two, surface);
+
+ F77_CALL(lowesc)(n, hat_matrix, LL, trL, one_delta, two_delta);
+
+ k = (*n) + 1;
+
+ for(i = 0; i < (*n); i++)
+
+ diagonal[i] = hat_matrix[i * k];
+
+ }
+
+ loess_free();
+
+}
+
+
+
+void
+
+loess_dfit(double *y, double *x, double *x_evaluate, double *weights,
+
+ double *span, Sint *degree, Sint *nonparametric,
+
+ Sint *drop_square, Sint *sum_drop_sqr,
+
+ Sint *d, Sint *n, Sint *m, double *fit)
+
+{
+
+ Sint zero = 0;
+
+
+
+ loess_workspace(d, n, span, degree, nonparametric, drop_square,
+
+ sum_drop_sqr, &zero);
+
+ F77_CALL(lowesf)(x, y, weights, iv, &liv, &lv, v, m, x_evaluate,
+
+ &zero, &zero, fit);
+
+ loess_free();
+
+}
+
+
+
+void
+
+loess_dfitse(double *y, double *x, double *x_evaluate, double *weights,
+
+ double *robust, Sint *family, double *span, Sint *degree,
+
+ Sint *nonparametric, Sint *drop_square,
+
+ Sint *sum_drop_sqr,
+
+ Sint *d, Sint *n, Sint *m, double *fit, double *L)
+
+{
+
+ Sint zero = 0, two = 2;
+
+
+
+ loess_workspace(d, n, span, degree, nonparametric, drop_square,
+
+ sum_drop_sqr, &zero);
+
+ if(*family == GAUSSIAN)
+
+ F77_CALL(lowesf)(x, y, weights, iv, &liv, &lv, v, m,
+
+ x_evaluate, L, &two, fit);
+
+ else if(*family == SYMMETRIC)
+
+ {
+
+ F77_CALL(lowesf)(x, y, weights, iv, &liv, &lv, v, m,
+
+ x_evaluate, L, &two, fit);
+
+ F77_CALL(lowesf)(x, y, robust, iv, &liv, &lv, v, m,
+
+ x_evaluate, &zero, &zero, fit);
+
+ }
+
+ loess_free();
+
+}
+
+
+
+void
+
+loess_ifit(Sint *parameter, Sint *a, double *xi, double *vert,
+
+ double *vval, Sint *m, double *x_evaluate, double *fit)
+
+{
+
+ loess_grow(parameter, a, xi, vert, vval);
+
+ F77_CALL(lowese)(iv, &liv, &lv, v, m, x_evaluate, fit);
+
+ loess_free();
+
+}
+
+
+
+void
+
+loess_ise(double *y, double *x, double *x_evaluate, double *weights,
+
+ double *span, Sint *degree, Sint *nonparametric,
+
+ Sint *drop_square, Sint *sum_drop_sqr, double *cell,
+
+ Sint *d, Sint *n, Sint *m, double *fit, double *L)
+
+{
+
+ Sint zero = 0, one = 1;
+
+
+
+ loess_workspace(d, n, span, degree, nonparametric, drop_square,
+
+ sum_drop_sqr, &one);
+
+ v[1] = *cell;
+
+ F77_CALL(lowesb)(x, y, weights, &zero, &zero, iv, &liv, &lv, v);
+
+ F77_CALL(lowesl)(iv, &liv, &lv, v, m, x_evaluate, L);
+
+ loess_free();
+
+}
+
+
+
+void
+
+loess_workspace(Sint *d, Sint *n, double *span, Sint *degree,
+
+ Sint *nonparametric, Sint *drop_square,
+
+ Sint *sum_drop_sqr, Sint *setLf)
+
+{
+
+ Sint D, N, tau0, nvmax, nf, version = 106, i;
+
+
+
+ D = *d;
+
+ N = *n;
+
+ nvmax = max(200, N);
+
+ nf = min(N, floor(N * (*span) + 1e-5));
+
+ if(nf <= 0) error("span is too small");
+
+ tau0 = ((*degree) > 1) ? ((D + 2) * (D + 1) * 0.5) : (D + 1);
+
+ tau = tau0 - (*sum_drop_sqr);
+
+ lv = 50 + (3 * D + 3) * nvmax + N + (tau0 + 2) * nf;
+
+ liv = 50 + ((Sint)pow((double)2, (double)D) + 4) * nvmax + 2 * N;
+
+ if(*setLf) {
+
+ lv = lv + (D + 1) * nf * nvmax;
+
+ liv = liv + nf * nvmax;
+
+ }
+
+ iv = Calloc(liv, Sint);
+
+ v = Calloc(lv, double);
+
+
+
+ F77_CALL(lowesd)(&version, iv, &liv, &lv, v, d, n, span, degree,
+
+ &nvmax, setLf);
+
+ iv[32] = *nonparametric;
+
+ for(i = 0; i < D; i++)
+
+ iv[i + 40] = drop_square[i];
+
+}
+
+
+
+static void
+
+loess_prune(Sint *parameter, Sint *a, double *xi, double *vert,
+
+ double *vval)
+
+{
+
+ Sint d, vc, a1, v1, xi1, vv1, nc, nv, nvmax, i, k;
+
+
+
+ d = iv[1];
+
+ vc = iv[3] - 1;
+
+ nc = iv[4];
+
+ nv = iv[5];
+
+ a1 = iv[6] - 1;
+
+ v1 = iv[10] - 1;
+
+ xi1 = iv[11] - 1;
+
+ vv1 = iv[12] - 1;
+
+ nvmax = iv[13];
+
+
+
+ for(i = 0; i < 5; i++)
+
+ parameter[i] = iv[i + 1];
+
+ parameter[5] = iv[21] - 1;
+
+ parameter[6] = iv[14] - 1;
+
+
+
+ for(i = 0; i < d; i++){
+
+ k = nvmax * i;
+
+ vert[i] = v[v1 + k];
+
+ vert[i + d] = v[v1 + vc + k];
+
+ }
+
+ for(i = 0; i < nc; i++) {
+
+ xi[i] = v[xi1 + i];
+
+ a[i] = iv[a1 + i];
+
+ }
+
+ k = (d + 1) * nv;
+
+ for(i = 0; i < k; i++)
+
+ vval[i] = v[vv1 + i];
+
+}
+
+
+
+static void
+
+loess_grow(Sint *parameter, Sint *a, double *xi,
+
+ double *vert, double *vval)
+
+{
+
+ Sint d, vc, nc, nv, a1, v1, xi1, vv1, i, k;
+
+
+
+ d = parameter[0];
+
+ vc = parameter[2];
+
+ nc = parameter[3];
+
+ nv = parameter[4];
+
+ liv = parameter[5];
+
+ lv = parameter[6];
+
+ iv = Calloc(liv, Sint);
+
+ v = Calloc(lv, double);
+
+
+
+ iv[1] = d;
+
+ iv[2] = parameter[1];
+
+ iv[3] = vc;
+
+ iv[5] = iv[13] = nv;
+
+ iv[4] = iv[16] = nc;
+
+ iv[6] = 50;
+
+ iv[7] = iv[6] + nc;
+
+ iv[8] = iv[7] + vc * nc;
+
+ iv[9] = iv[8] + nc;
+
+ iv[10] = 50;
+
+ iv[12] = iv[10] + nv * d;
+
+ iv[11] = iv[12] + (d + 1) * nv;
+
+ iv[27] = 173;
+
+
+
+ v1 = iv[10] - 1;
+
+ xi1 = iv[11] - 1;
+
+ a1 = iv[6] - 1;
+
+ vv1 = iv[12] - 1;
+
+
+
+ for(i = 0; i < d; i++) {
+
+ k = nv * i;
+
+ v[v1 + k] = vert[i];
+
+ v[v1 + vc - 1 + k] = vert[i + d];
+
+ }
+
+ for(i = 0; i < nc; i++) {
+
+ v[xi1 + i] = xi[i];
+
+ iv[a1 + i] = a[i];
+
+ }
+
+ k = (d + 1) * nv;
+
+ for(i = 0; i < k; i++)
+
+ v[vv1 + i] = vval[i];
+
+
+
+ F77_CALL(ehg169)(&d, &vc, &nc, &nc, &nv, &nv, v+v1, iv+a1,
+
+ v+xi1, iv+iv[7]-1, iv+iv[8]-1, iv+iv[9]-1);
+
+}
+
+
+
+
+
+/* begin ehg's FORTRAN-callable C-codes */
+
+
+
+void F77_SUB(ehg182)(int *i)
+
+{
+
+ char *msg, msg2[50];
+
+#define MSG(_m_) msg = _m_ ; break ;
+
+
+
+switch(*i){
+
+ case 100:MSG("wrong version number in lowesd. Probably typo in caller.")
+
+ case 101:MSG("d>dMAX in ehg131. Need to recompile with increased dimensions.")
+
+ case 102:MSG("liv too small. (Discovered by lowesd)")
+
+ case 103:MSG("lv too small. (Discovered by lowesd)")
+
+ case 104:MSG("span too small. fewer data values than degrees of freedom.")
+
+ case 105:MSG("k>d2MAX in ehg136. Need to recompile with increased dimensions.")
+
+ case 106:MSG("lwork too small")
+
+ case 107:MSG("invalid value for kernel")
+
+ case 108:MSG("invalid value for ideg")
+
+ case 109:MSG("lowstt only applies when kernel=1.")
+
+ case 110:MSG("not enough extra workspace for robustness calculation")
+
+ case 120:MSG("zero-width neighborhood. make span bigger")
+
+ case 121:MSG("all data on boundary of neighborhood. make span bigger")
+
+ case 122:MSG("extrapolation not allowed with blending")
+
+ case 123:MSG("ihat=1 (diag L) in l2fit only makes sense if z=x (eval=data).")
+
+ case 171:MSG("lowesd must be called first.")
+
+ case 172:MSG("lowesf must not come between lowesb and lowese, lowesr, or lowesl.")
+
+ case 173:MSG("lowesb must come before lowese, lowesr, or lowesl.")
+
+ case 174:MSG("lowesb need not be called twice.")
+
+ case 175:MSG("need setLf=.true. for lowesl.")
+
+ case 180:MSG("nv>nvmax in cpvert.")
+
+ case 181:MSG("nt>20 in eval.")
+
+ case 182:MSG("svddc failed in l2fit.")
+
+ case 183:MSG("didnt find edge in vleaf.")
+
+ case 184:MSG("zero-width cell found in vleaf.")
+
+ case 185:MSG("trouble descending to leaf in vleaf.")
+
+ case 186:MSG("insufficient workspace for lowesf.")
+
+ case 187:MSG("insufficient stack space")
+
+ case 188:MSG("lv too small for computing explicit L")
+
+ case 191:MSG("computed trace L was negative; something is wrong!")
+
+ case 192:MSG("computed delta was negative; something is wrong!")
+
+ case 193:MSG("workspace in loread appears to be corrupted")
+
+ case 194:MSG("trouble in l2fit/l2tr")
+
+ case 195:MSG("only constant, linear, or quadratic local models allowed")
+
+ case 196:MSG("degree must be at least 1 for vertex influence matrix")
+
+ case 999:MSG("not yet implemented")
+
+ default: sprintf(msg=msg2,"Assert failed; error code %d\n",*i);
+
+}
+
+warning(msg);
+
+}
+
+#undef MSG
+
+
+
+void F77_SUB(ehg183a)(char *s, int *nc,int *i,int *n,int *inc)
+
+{
+
+ char mess[4000], num[20];
+
+ int j;
+
+ strncpy(mess,s,*nc);
+
+ mess[*nc] = '\0';
+
+ for (j=0; j<*n; j++) {
+
+ sprintf(num," %d",i[j * *inc]);
+
+ strcat(mess,num);
+
+ }
+
+ strcat(mess,"\n");
+
+ warning(mess);
+
+}
+
+
+
+void F77_SUB(ehg184a)(char *s, int *nc, double *x, int *n, int *inc)
+
+{
+
+ char mess[4000], num[30];
+
+ int j;
+
+ strncpy(mess,s,*nc);
+
+ mess[*nc] = '\0';
+
+ for (j=0; j<*n; j++) {
+
+ sprintf(num," %.5g",x[j * *inc]);
+
+ strcat(mess,num);
+
+ }
+
+ strcat(mess,"\n");
+
+ warning(mess);
+
+}
+
diff --git a/src/loessf.f b/src/loessf.f
new file mode 100644
index 0000000..d360366
--- /dev/null
+++ b/src/loessf.f
@@ -0,0 +1,2078 @@
+C
+C The authors of this software are Cleveland, Grosse, and Shyu.
+C Copyright (c) 1989, 1992 by AT&T.
+C Permission to use, copy, modify, and distribute this software for any
+C purpose without fee is hereby granted, provided that this entire notice
+C is included in all copies of any software which is or includes a copy
+C or modification of this software and in all copies of the supporting
+C documentation for such software.
+C THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED
+C WARRANTY. IN PARTICULAR, NEITHER THE AUTHORS NOR AT&T MAKE ANY
+C REPRESENTATION OR WARRANTY OF ANY KIND CONCERNING THE MERCHANTABILITY
+C OF THIS SOFTWARE OR ITS FITNESS FOR ANY PARTICULAR PURPOSE.
+
+C altered by B.D. Ripley to
+C
+C remove unused variables
+C make phi in ehg139 double precision to match calling sequence
+C
+C Note that ehg182(errormsg_code) is in ./loessc.c
+
+ subroutine ehg126(d,n,vc,x,v,nvmax)
+ integer d,execnt,i,j,k,n,nvmax,vc
+ DOUBLE PRECISION machin,alpha,beta,mu,t
+ DOUBLE PRECISION v(nvmax,d),x(n,d)
+
+ DOUBLE PRECISION D1MACH
+ external D1MACH
+ save machin,execnt
+ data execnt /0/
+c MachInf -> machin
+ execnt=execnt+1
+ if(execnt.eq.1)then
+c initialize d1mach(2) === DBL_MAX:
+ machin=D1MACH(2)
+ end if
+c fill in vertices for bounding box of $x$
+c lower left, upper right
+ do 3 k=1,d
+ alpha=machin
+ beta=-machin
+ do 4 i=1,n
+ t=x(i,k)
+ alpha=min(alpha,t)
+ beta=max(beta,t)
+ 4 continue
+c expand the box a little
+ mu=0.005D0*max(beta-alpha,1.d-10*max(DABS(alpha),DABS(beta))+
+ + 1.d-30)
+ alpha=alpha-mu
+ beta=beta+mu
+ v(1,k)=alpha
+ v(vc,k)=beta
+ 3 continue
+c remaining vertices
+ do 5 i=2,vc-1
+ j=i-1
+ do 6 k=1,d
+ v(i,k)=v(1+mod(j,2)*(vc-1),k)
+ j=DBLE(j)/2.D0
+ 6 continue
+ 5 continue
+ return
+ end
+
+ subroutine ehg125(p,nv,v,vhit,nvmax,d,k,t,r,s,f,l,u)
+ logical i1,i2,match
+ integer d,execnt,h,i,i3,j,k,m,mm,nv,nvmax,p,r,s
+ integer f(r,0:1,s),l(r,0:1,s),u(r,0:1,s),vhit(nvmax)
+ DOUBLE PRECISION t
+ DOUBLE PRECISION v(nvmax,d)
+ external ehg182
+ save execnt
+ data execnt /0/
+ execnt=execnt+1
+ h=nv
+ do 3 i=1,r
+ do 4 j=1,s
+ h=h+1
+ do 5 i3=1,d
+ v(h,i3)=v(f(i,0,j),i3)
+ 5 continue
+ v(h,k)=t
+c check for redundant vertex
+ match=.false.
+ m=1
+c top of while loop
+ 6 if(.not.match)then
+ i1=(m.le.nv)
+ else
+ i1=.false.
+ end if
+ if(.not.(i1))goto 7
+ match=(v(m,1).eq.v(h,1))
+ mm=2
+c top of while loop
+ 8 if(match)then
+ i2=(mm.le.d)
+ else
+ i2=.false.
+ end if
+ if(.not.(i2))goto 9
+ match=(v(m,mm).eq.v(h,mm))
+ mm=mm+1
+ goto 8
+c bottom of while loop
+ 9 m=m+1
+ goto 6
+c bottom of while loop
+ 7 m=m-1
+ if(match)then
+ h=h-1
+ else
+ m=h
+ if(vhit(1).ge.0)then
+ vhit(m)=p
+ end if
+ end if
+ l(i,0,j)=f(i,0,j)
+ l(i,1,j)=m
+ u(i,0,j)=m
+ u(i,1,j)=f(i,1,j)
+ 4 continue
+ 3 continue
+ nv=h
+ if(.not.(nv.le.nvmax))then
+ call ehg182(180)
+ end if
+ return
+ end
+
+ integer function ehg138(i,z,a,xi,lo,hi,ncmax)
+ logical i1
+ integer execnt,i,j,ncmax
+ integer a(ncmax),hi(ncmax),lo(ncmax)
+ DOUBLE PRECISION xi(ncmax),z(8)
+ save execnt
+ data execnt /0/
+ execnt=execnt+1
+c descend tree until leaf or ambiguous
+ j=i
+c top of while loop
+ 3 if(a(j).ne.0)then
+ i1=(z(a(j)).ne.xi(j))
+ else
+ i1=.false.
+ end if
+ if(.not.(i1))goto 4
+ if(z(a(j)).lt.xi(j))then
+ j=lo(j)
+ else
+ j=hi(j)
+ end if
+ goto 3
+c bottom of while loop
+ 4 ehg138=j
+ return
+ end
+
+ subroutine ehg106(il,ir,k,nk,p,pi,n)
+
+c Partial sorting of p(1, il:ir) returning the sort indices pi() only
+c such that p(1, pi(k)) is correct
+
+c implicit none
+c Arguments
+c Input:
+ integer il,ir,k,nk,n
+ DOUBLE PRECISION p(nk,n)
+c using only p(1, pi(*))
+c Output:
+ integer pi(n)
+
+c Variables
+ DOUBLE PRECISION t
+ integer i,ii,j,l,r
+
+c find the $k$-th smallest of $n$ elements
+c Floyd+Rivest, CACM Mar '75, Algorithm 489
+ l=il
+ r=ir
+c while (l < r )
+ 3 if(.not.(l.lt.r))goto 4
+c to avoid recursion, sophisticated partition deleted
+c partition $x sub {l..r}$ about $t$
+ t=p(1,pi(k))
+ i=l
+ j=r
+ ii=pi(l)
+ pi(l)=pi(k)
+ pi(k)=ii
+ if(t.lt.p(1,pi(r)))then
+ ii=pi(l)
+ pi(l)=pi(r)
+ pi(r)=ii
+ end if
+c top of while loop
+ 5 if(.not.(i.lt.j))goto 6
+ ii=pi(i)
+ pi(i)=pi(j)
+ pi(j)=ii
+ i=i+1
+ j=j-1
+c top of while loop
+ 7 if(.not.(p(1,pi(i)).lt.t))goto 8
+ i=i+1
+ goto 7
+c bottom of while loop
+ 8 continue
+c top of while loop
+ 9 if(.not.(t.lt.p(1,pi(j))))goto 10
+ j=j-1
+ goto 9
+c bottom of while loop
+ 10 goto 5
+c bottom of while loop
+ 6 if(p(1,pi(l)).eq.t)then
+ ii=pi(l)
+ pi(l)=pi(j)
+ pi(j)=ii
+ else
+ j=j+1
+ ii=pi(r)
+ pi(r)=pi(j)
+ pi(j)=ii
+ end if
+ if(j.le.k)then
+ l=j+1
+ end if
+ if(k.le.j)then
+ r=j-1
+ end if
+ goto 3
+c bottom of while loop
+ 4 return
+ end
+
+
+ subroutine ehg127(q,n,d,nf,f,x,psi,y,rw,kernel,k,dist,eta,b,od,w,
+ + rcond,sing,sigma,u,e,dgamma,qraux,work,tol,dd,tdeg,cdeg,s)
+ integer column,d,dd,execnt,i,i3,i9,info,inorm2,j,jj,jpvt,k,kernel,
+ + n,nf,od,sing,tdeg
+ integer cdeg(8),psi(n)
+ double precision machep,f,i1,i10,i2,i4,i5,i6,i7,i8,rcond,rho,scal,
+ + tol
+ double precision g(15),sigma(15),u(15,15),e(15,15),b(nf,k),
+ + colnor(15),dist(n),eta(nf),dgamma(15),q(d),qraux(15),rw(n),
+ + s(0:od),w(nf),work(15),x(n,d),y(n)
+
+ integer idamax
+ double precision d1mach, ddot
+
+ external ehg106,ehg182,ehg184,dqrdc,dqrsl,dsvdc
+ external idamax, d1mach, ddot
+
+ save machep,execnt
+ data execnt /0/
+c colnorm -> colnor
+c E -> g
+c MachEps -> machep
+c V -> e
+c X -> b
+ execnt=execnt+1
+ if(execnt.eq.1)then
+c initialize d1mach(4) === 1 / DBL_EPSILON === 2^52 :
+ machep=d1mach(4)
+ end if
+c sort by distance
+ do 3 i3=1,n
+ dist(i3)=0
+ 3 continue
+ do 4 j=1,dd
+ i4=q(j)
+ do 5 i3=1,n
+ dist(i3)=dist(i3)+(x(i3,j)-i4)**2
+ 5 continue
+ 4 continue
+ call ehg106(1,n,nf,1,dist,psi,n)
+ rho=dist(psi(nf))*max(1.d0,f)
+ if(rho .le. 0)then
+ call ehg182(120)
+ end if
+c compute neighborhood weights
+ if(kernel.eq.2)then
+ do 6 i=1,nf
+ if(dist(psi(i)).lt.rho)then
+ i1=dsqrt(rw(psi(i)))
+ else
+ i1=0
+ end if
+ w(i)=i1
+ 6 continue
+ else
+ do 7 i3=1,nf
+ w(i3)=dsqrt(dist(psi(i3))/rho)
+ 7 continue
+ do 8 i3=1,nf
+ w(i3)=dsqrt(rw(psi(i3))*(1-w(i3)**3)**3)
+ 8 continue
+ end if
+ if(dabs(w(idamax(nf,w,1))).eq.0)then
+ call ehg184('at ',q(1),dd,1)
+ call ehg184('radius ',rho,1,1)
+ if(.not..false.)then
+ call ehg182(121)
+ end if
+ end if
+c fill design matrix
+ column=1
+ do 9 i3=1,nf
+ b(i3,column)=w(i3)
+ 9 continue
+ if(tdeg.ge.1)then
+ do 10 j=1,d
+ if(cdeg(j).ge.1)then
+ column=column+1
+ i5=q(j)
+ do 11 i3=1,nf
+ b(i3,column)=w(i3)*(x(psi(i3),j)-i5)
+ 11 continue
+ end if
+ 10 continue
+ end if
+ if(tdeg.ge.2)then
+ do 12 j=1,d
+ if(cdeg(j).ge.1)then
+ if(cdeg(j).ge.2)then
+ column=column+1
+ i6=q(j)
+ do 13 i3=1,nf
+ b(i3,column)=w(i3)*(x(psi(i3),j)-i6)**2
+ 13 continue
+ end if
+ do 14 jj=j+1,d
+ if(cdeg(jj).ge.1)then
+ column=column+1
+ i7=q(j)
+ i8=q(jj)
+ do 15 i3=1,nf
+ b(i3,column)=w(i3)*(x(psi(i3),j)-i7)*(x(psi(i3),
+ +jj)-i8)
+ 15 continue
+ end if
+ 14 continue
+ end if
+ 12 continue
+ k=column
+ end if
+ do 16 i3=1,nf
+ eta(i3)=w(i3)*y(psi(i3))
+ 16 continue
+c equilibrate columns
+ do 17 j=1,k
+ scal=0
+ do 18 inorm2=1,nf
+ scal=scal+b(inorm2,j)**2
+ 18 continue
+ scal=dsqrt(scal)
+ if(0.lt.scal)then
+ do 19 i3=1,nf
+ b(i3,j)=b(i3,j)/scal
+ 19 continue
+ colnor(j)=scal
+ else
+ colnor(j)=1
+ end if
+ 17 continue
+c singular value decomposition
+ call dqrdc(b,nf,nf,k,qraux,jpvt,work,0)
+ call dqrsl(b,nf,nf,k,qraux,eta,work,eta,eta,work,work,1000,info)
+ do 20 i9=1,k
+ do 21 i3=1,k
+ u(i3,i9)=0
+ 21 continue
+ 20 continue
+ do 22 i=1,k
+ do 23 j=i,k
+ u(i,j)=b(i,j)
+ 23 continue
+ 22 continue
+ call dsvdc(u,15,k,k,sigma,g,u,15,e,15,work,21,info)
+ if(.not.(info.eq.0))then
+ call ehg182(182)
+ end if
+ tol=sigma(1)*(100*machep)
+ rcond=min(rcond,sigma(k)/sigma(1))
+ if(sigma(k).le.tol)then
+ sing=sing+1
+ if(sing.eq.1)then
+ call ehg184('pseudoinverse used at',q(1),d,1)
+ call ehg184('neighborhood radius',dsqrt(rho),1,1)
+ call ehg184('reciprocal condition number ',rcond,1,1)
+ else
+ if(sing.eq.2)then
+ call ehg184('There are other near singularities as well.'
+ +,rho,1,1)
+ end if
+ end if
+ end if
+c compensate for equilibration
+ do 24 j=1,k
+ i10=colnor(j)
+ do 25 i3=1,k
+ e(j,i3)=e(j,i3)/i10
+ 25 continue
+ 24 continue
+c solve least squares problem
+ do 26 j=1,k
+ if(tol.lt.sigma(j))then
+ i2=ddot(k,u(1,j),1,eta,1)/sigma(j)
+ else
+ i2=0.d0
+ end if
+ dgamma(j)=i2
+ 26 continue
+ do 27 j=0,od
+ s(j)=ddot(k,e(j+1,1),15,dgamma,1)
+ 27 continue
+ return
+ end
+
+ subroutine ehg131(x,y,rw,trl,diagl,kernel,k,n,d,nc,ncmax,vc,nv,
+ + nvmax,nf,f,a,c,hi,lo,pi,psi,v,vhit,vval,xi,dist,eta,b,ntol,
+ + fd,w,vval2,rcond,sing,dd,tdeg,cdeg,lq,lf,setlf)
+ logical setlf
+ integer identi,d,dd,execnt,i1,i2,j,k,kernel,n,nc,ncmax,nf,ntol,nv,
+ + nvmax,sing,tdeg,vc
+ integer lq(nvmax,nf),a(ncmax),c(vc,ncmax),cdeg(8),hi(ncmax),
+ + lo(ncmax),pi(n),psi(n),vhit(nvmax)
+ double precision f,fd,rcond,trl
+ double precision lf(0:d,nvmax,nf),b(*),delta(8),diagl(n),dist(n),
+ + eta(nf),rw(n),v(nvmax,d),vval(0:d,nvmax),vval2(0:d,nvmax),
+ + w(nf),x(n,d),xi(ncmax),y(n)
+ external ehg126,ehg182,ehg139,ehg124
+ double precision dnrm2
+ external dnrm2
+ save execnt
+ data execnt /0/
+c Identity -> identi
+c X -> b
+ execnt=execnt+1
+ if(.not.(d.le.8))then
+ call ehg182(101)
+ end if
+c build $k$-d tree
+ call ehg126(d,n,vc,x,v,nvmax)
+ nv=vc
+ nc=1
+ do 3 j=1,vc
+ c(j,nc)=j
+ vhit(j)=0
+ 3 continue
+ do 4 i1=1,d
+ delta(i1)=v(vc,i1)-v(1,i1)
+ 4 continue
+ fd=fd*dnrm2(d,delta,1)
+ do 5 identi=1,n
+ pi(identi)=identi
+ 5 continue
+ call ehg124(1,n,d,n,nv,nc,ncmax,vc,x,pi,a,xi,lo,hi,c,v,vhit,nvmax,
+ +ntol,fd,dd)
+c smooth
+ if(trl.ne.0)then
+ do 6 i2=1,nv
+ do 7 i1=0,d
+ vval2(i1,i2)=0
+ 7 continue
+ 6 continue
+ end if
+ call ehg139(v,nvmax,nv,n,d,nf,f,x,pi,psi,y,rw,trl,kernel,k,dist,
+ + dist,eta,b,d,w,diagl,vval2,nc,vc,a,xi,lo,hi,c,vhit,rcond,
+ + sing,dd,tdeg,cdeg,lq,lf,setlf,vval)
+ return
+ end
+
+ subroutine ehg133(n,d,vc,nvmax,nc,ncmax,a,c,hi,lo,v,vval,xi,m,z,s)
+ integer n,d,vc,nvmax,nc,ncmax, m
+ integer a(ncmax),c(vc,ncmax),hi(ncmax),lo(ncmax)
+ double precision v(nvmax,d),vval(0:d,nvmax),xi(ncmax),z(m,d),s(m)
+c Var
+ double precision delta(8)
+ integer i,i1
+
+ double precision ehg128
+ external ehg128
+
+ do 3 i=1,m
+ do 4 i1=1,d
+ delta(i1)=z(i,i1)
+ 4 continue
+ s(i)=ehg128(delta,d,ncmax,vc,a,xi,lo,hi,c,v,nvmax,vval)
+ 3 continue
+ return
+ end
+
+ subroutine ehg140(iw,i,j)
+ integer execnt,i,j
+ integer iw(i)
+ save execnt
+ data execnt /0/
+ execnt=execnt+1
+ iw(i)=j
+ return
+ end
+
+ subroutine ehg141(trl,n,deg,k,d,nsing,dk,delta1,delta2)
+ double precision trl,delta1,delta2
+ integer n,deg,k,d,nsing,dk
+
+ double precision c(48), c1, c2, c3, c4, corx,z
+ integer i
+
+ external ehg176
+ double precision ehg176
+ double precision ourz(1)
+c coef, d, deg, del
+ data c / .2971620d0,.3802660d0,.5886043d0,.4263766d0,.3346498d0,
+ +.6271053d0,.5241198d0,.3484836d0,.6687687d0,.6338795d0,.4076457d0,
+ +.7207693d0,.1611761d0,.3091323d0,.4401023d0,.2939609d0,.3580278d0,
+ +.5555741d0,.3972390d0,.4171278d0,.6293196d0,.4675173d0,.4699070d0,
+ +.6674802d0,.2848308d0,.2254512d0,.2914126d0,.5393624d0,.2517230d0,
+ +.3898970d0,.7603231d0,.2969113d0,.4740130d0,.9664956d0,.3629838d0,
+ +.5348889d0,.2075670d0,.2822574d0,.2369957d0,.3911566d0,.2981154d0,
+ +.3623232d0,.5508869d0,.3501989d0,.4371032d0,.7002667d0,.4291632d0,
+ +.4930370d0 /
+
+ if(deg.eq.0) dk=1
+ if(deg.eq.1) dk=d+1
+ if(deg.eq.2) dk=dble((d+2)*(d+1))/2.d0
+ corx=dsqrt(k/dble(n))
+ z=(dsqrt(k/trl)-corx)/(1-corx)
+ if(nsing .eq. 0 .and. 1 .lt. z) call ehg184('Chernobyl! trL<k',t
+ +rl,1,1)
+ if(z .lt. 0) call ehg184('Chernobyl! trL>n',trl,1,1)
+ z=min(1.0d0,max(0.0d0,z))
+ ourz(1) = z
+ c4=dexp(ehg176(ourz))
+ i=1+3*(min(d,4)-1+4*(deg-1))
+ if(d.le.4)then
+ c1=c(i)
+ c2=c(i+1)
+ c3=c(i+2)
+ else
+ c1=c(i)+(d-4)*(c(i)-c(i-3))
+ c2=c(i+1)+(d-4)*(c(i+1)-c(i-2))
+ c3=c(i+2)+(d-4)*(c(i+2)-c(i-1))
+ endif
+ delta1=n-trl*dexp(c1*z**c2*(1-z)**c3*c4)
+ i=i+24
+ if(d.le.4)then
+ c1=c(i)
+ c2=c(i+1)
+ c3=c(i+2)
+ else
+ c1=c(i)+(d-4)*(c(i)-c(i-3))
+ c2=c(i+1)+(d-4)*(c(i+1)-c(i-2))
+ c3=c(i+2)+(d-4)*(c(i+2)-c(i-1))
+ endif
+ delta2=n-trl*dexp(c1*z**c2*(1-z)**c3*c4)
+ return
+ end
+
+ subroutine lowesc(n,l,ll,trl,delta1,delta2)
+ integer execnt,i,j,n
+ double precision delta1,delta2,trl
+ double precision l(n,n),ll(n,n)
+ double precision ddot
+ external ddot
+ save execnt
+ data execnt /0/
+ execnt=execnt+1
+c compute $LL~=~(I-L)(I-L)'$
+ do 3 i=1,n
+ l(i,i)=l(i,i)-1
+ 3 continue
+ do 4 i=1,n
+ do 5 j=1,i
+ ll(i,j)=ddot(n,l(i,1),n,l(j,1),n)
+ 5 continue
+ 4 continue
+ do 6 i=1,n
+ do 7 j=i+1,n
+ ll(i,j)=ll(j,i)
+ 7 continue
+ 6 continue
+ do 8 i=1,n
+ l(i,i)=l(i,i)+1
+ 8 continue
+c accumulate first two traces
+ trl=0
+ delta1=0
+ do 9 i=1,n
+ trl=trl+l(i,i)
+ delta1=delta1+ll(i,i)
+ 9 continue
+c $delta sub 2 = "tr" LL sup 2$
+ delta2=0
+ do 10 i=1,n
+ delta2=delta2+ddot(n,ll(i,1),n,ll(1,i),1)
+ 10 continue
+ return
+ end
+
+ subroutine ehg169(d,vc,nc,ncmax,nv,nvmax,v,a,xi,c,hi,lo)
+ integer d,vc,nc,ncmax,nv,nvmax
+ integer a(ncmax), c(vc,ncmax), hi(ncmax), lo(ncmax)
+ DOUBLE PRECISION v(nvmax,d),xi(ncmax)
+
+ integer novhit(1),i,j,k,mc,mv,p
+ external ehg125,ehg182
+ integer ifloor
+ external ifloor
+
+c as in bbox
+c remaining vertices
+ do 3 i=2,vc-1
+ j=i-1
+ do 4 k=1,d
+ v(i,k)=v(1+mod(j,2)*(vc-1),k)
+ j=ifloor(DBLE(j)/2.D0)
+ 4 continue
+ 3 continue
+c as in ehg131
+ mc=1
+ mv=vc
+ novhit(1)=-1
+ do 5 j=1,vc
+ c(j,mc)=j
+ 5 continue
+c as in rbuild
+ p=1
+c top of while loop
+ 6 if(.not.(p.le.nc))goto 7
+ if(a(p).ne.0)then
+ k=a(p)
+c left son
+ mc=mc+1
+ lo(p)=mc
+c right son
+ mc=mc+1
+ hi(p)=mc
+ call ehg125(p,mv,v,novhit,nvmax,d,k,xi(p),2**(k-1),2**(d-k),
+ + c(1,p),c(1,lo(p)),c(1,hi(p)))
+ end if
+ p=p+1
+ goto 6
+c bottom of while loop
+ 7 if(.not.(mc.eq.nc))then
+ call ehg182(193)
+ end if
+ if(.not.(mv.eq.nv))then
+ call ehg182(193)
+ end if
+ return
+ end
+
+ DOUBLE PRECISION function ehg176(z)
+c
+ DOUBLE PRECISION z(*)
+c
+ integer d,vc,nv,nc
+ integer a(17), c(2,17)
+ integer hi(17), lo(17)
+ DOUBLE PRECISION v(10,1)
+ DOUBLE PRECISION vval(0:1,10)
+ DOUBLE PRECISION xi(17)
+ double precision ehg128
+ external ehg128
+
+ data d,vc,nv,nc /1,2,10,17/
+ data a(1) /1/
+ data hi(1),lo(1),xi(1) /3,2,0.3705D0/
+ data c(1,1) /1/
+ data c(2,1) /2/
+ data a(2) /1/
+ data hi(2),lo(2),xi(2) /5,4,0.2017D0/
+ data c(1,2) /1/
+ data c(2,2) /3/
+ data a(3) /1/
+ data hi(3),lo(3),xi(3) /7,6,0.5591D0/
+ data c(1,3) /3/
+ data c(2,3) /2/
+ data a(4) /1/
+ data hi(4),lo(4),xi(4) /9,8,0.1204D0/
+ data c(1,4) /1/
+ data c(2,4) /4/
+ data a(5) /1/
+ data hi(5),lo(5),xi(5) /11,10,0.2815D0/
+ data c(1,5) /4/
+ data c(2,5) /3/
+ data a(6) /1/
+ data hi(6),lo(6),xi(6) /13,12,0.4536D0/
+ data c(1,6) /3/
+ data c(2,6) /5/
+ data a(7) /1/
+ data hi(7),lo(7),xi(7) /15,14,0.7132D0/
+ data c(1,7) /5/
+ data c(2,7) /2/
+ data a(8) /0/
+ data c(1,8) /1/
+ data c(2,8) /6/
+ data a(9) /0/
+ data c(1,9) /6/
+ data c(2,9) /4/
+ data a(10) /0/
+ data c(1,10) /4/
+ data c(2,10) /7/
+ data a(11) /0/
+ data c(1,11) /7/
+ data c(2,11) /3/
+ data a(12) /0/
+ data c(1,12) /3/
+ data c(2,12) /8/
+ data a(13) /0/
+ data c(1,13) /8/
+ data c(2,13) /5/
+ data a(14) /0/
+ data c(1,14) /5/
+ data c(2,14) /9/
+ data a(15) /1/
+ data hi(15),lo(15),xi(15) /17,16,0.8751D0/
+ data c(1,15) /9/
+ data c(2,15) /2/
+ data a(16) /0/
+ data c(1,16) /9/
+ data c(2,16) /10/
+ data a(17) /0/
+ data c(1,17) /10/
+ data c(2,17) /2/
+ data vval(0,1) /-9.0572D-2/
+ data v(1,1) /-5.D-3/
+ data vval(1,1) /4.4844D0/
+ data vval(0,2) /-1.0856D-2/
+ data v(2,1) /1.005D0/
+ data vval(1,2) /-0.7736D0/
+ data vval(0,3) /-5.3718D-2/
+ data v(3,1) /0.3705D0/
+ data vval(1,3) /-0.3495D0/
+ data vval(0,4) /2.6152D-2/
+ data v(4,1) /0.2017D0/
+ data vval(1,4) /-0.7286D0/
+ data vval(0,5) /-5.8387D-2/
+ data v(5,1) /0.5591D0/
+ data vval(1,5) /0.1611D0/
+ data vval(0,6) /9.5807D-2/
+ data v(6,1) /0.1204D0/
+ data vval(1,6) /-0.7978D0/
+ data vval(0,7) /-3.1926D-2/
+ data v(7,1) /0.2815D0/
+ data vval(1,7) /-0.4457D0/
+ data vval(0,8) /-6.4170D-2/
+ data v(8,1) /0.4536D0/
+ data vval(1,8) /3.2813D-2/
+ data vval(0,9) /-2.0636D-2/
+ data v(9,1) /0.7132D0/
+ data vval(1,9) /0.3350D0/
+ data vval(0,10) /4.0172D-2/
+ data v(10,1) /0.8751D0/
+ data vval(1,10) /-4.1032D-2/
+ ehg176=ehg128(z,d,nc,vc,a,xi,lo,hi,c,v,nv,vval)
+ end
+
+ subroutine lowesa(trl,n,d,tau,nsing,delta1,delta2)
+ integer n,d,tau,nsing
+ double precision trl, delta1,delta2
+
+ integer dka,dkb
+ double precision alpha,d1a,d1b,d2a,d2b
+ external ehg141
+
+ call ehg141(trl,n,1,tau,d,nsing,dka,d1a,d2a)
+ call ehg141(trl,n,2,tau,d,nsing,dkb,d1b,d2b)
+ alpha=dble(tau-dka)/dble(dkb-dka)
+ delta1=(1-alpha)*d1a+alpha*d1b
+ delta2=(1-alpha)*d2a+alpha*d2b
+ return
+ end
+
+ subroutine ehg191(m,z,l,d,n,nf,nv,ncmax,vc,a,xi,lo,hi,c,v,nvmax,
+ + vval2,lf,lq)
+c Args
+ integer m,d,n,nf,nv,ncmax,nvmax,vc
+ double precision z(m,d), l(m,n), xi(ncmax), v(nvmax,d),
+ + vval2(0:d,nvmax), lf(0:d,nvmax,nf)
+ integer lq(nvmax,nf),a(ncmax),c(vc,ncmax),lo(ncmax),hi(ncmax)
+c Var
+ integer lq1,execnt,i,i1,i2,j,p
+ double precision zi(8)
+ double precision ehg128
+ external ehg128
+
+ save execnt
+ data execnt /0/
+ execnt=execnt+1
+ do 3 j=1,n
+ do 4 i2=1,nv
+ do 5 i1=0,d
+ vval2(i1,i2)=0
+ 5 continue
+ 4 continue
+ do 6 i=1,nv
+c linear search for i in Lq
+ lq1=lq(i,1)
+ lq(i,1)=j
+ p=nf
+c top of while loop
+ 7 if(.not.(lq(i,p).ne.j))goto 8
+ p=p-1
+ goto 7
+c bottom of while loop
+ 8 lq(i,1)=lq1
+ if(lq(i,p).eq.j)then
+ do 9 i1=0,d
+ vval2(i1,i)=lf(i1,i,p)
+ 9 continue
+ end if
+ 6 continue
+ do 10 i=1,m
+ do 11 i1=1,d
+ zi(i1)=z(i,i1)
+ 11 continue
+ l(i,j)=ehg128(zi,d,ncmax,vc,a,xi,lo,hi,c,v,nvmax,vval2)
+ 10 continue
+ 3 continue
+ return
+ end
+
+ subroutine ehg196(tau,d,f,trl)
+ integer d,dka,dkb,execnt,tau
+ double precision alpha,f,trl,trla,trlb
+ external ehg197
+ save execnt
+ data execnt /0/
+ execnt=execnt+1
+ call ehg197(1,tau,d,f,dka,trla)
+ call ehg197(2,tau,d,f,dkb,trlb)
+ alpha=dble(tau-dka)/dble(dkb-dka)
+ trl=(1-alpha)*trla+alpha*trlb
+ return
+ end
+
+ subroutine ehg197(deg,tau,d,f,dk,trl)
+ integer deg,tau,d,dk
+ double precision f, trl
+
+ double precision g1
+ dk = 0
+ if(deg.eq.1) dk=d+1
+ if(deg.eq.2) dk=dble((d+2)*(d+1))/2.d0
+ g1 = (-0.08125d0*d+0.13d0)*d+1.05d0
+ trl = dk*(1+max(0.d0,(g1-f)/f))
+ return
+ end
+
+ subroutine ehg192(y,d,n,nf,nv,nvmax,vval,lf,lq)
+ integer d,i,i1,i2,j,n,nf,nv,nvmax
+ integer lq(nvmax,nf)
+ DOUBLE PRECISION i3
+ DOUBLE PRECISION lf(0:d,nvmax,nf),vval(0:d,nvmax),y(n)
+
+ do 3 i2=1,nv
+ do 4 i1=0,d
+ vval(i1,i2)=0
+ 4 continue
+ 3 continue
+ do 5 i=1,nv
+ do 6 j=1,nf
+ i3=y(lq(i,j))
+ do 7 i1=0,d
+ vval(i1,i)=vval(i1,i)+i3*lf(i1,i,j)
+ 7 continue
+ 6 continue
+ 5 continue
+ return
+ end
+
+ DOUBLE PRECISION function ehg128(z,d,ncmax,vc,a,xi,lo,hi,c,v,
+ + nvmax,vval)
+
+c implicit none
+c Args
+ integer d,ncmax,nvmax,vc
+ integer a(ncmax),c(vc,ncmax),hi(ncmax),lo(ncmax)
+ DOUBLE PRECISION z(d),xi(ncmax),v(nvmax,d), vval(0:d,nvmax)
+c Vars
+ logical i2,i3,i4,i5,i6,i7,i8,i9,i10
+ integer execnt,i,i1,i11,i12,ig,ii,j,lg,ll,m,nt,ur
+ integer t(20)
+ DOUBLE PRECISION ge,gn,gs,gw,gpe,gpn,gps,gpw,h,phi0,phi1,
+ + psi0,psi1,s,sew,sns,v0,v1,xibar
+ DOUBLE PRECISION g(0:8,256),g0(0:8),g1(0:8)
+
+ external ehg182,ehg184
+ save execnt
+ data execnt /0/
+ execnt=execnt+1
+c locate enclosing cell
+ nt=1
+ t(nt)=1
+ j=1
+c top of while loop
+ 3 if(.not.(a(j).ne.0))goto 4
+ nt=nt+1
+ if(z(a(j)).lt.xi(j))then
+ i1=lo(j)
+ else
+ i1=hi(j)
+ end if
+ t(nt)=i1
+ if(.not.(nt.lt.20))then
+ call ehg182(181)
+ end if
+ j=t(nt)
+ goto 3
+c bottom of while loop
+ 4 continue
+c tensor
+ do 5 i12=1,vc
+ do 6 i11=0,d
+ g(i11,i12)=vval(i11,c(i12,j))
+ 6 continue
+ 5 continue
+ lg=vc
+ ll=c(1,j)
+ ur=c(vc,j)
+ do 7 i=d,1,-1
+ h=(z(i)-v(ll,i))/(v(ur,i)-v(ll,i))
+ if(h.lt.-.001D0)then
+ call ehg184('eval ',z(1),d,1)
+ call ehg184('lowerlimit ',v(ll,1),d,nvmax)
+ else
+ if(1.001D0.lt.h)then
+ call ehg184('eval ',z(1),d,1)
+ call ehg184('upperlimit ',v(ur,1),d,nvmax)
+ end if
+ end if
+ if(-.001D0.le.h)then
+ i2=(h.le.1.001D0)
+ else
+ i2=.false.
+ end if
+ if(.not.i2)then
+ call ehg182(122)
+ end if
+ lg=DBLE(lg)/2.D0
+ do 8 ig=1,lg
+c Hermite basis
+ phi0=(1-h)**2*(1+2*h)
+ phi1=h**2*(3-2*h)
+ psi0=h*(1-h)**2
+ psi1=h**2*(h-1)
+ g(0,ig)=phi0*g(0,ig) + phi1*g(0,ig+lg) +
+ + (psi0*g(i,ig)+psi1*g(i,ig+lg)) * (v(ur,i)-v(ll,i))
+ do 9 ii=1,i-1
+ g(ii,ig)=phi0*g(ii,ig)+phi1*g(ii,ig+lg)
+ 9 continue
+ 8 continue
+ 7 continue
+ s=g(0,1)
+c blending
+ if(d.eq.2)then
+c ----- North -----
+ v0=v(ll,1)
+ v1=v(ur,1)
+ do 10 i11=0,d
+ g0(i11)=vval(i11,c(3,j))
+ 10 continue
+ do 11 i11=0,d
+ g1(i11)=vval(i11,c(4,j))
+ 11 continue
+ xibar=v(ur,2)
+ m=nt-1
+c top of while loop
+ 12 if(m.eq.0)then
+ i4=.true.
+ else
+ if(a(t(m)).eq.2)then
+ i3=(xi(t(m)).eq.xibar)
+ else
+ i3=.false.
+ end if
+ i4=i3
+ end if
+ if(.not.(.not.i4))goto 13
+ m=m-1
+c voidp junk
+ goto 12
+c bottom of while loop
+ 13 if(m.ge.1)then
+ m=hi(t(m))
+c top of while loop
+ 14 if(.not.(a(m).ne.0))goto 15
+ if(z(a(m)).lt.xi(m))then
+ m=lo(m)
+ else
+ m=hi(m)
+ end if
+ goto 14
+c bottom of while loop
+ 15 if(v0.lt.v(c(1,m),1))then
+ v0=v(c(1,m),1)
+ do 16 i11=0,d
+ g0(i11)=vval(i11,c(1,m))
+ 16 continue
+ end if
+ if(v(c(2,m),1).lt.v1)then
+ v1=v(c(2,m),1)
+ do 17 i11=0,d
+ g1(i11)=vval(i11,c(2,m))
+ 17 continue
+ end if
+ end if
+ h=(z(1)-v0)/(v1-v0)
+c Hermite basis
+ phi0=(1-h)**2*(1+2*h)
+ phi1=h**2*(3-2*h)
+ psi0=h*(1-h)**2
+ psi1=h**2*(h-1)
+ gn=phi0*g0(0)+phi1*g1(0)+(psi0*g0(1)+psi1*g1(1))*(v1-v0)
+ gpn=phi0*g0(2)+phi1*g1(2)
+c ----- South -----
+ v0=v(ll,1)
+ v1=v(ur,1)
+ do 18 i11=0,d
+ g0(i11)=vval(i11,c(1,j))
+ 18 continue
+ do 19 i11=0,d
+ g1(i11)=vval(i11,c(2,j))
+ 19 continue
+ xibar=v(ll,2)
+ m=nt-1
+c top of while loop
+ 20 if(m.eq.0)then
+ i6=.true.
+ else
+ if(a(t(m)).eq.2)then
+ i5=(xi(t(m)).eq.xibar)
+ else
+ i5=.false.
+ end if
+ i6=i5
+ end if
+ if(.not.(.not.i6))goto 21
+ m=m-1
+c voidp junk
+ goto 20
+c bottom of while loop
+ 21 if(m.ge.1)then
+ m=lo(t(m))
+c top of while loop
+ 22 if(.not.(a(m).ne.0))goto 23
+ if(z(a(m)).lt.xi(m))then
+ m=lo(m)
+ else
+ m=hi(m)
+ end if
+ goto 22
+c bottom of while loop
+ 23 if(v0.lt.v(c(3,m),1))then
+ v0=v(c(3,m),1)
+ do 24 i11=0,d
+ g0(i11)=vval(i11,c(3,m))
+ 24 continue
+ end if
+ if(v(c(4,m),1).lt.v1)then
+ v1=v(c(4,m),1)
+ do 25 i11=0,d
+ g1(i11)=vval(i11,c(4,m))
+ 25 continue
+ end if
+ end if
+ h=(z(1)-v0)/(v1-v0)
+c Hermite basis
+ phi0=(1-h)**2*(1+2*h)
+ phi1=h**2*(3-2*h)
+ psi0=h*(1-h)**2
+ psi1=h**2*(h-1)
+ gs=phi0*g0(0)+phi1*g1(0)+(psi0*g0(1)+psi1*g1(1))*(v1-v0)
+ gps=phi0*g0(2)+phi1*g1(2)
+c ----- East -----
+ v0=v(ll,2)
+ v1=v(ur,2)
+ do 26 i11=0,d
+ g0(i11)=vval(i11,c(2,j))
+ 26 continue
+ do 27 i11=0,d
+ g1(i11)=vval(i11,c(4,j))
+ 27 continue
+ xibar=v(ur,1)
+ m=nt-1
+c top of while loop
+ 28 if(m.eq.0)then
+ i8=.true.
+ else
+ if(a(t(m)).eq.1)then
+ i7=(xi(t(m)).eq.xibar)
+ else
+ i7=.false.
+ end if
+ i8=i7
+ end if
+ if(.not.(.not.i8))goto 29
+ m=m-1
+c voidp junk
+ goto 28
+c bottom of while loop
+ 29 if(m.ge.1)then
+ m=hi(t(m))
+c top of while loop
+ 30 if(.not.(a(m).ne.0))goto 31
+ if(z(a(m)).lt.xi(m))then
+ m=lo(m)
+ else
+ m=hi(m)
+ end if
+ goto 30
+c bottom of while loop
+ 31 if(v0.lt.v(c(1,m),2))then
+ v0=v(c(1,m),2)
+ do 32 i11=0,d
+ g0(i11)=vval(i11,c(1,m))
+ 32 continue
+ end if
+ if(v(c(3,m),2).lt.v1)then
+ v1=v(c(3,m),2)
+ do 33 i11=0,d
+ g1(i11)=vval(i11,c(3,m))
+ 33 continue
+ end if
+ end if
+ h=(z(2)-v0)/(v1-v0)
+c Hermite basis
+ phi0=(1-h)**2*(1+2*h)
+ phi1=h**2*(3-2*h)
+ psi0=h*(1-h)**2
+ psi1=h**2*(h-1)
+ ge=phi0*g0(0)+phi1*g1(0)+(psi0*g0(2)+psi1*g1(2))*(v1-v0)
+ gpe=phi0*g0(1)+phi1*g1(1)
+c ----- West -----
+ v0=v(ll,2)
+ v1=v(ur,2)
+ do 34 i11=0,d
+ g0(i11)=vval(i11,c(1,j))
+ 34 continue
+ do 35 i11=0,d
+ g1(i11)=vval(i11,c(3,j))
+ 35 continue
+ xibar=v(ll,1)
+ m=nt-1
+c top of while loop
+ 36 if(m.eq.0)then
+ i10=.true.
+ else
+ if(a(t(m)).eq.1)then
+ i9=(xi(t(m)).eq.xibar)
+ else
+ i9=.false.
+ end if
+ i10=i9
+ end if
+ if(.not.(.not.i10))goto 37
+ m=m-1
+c voidp junk
+ goto 36
+c bottom of while loop
+ 37 if(m.ge.1)then
+ m=lo(t(m))
+c top of while loop
+ 38 if(.not.(a(m).ne.0))goto 39
+ if(z(a(m)).lt.xi(m))then
+ m=lo(m)
+ else
+ m=hi(m)
+ end if
+ goto 38
+c bottom of while loop
+ 39 if(v0.lt.v(c(2,m),2))then
+ v0=v(c(2,m),2)
+ do 40 i11=0,d
+ g0(i11)=vval(i11,c(2,m))
+ 40 continue
+ end if
+ if(v(c(4,m),2).lt.v1)then
+ v1=v(c(4,m),2)
+ do 41 i11=0,d
+ g1(i11)=vval(i11,c(4,m))
+ 41 continue
+ end if
+ end if
+ h=(z(2)-v0)/(v1-v0)
+c Hermite basis
+ phi0=(1-h)**2*(1+2*h)
+ phi1=h**2*(3-2*h)
+ psi0=h*(1-h)**2
+ psi1=h**2*(h-1)
+ gw=phi0*g0(0)+phi1*g1(0)+(psi0*g0(2)+psi1*g1(2))*(v1-v0)
+ gpw=phi0*g0(1)+phi1*g1(1)
+c NS
+ h=(z(2)-v(ll,2))/(v(ur,2)-v(ll,2))
+c Hermite basis
+ phi0=(1-h)**2*(1+2*h)
+ phi1=h**2*(3-2*h)
+ psi0=h*(1-h)**2
+ psi1=h**2*(h-1)
+ sns=phi0*gs+phi1*gn+(psi0*gps+psi1*gpn)*(v(ur,2)-v(ll,2))
+c EW
+ h=(z(1)-v(ll,1))/(v(ur,1)-v(ll,1))
+c Hermite basis
+ phi0=(1-h)**2*(1+2*h)
+ phi1=h**2*(3-2*h)
+ psi0=h*(1-h)**2
+ psi1=h**2*(h-1)
+ sew=phi0*gw+phi1*ge+(psi0*gpw+psi1*gpe)*(v(ur,1)-v(ll,1))
+ s=(sns+sew)-s
+ end if
+ ehg128=s
+ return
+ end
+
+ integer function ifloor(x)
+ DOUBLE PRECISION x
+ ifloor=x
+ if(ifloor.gt.x) ifloor=ifloor-1
+ end
+
+c DSIGN is unused, causes conflicts on some platforms
+c DOUBLE PRECISION function DSIGN(a1,a2)
+c DOUBLE PRECISION a1, a2
+c DSIGN=DABS(a1)
+c if(a2.ge.0)DSIGN=-DSIGN
+c end
+
+
+c ehg136() is the workhorse of lowesf(.)
+c n = number of observations
+c m = number of x values at which to evaluate
+c f = span
+c nf = min(n, floor(f * n))
+ subroutine ehg136(u,lm,m,n,d,nf,f,x,psi,y,rw,kernel,k,dist,eta,b,
+ + od,o,ihat,w,rcond,sing,dd,tdeg,cdeg,s)
+ integer identi,d,dd,execnt,i,i1,ihat,info,j,k,kernel,l,lm,m,n,nf,
+ + od,sing,tdeg
+ integer cdeg(8),psi(n)
+ double precision f,i2,rcond,scale,tol
+ double precision o(m,n),sigma(15),e(15,15),g(15,15),b(nf,k),
+ $ dist(n),eta(nf),dgamma(15),q(8),qraux(15),rw(n),s(0:od,m),
+ $ u(lm,d),w(nf),work(15),x(n,d),y(n)
+
+ external ehg127,ehg182,dqrsl
+ double precision ddot
+ external ddot
+
+ save execnt
+ data execnt /0/
+
+c V -> g
+c U -> e
+c Identity -> identi
+c L -> o
+c X -> b
+ execnt=execnt+1
+ if(k .gt. nf-1) call ehg182(104)
+ if(k .gt. 15) call ehg182(105)
+ do 3 identi=1,n
+ psi(identi)=identi
+ 3 continue
+ do 4 l=1,m
+ do 5 i1=1,d
+ q(i1)=u(l,i1)
+ 5 continue
+ call ehg127(q,n,d,nf,f,x,psi,y,rw,kernel,k,dist,eta,b,od,w,
+ + rcond,sing,sigma,e,g,dgamma,qraux,work,tol,dd,tdeg,cdeg,
+ + s(0,l))
+ if(ihat.eq.1)then
+c $L sub {l,l} =
+c V sub {1,:} SIGMA sup {+} U sup T
+c (Q sup T W e sub i )$
+ if(.not.(m.eq.n))then
+ call ehg182(123)
+ end if
+c find $i$ such that $l = psi sub i$
+ i=1
+c top of while loop
+ 6 if(.not.(l.ne.psi(i)))goto 7
+ i=i+1
+ if(.not.(i.lt.nf))then
+ call ehg182(123)
+ goto 7
+ end if
+ goto 6
+c bottom of while loop
+ 7 do 8 i1=1,nf
+ eta(i1)=0
+ 8 continue
+ eta(i)=w(i)
+c $eta = Q sup T W e sub i$
+ call dqrsl(b,nf,nf,k,qraux,eta,eta,eta,eta,eta,eta,1000,
+ + info)
+c $gamma = U sup T eta sub {1:k}$
+ do 9 i1=1,k
+ dgamma(i1)=0
+ 9 continue
+ do 10 j=1,k
+ i2=eta(j)
+ do 11 i1=1,k
+ dgamma(i1)=dgamma(i1)+i2*e(j,i1)
+ 11 continue
+ 10 continue
+c $gamma = SIGMA sup {+} gamma$
+ do 12 j=1,k
+ if(tol.lt.sigma(j))then
+ dgamma(j)=dgamma(j)/sigma(j)
+ else
+ dgamma(j)=0.d0
+ end if
+ 12 continue
+c voidp junk
+c voidp junk
+ o(l,1)=ddot(k,g(1,1),15,dgamma,1)
+ else
+ if(ihat.eq.2)then
+c $L sub {l,:} =
+c V sub {1,:} SIGMA sup {+}
+c ( U sup T Q sup T ) W $
+ do 13 i1=1,n
+ o(l,i1)=0
+ 13 continue
+ do 14 j=1,k
+ do 15 i1=1,nf
+ eta(i1)=0
+ 15 continue
+ do 16 i1=1,k
+ eta(i1)=e(i1,j)
+ 16 continue
+ call dqrsl(b,nf,nf,k,qraux,eta,eta,work,work,work,work
+ + ,10000,info)
+ if(tol.lt.sigma(j))then
+ scale=1.d0/sigma(j)
+ else
+ scale=0.d0
+ end if
+ do 17 i1=1,nf
+ eta(i1)=eta(i1)*(scale*w(i1))
+ 17 continue
+ do 18 i=1,nf
+ o(l,psi(i))=o(l,psi(i))+g(1,j)*eta(i)
+ 18 continue
+ 14 continue
+ end if
+ end if
+ 4 continue
+ return
+ end
+
+c called from lowesb() ... compute fit ..?..?...
+c somewhat similar to ehg136
+ subroutine ehg139(v,nvmax,nv,n,d,nf,f,x,pi,psi,y,rw,trl,kernel,k,
+ + dist,phi,eta,b,od,w,diagl,vval2,ncmax,vc,a,xi,lo,hi,c,vhit,
+ + rcond,sing,dd,tdeg,cdeg,lq,lf,setlf,s)
+ logical setlf
+ integer identi,d,dd,execnt,i,i2,i3,i5,i6,ii,ileaf,info,j,k,kernel,
+ + l,n,ncmax,nf,nleaf,nv,nvmax,od,sing,tdeg,vc
+ integer lq(nvmax,nf),a(ncmax),c(vc,ncmax),cdeg(8),hi(ncmax),
+ + leaf(256),lo(ncmax),pi(n),psi(n),vhit(nvmax)
+ DOUBLE PRECISION f,i1,i4,i7,rcond,scale,term,tol,trl
+ DOUBLE PRECISION lf(0:d,nvmax,nf),sigma(15),u(15,15),e(15,15),
+ + b(nf,k),diagl(n),dist(n),eta(nf),DGAMMA(15),q(8),qraux(15),
+ + rw(n),s(0:od,nv),v(nvmax,d),vval2(0:d,nv),w(nf),work(15),
+ + x(n,d),xi(ncmax),y(n),z(8)
+ DOUBLE PRECISION phi(n)
+
+ external ehg127,ehg182,DQRSL,ehg137
+ DOUBLE PRECISION ehg128
+ external ehg128
+ DOUBLE PRECISION DDOT
+ external DDOT
+
+ save execnt
+ data execnt /0/
+c V -> e
+c Identity -> identi
+c X -> b
+ execnt=execnt+1
+c l2fit with trace(L)
+ if(k .gt. nf-1) call ehg182(104)
+ if(k .gt. 15) call ehg182(105)
+ if(trl.ne.0)then
+ do 3 i5=1,n
+ diagl(i5)=0
+ 3 continue
+ do 4 i6=1,nv
+ do 5 i5=0,d
+ vval2(i5,i6)=0
+ 5 continue
+ 4 continue
+ end if
+ do 6 identi=1,n
+ psi(identi)=identi
+ 6 continue
+ do 7 l=1,nv
+ do 8 i5=1,d
+ q(i5)=v(l,i5)
+ 8 continue
+ call ehg127(q,n,d,nf,f,x,psi,y,rw,kernel,k,dist,eta,b,od,w,
+ + rcond,sing,sigma,u,e,DGAMMA,qraux,work,tol,dd,tdeg,cdeg,
+ + s(0,l))
+ if(trl.ne.0)then
+c invert $psi$
+ do 9 i5=1,n
+ phi(i5)=0
+ 9 continue
+ do 10 i=1,nf
+ phi(psi(i))=i
+ 10 continue
+ do 11 i5=1,d
+ z(i5)=v(l,i5)
+ 11 continue
+ call ehg137(z,vhit(l),leaf,nleaf,d,nv,nvmax,ncmax,a,xi,
+ + lo,hi)
+ do 12 ileaf=1,nleaf
+ do 13 ii=lo(leaf(ileaf)),hi(leaf(ileaf))
+ i=phi(pi(ii))
+ if(i.ne.0)then
+ if(.not.(psi(i).eq.pi(ii)))then
+ call ehg182(194)
+ end if
+ do 14 i5=1,nf
+ eta(i5)=0
+ 14 continue
+ eta(i)=w(i)
+c $eta = Q sup T W e sub i$
+ call DQRSL(b,nf,nf,k,qraux,eta,work,eta,eta,work,
+ + work,1000,info)
+ do 15 j=1,k
+ if(tol.lt.sigma(j))then
+ i4=DDOT(k,u(1,j),1,eta,1)/sigma(j)
+ else
+ i4=0.D0
+ end if
+ DGAMMA(j)=i4
+ 15 continue
+ do 16 j=1,d+1
+ vval2(j-1,l)=DDOT(k,e(j,1),15,DGAMMA,1)
+ 16 continue
+ do 17 i5=1,d
+ z(i5)=x(pi(ii),i5)
+ 17 continue
+ term=ehg128(z,d,ncmax,vc,a,xi,lo,hi,c,v,nvmax,
+ + vval2)
+ diagl(pi(ii))=diagl(pi(ii))+term
+ do 18 i5=0,d
+ vval2(i5,l)=0
+ 18 continue
+ end if
+ 13 continue
+ 12 continue
+ end if
+ if(setlf)then
+c $Lf sub {:,l,:} = V SIGMA sup {+} U sup T Q sup T W$
+ if(.not.(k.ge.d+1))then
+ call ehg182(196)
+ end if
+ do 19 i5=1,nf
+ lq(l,i5)=psi(i5)
+ 19 continue
+ do 20 i6=1,nf
+ do 21 i5=0,d
+ lf(i5,l,i6)=0
+ 21 continue
+ 20 continue
+ do 22 j=1,k
+ do 23 i5=1,nf
+ eta(i5)=0
+ 23 continue
+ do 24 i5=1,k
+ eta(i5)=u(i5,j)
+ 24 continue
+ call DQRSL(b,nf,nf,k,qraux,eta,eta,work,work,work,work,
+ + 10000,info)
+ if(tol.lt.sigma(j))then
+ scale=1.D0/sigma(j)
+ else
+ scale=0.D0
+ end if
+ do 25 i5=1,nf
+ eta(i5)=eta(i5)*(scale*w(i5))
+ 25 continue
+ do 26 i=1,nf
+ i7=eta(i)
+ do 27 i5=0,d
+ lf(i5,l,i)=lf(i5,l,i)+e(1+i5,j)*i7
+ 27 continue
+ 26 continue
+ 22 continue
+ end if
+ 7 continue
+ if(trl.ne.0)then
+ if(n.le.0)then
+ trl=0.D0
+ else
+ i3=n
+ i1=diagl(i3)
+ do 28 i2=i3-1,1,-1
+ i1=diagl(i2)+i1
+ 28 continue
+ trl=i1
+ end if
+ end if
+ return
+ end
+
+ subroutine lowesb(xx,yy,ww,diagl,infl,iv,liv,lv,wv)
+ logical infl
+ integer liv, lv
+ integer iv(*)
+ DOUBLE PRECISION xx(*),yy(*),ww(*),diagl(*),wv(*)
+c Var
+ DOUBLE PRECISION trl
+ logical setlf
+ integer execnt
+
+ integer ifloor
+ external ifloor
+ external ehg131,ehg182,ehg183
+
+ save execnt
+ data execnt /0/
+ execnt=execnt+1
+ if(.not.(iv(28).ne.173))then
+ call ehg182(174)
+ end if
+ if(iv(28).ne.172)then
+ if(.not.(iv(28).eq.171))then
+ call ehg182(171)
+ end if
+ end if
+ iv(28)=173
+ if(infl)then
+ trl=1.D0
+ else
+ trl=0.D0
+ end if
+ setlf=(iv(27).ne.iv(25))
+ call ehg131(xx,yy,ww,trl,diagl,iv(20),iv(29),iv(3),iv(2),iv(5),
+ + iv(17),iv(4),iv(6),iv(14),iv(19),wv(1),iv(iv(7)),iv(iv(8)),
+ + iv(iv(9)),iv(iv(10)),iv(iv(22)),iv(iv(27)),wv(iv(11)),
+ + iv(iv(23)),wv(iv(13)),wv(iv(12)),wv(iv(15)),wv(iv(16)),
+ + wv(iv(18)),ifloor(iv(3)*wv(2)),wv(3),wv(iv(26)),wv(iv(24)),
+ + wv(4),iv(30),iv(33),iv(32),iv(41),iv(iv(25)),wv(iv(34)),
+ + setlf)
+ if(iv(14).lt.iv(6)+DBLE(iv(4))/2.D0)then
+ call ehg183('k-d tree limited by memory; nvmax=',
+ + iv(14),1,1)
+ else
+ if(iv(17).lt.iv(5)+2)then
+ call ehg183('k-d tree limited by memory. ncmax=',
+ + iv(17),1,1)
+ end if
+ end if
+ return
+ end
+
+c�lowesd() : Initialize iv(*) and v(1:4)
+c ------ called only by loess_workspace() in ./loessc.c
+ subroutine lowesd(versio,iv,liv,lv,v,d,n,f,ideg,nvmax,setlf)
+ integer versio,liv,lv,d,n,ideg,nvmax
+ integer iv(liv)
+ logical setlf
+ double precision f, v(lv)
+
+ integer bound,execnt,i,i1,i2,j,ncmax,nf,vc
+ external ehg182
+ integer ifloor
+ external ifloor
+ save execnt
+ data execnt /0/
+c
+c unnecessary initialization of i1 to keep g77 -Wall happy
+c
+ i1 = 0
+c version -> versio
+ execnt=execnt+1
+ if(.not.(versio.eq.106))then
+ call ehg182(100)
+ end if
+ iv(28)=171
+ iv(2)=d
+ iv(3)=n
+ vc=2**d
+ iv(4)=vc
+ if(.not.(0.lt.f))then
+ call ehg182(120)
+ end if
+ nf=min(n,ifloor(n*f))
+ iv(19)=nf
+ iv(20)=1
+ if(ideg.eq.0)then
+ i1=1
+ else
+ if(ideg.eq.1)then
+ i1=d+1
+ else
+ if(ideg.eq.2)then
+ i1=dble((d+2)*(d+1))/2.d0
+ end if
+ end if
+ end if
+ iv(29)=i1
+ iv(21)=1
+ iv(14)=nvmax
+ ncmax=nvmax
+ iv(17)=ncmax
+ iv(30)=0
+ iv(32)=ideg
+ if(.not.(ideg.ge.0))then
+ call ehg182(195)
+ end if
+ if(.not.(ideg.le.2))then
+ call ehg182(195)
+ end if
+ iv(33)=d
+ do 3 i2=41,49
+ iv(i2)=ideg
+ 3 continue
+ iv(7)=50
+ iv(8)=iv(7)+ncmax
+ iv(9)=iv(8)+vc*ncmax
+ iv(10)=iv(9)+ncmax
+ iv(22)=iv(10)+ncmax
+c initialize permutation
+ j=iv(22)-1
+ do 4 i=1,n
+ iv(j+i)=i
+ 4 continue
+ iv(23)=iv(22)+n
+ iv(25)=iv(23)+nvmax
+ if(setlf)then
+ iv(27)=iv(25)+nvmax*nf
+ else
+ iv(27)=iv(25)
+ end if
+ bound=iv(27)+n
+ if(.not.(bound-1.le.liv))then
+ call ehg182(102)
+ end if
+ iv(11)=50
+ iv(13)=iv(11)+nvmax*d
+ iv(12)=iv(13)+(d+1)*nvmax
+ iv(15)=iv(12)+ncmax
+ iv(16)=iv(15)+n
+ iv(18)=iv(16)+nf
+ iv(24)=iv(18)+iv(29)*nf
+ iv(34)=iv(24)+(d+1)*nvmax
+ if(setlf)then
+ iv(26)=iv(34)+(d+1)*nvmax*nf
+ else
+ iv(26)=iv(34)
+ end if
+ bound=iv(26)+nf
+ if(.not.(bound-1.le.lv))then
+ call ehg182(103)
+ end if
+ v(1)=f
+ v(2)=0.05d0
+ v(3)=0.d0
+ v(4)=1.d0
+ return
+ end
+
+ subroutine lowese(iv,liv,lv,wv,m,z,s)
+ integer liv,lv,m
+ integer iv(*)
+ double precision s(m),wv(*),z(m,1)
+
+ integer execnt
+ external ehg133,ehg182
+
+ save execnt
+ data execnt /0/
+ execnt=execnt+1
+ if(.not.(iv(28).ne.172))then
+ call ehg182(172)
+ end if
+ if(.not.(iv(28).eq.173))then
+ call ehg182(173)
+ end if
+ call ehg133(iv(3),iv(2),iv(4),iv(14),iv(5),iv(17),iv(iv(7)),iv(iv(
+ +8)),iv(iv(9)),iv(iv(10)),wv(iv(11)),wv(iv(13)),wv(iv(12)),m,z,s)
+ return
+ end
+
+c "direct" (non-"interpolate") fit aka predict() :
+ subroutine lowesf(xx,yy,ww,iv,liv,lv,wv,m,z,l,ihat,s)
+ integer liv,lv,m,ihat
+c m = number of x values at which to evaluate
+ integer iv(*)
+ double precision xx(*),yy(*),ww(*),wv(*),z(m,1),l(m,*),s(m)
+
+ logical i1
+ integer execnt
+
+ external ehg182,ehg136
+ save execnt
+ data execnt /0/
+ execnt=execnt+1
+ if(171.le.iv(28))then
+ i1=(iv(28).le.174)
+ else
+ i1=.false.
+ end if
+ if(.not.i1)then
+ call ehg182(171)
+ end if
+ iv(28)=172
+ if(.not.(iv(14).ge.iv(19)))then
+ call ehg182(186)
+ end if
+
+c do the work; in ehg136() give the argument names as they are there:
+c ehg136(u,lm,m, n, d, nf, f, x, psi, y ,rw,
+ call ehg136(z,m,m,iv(3),iv(2),iv(19),wv(1),xx,iv(iv(22)),yy,ww,
+c kernel, k, dist, eta, b, od,o,ihat,
+ + iv(20),iv(29),wv(iv(15)),wv(iv(16)),wv(iv(18)),0,l,ihat,
+c w, rcond,sing, dd, tdeg,cdeg, s)
+ + wv(iv(26)),wv(4),iv(30),iv(33),iv(32),iv(41),s)
+ return
+ end
+
+ subroutine lowesl(iv,liv,lv,wv,m,z,l)
+ integer liv,lv,m
+ integer iv(*)
+ double precision l(m,*),wv(*),z(m,1)
+
+ integer execnt
+ external ehg182,ehg191
+ save execnt
+ data execnt /0/
+ execnt=execnt+1
+ if(.not.(iv(28).ne.172))then
+ call ehg182(172)
+ end if
+ if(.not.(iv(28).eq.173))then
+ call ehg182(173)
+ end if
+ if(.not.(iv(26).ne.iv(34)))then
+ call ehg182(175)
+ end if
+ call ehg191(m,z,l,iv(2),iv(3),iv(19),iv(6),iv(17),iv(4),iv(iv(7)),
+ + wv(iv(12)),iv(iv(10)),iv(iv(9)),iv(iv(8)),wv(iv(11)),iv(14),
+ + wv(iv(24)),wv(iv(34)),iv(iv(25)))
+ return
+ end
+
+ subroutine lowesr(yy,iv,liv,lv,wv)
+ integer liv,lv
+ integer iv(*)
+ DOUBLE PRECISION yy(*),wv(*)
+
+ integer execnt
+ external ehg182,ehg192
+ save execnt
+ data execnt /0/
+ execnt=execnt+1
+ if(.not.(iv(28).ne.172))then
+ call ehg182(172)
+ end if
+ if(.not.(iv(28).eq.173))then
+ call ehg182(173)
+ end if
+ call ehg192(yy,iv(2),iv(3),iv(19),iv(6),iv(14),wv(iv(13)),
+ + wv(iv(34)),iv(iv(25)))
+ return
+ end
+
+ subroutine lowesw(res,n,rw,pi)
+c Tranliterated from Devlin's ratfor
+
+c implicit none
+c Args
+ integer n
+ double precision res(n),rw(n)
+ integer pi(n)
+c Var
+ integer identi,i,i1,nh
+ double precision cmad,rsmall
+
+ integer ifloor
+ double precision d1mach
+
+ external ehg106
+ external ifloor
+ external d1mach
+
+c Identity -> identi
+
+c find median of absolute residuals
+ do 3 i1=1,n
+ rw(i1)=dabs(res(i1))
+ 3 continue
+ do 4 identi=1,n
+ pi(identi)=identi
+ 4 continue
+ nh=ifloor(dble(n)/2.d0)+1
+c partial sort to find 6*mad
+ call ehg106(1,n,nh,1,rw,pi,n)
+ if((n-nh)+1.lt.nh)then
+ call ehg106(1,nh-1,nh-1,1,rw,pi,n)
+ cmad=3*(rw(pi(nh))+rw(pi(nh-1)))
+ else
+ cmad=6*rw(pi(nh))
+ end if
+ rsmall=d1mach(1)
+ if(cmad.lt.rsmall)then
+ do 5 i1=1,n
+ rw(i1)=1
+ 5 continue
+ else
+ do 6 i=1,n
+ if(cmad*0.999d0.lt.rw(i))then
+ rw(i)=0
+ else
+ if(cmad*0.001d0.lt.rw(i))then
+ rw(i)=(1-(rw(i)/cmad)**2)**2
+ else
+ rw(i)=1
+ end if
+ end if
+ 6 continue
+ end if
+ return
+ end
+
+ subroutine lowesp(n,y,yhat,pwgts,rwgts,pi,ytilde)
+ integer n
+ integer pi(n)
+ double precision y(n),yhat(n),pwgts(n),rwgts(n),ytilde(n)
+c Var
+ double precision c,i1,i4,mad
+ integer identi,execnt,i2,i3,i5,m
+
+ external ehg106
+ integer ifloor
+ external ifloor
+ save execnt
+ data execnt /0/
+c Identity -> identi
+ execnt=execnt+1
+c median absolute deviation
+ do 3 i5=1,n
+ ytilde(i5)=dabs(y(i5)-yhat(i5))*dsqrt(pwgts(i5))
+ 3 continue
+ do 4 identi=1,n
+ pi(identi)=identi
+ 4 continue
+ m=ifloor(dble(n)/2.d0)+1
+ call ehg106(1,n,m,1,ytilde,pi,n)
+ if((n-m)+1.lt.m)then
+ call ehg106(1,m-1,m-1,1,ytilde,pi,n)
+ mad=(ytilde(pi(m-1))+ytilde(pi(m)))/2
+ else
+ mad=ytilde(pi(m))
+ end if
+c magic constant
+ c=(6*mad)**2/5
+ do 5 i5=1,n
+ ytilde(i5)=1-((y(i5)-yhat(i5))**2*pwgts(i5))/c
+ 5 continue
+ do 6 i5=1,n
+ ytilde(i5)=ytilde(i5)*dsqrt(rwgts(i5))
+ 6 continue
+ if(n.le.0)then
+ i4=0.d0
+ else
+ i3=n
+ i1=ytilde(i3)
+ do 7 i2=i3-1,1,-1
+ i1=ytilde(i2)+i1
+ 7 continue
+ i4=i1
+ end if
+ c=n/i4
+c pseudovalues
+ do 8 i5=1,n
+ ytilde(i5)=yhat(i5)+(c*rwgts(i5))*(y(i5)-yhat(i5))
+ 8 continue
+ return
+ end
+
+ subroutine ehg124(ll,uu,d,n,nv,nc,ncmax,vc,x,pi,a,xi,lo,hi,c,v,
+ + vhit,nvmax,fc,fd,dd)
+
+ integer ll,uu,d,n,nv,nc,ncmax,vc,nvmax,fc,dd
+ integer a(ncmax),c(vc,ncmax),hi(ncmax),lo(ncmax),pi(n),vhit(nvmax)
+ DOUBLE PRECISION fd, v(nvmax,d),x(n,d),xi(ncmax)
+
+ logical i1,i2,i3,leaf
+ integer execnt,i4,inorm2,k,l,m,p,u
+ DOUBLE PRECISION diam,diag(8),sigma(8)
+
+ external ehg125,ehg106,ehg129
+ integer IDAMAX
+ external IDAMAX
+ save execnt
+ data execnt /0/
+ execnt=execnt+1
+ p=1
+ l=ll
+ u=uu
+ lo(p)=l
+ hi(p)=u
+c top of while loop
+ 3 if(.not.(p.le.nc))goto 4
+ do 5 i4=1,dd
+ diag(i4)=v(c(vc,p),i4)-v(c(1,p),i4)
+ 5 continue
+ diam=0
+ do 6 inorm2=1,dd
+ diam=diam+diag(inorm2)**2
+ 6 continue
+ diam=DSQRT(diam)
+ if((u-l)+1.le.fc)then
+ i1=.true.
+ else
+ i1=(diam.le.fd)
+ end if
+ if(i1)then
+ leaf=.true.
+ else
+ if(ncmax.lt.nc+2)then
+ i2=.true.
+ else
+ i2=(nvmax.lt.nv+DBLE(vc)/2.D0)
+ end if
+ leaf=i2
+ end if
+ if(.not.leaf)then
+ call ehg129(l,u,dd,x,pi,n,sigma)
+ k=IDAMAX(dd,sigma,1)
+ m=DBLE(l+u)/2.D0
+ call ehg106(l,u,m,1,x(1,k),pi,n)
+c all ties go with hi son
+c top of while loop
+ 7 if(1.lt.m)then
+ i3=(x(pi(m-1),k).eq.x(pi(m),k))
+ else
+ i3=.false.
+ end if
+ if(.not.(i3))goto 8
+ m=m-1
+ goto 7
+c bottom of while loop
+ 8 if(v(c(1,p),k).eq.x(pi(m),k))then
+ leaf=.true.
+ else
+ leaf=(v(c(vc,p),k).eq.x(pi(m),k))
+ end if
+ end if
+ if(leaf)then
+ a(p)=0
+ else
+ a(p)=k
+ xi(p)=x(pi(m),k)
+c left son
+ nc=nc+1
+ lo(p)=nc
+ lo(nc)=l
+ hi(nc)=m
+c right son
+ nc=nc+1
+ hi(p)=nc
+ lo(nc)=m+1
+ hi(nc)=u
+ call ehg125(p,nv,v,vhit,nvmax,d,k,xi(p),2**(k-1),2**(d-k),
+ + c(1,p),c(1,lo(p)),c(1,hi(p)))
+ end if
+ p=p+1
+ l=lo(p)
+ u=hi(p)
+ goto 3
+c bottom of while loop
+ 4 return
+ end
+
+ subroutine ehg129(l,u,d,x,pi,n,sigma)
+ integer d,execnt,i,k,l,n,u
+ integer pi(n)
+ DOUBLE PRECISION machin,alpha,beta,t
+ DOUBLE PRECISION sigma(d),x(n,d)
+ DOUBLE PRECISION D1MACH
+ external D1MACH
+ save machin,execnt
+ data execnt /0/
+c MachInf -> machin
+ execnt=execnt+1
+ if(execnt.eq.1)then
+c initialize d1mach(2) === DBL_MAX:
+ machin=D1MACH(2)
+ end if
+ do 3 k=1,d
+ alpha=machin
+ beta=-machin
+ do 4 i=l,u
+ t=x(pi(i),k)
+ alpha=min(alpha,x(pi(i),k))
+ beta=max(beta,t)
+ 4 continue
+ sigma(k)=beta-alpha
+ 3 continue
+ return
+ end
+
+c {called only from ehg127} purpose...?...
+ subroutine ehg137(z,kappa,leaf,nleaf,d,nv,nvmax,ncmax,a,xi,lo,hi)
+ integer kappa,d,nv,nvmax,ncmax,nleaf
+ integer leaf(256),a(ncmax),hi(ncmax),lo(ncmax),pstack(20)
+ DOUBLE PRECISION z(d),xi(ncmax)
+
+ integer execnt,p,stackt
+
+ external ehg182
+ save execnt
+ data execnt /0/
+c stacktop -> stackt
+ execnt=execnt+1
+c find leaf cells affected by $z$
+ stackt=0
+ p=1
+ nleaf=0
+c top of while loop
+ 3 if(.not.(0.lt.p))goto 4
+ if(a(p).eq.0)then
+c leaf
+ nleaf=nleaf+1
+ leaf(nleaf)=p
+c Pop
+ if(stackt.ge.1)then
+ p=pstack(stackt)
+ else
+ p=0
+ end if
+ stackt=max(0,stackt-1)
+ else
+ if(z(a(p)).eq.xi(p))then
+c Push
+ stackt=stackt+1
+ if(.not.(stackt.le.20))then
+ call ehg182(187)
+ end if
+ pstack(stackt)=hi(p)
+ p=lo(p)
+ else
+ if(z(a(p)).lt.xi(p))then
+ p=lo(p)
+ else
+ p=hi(p)
+ end if
+ end if
+ end if
+ goto 3
+c bottom of while loop
+ 4 if(.not.(nleaf.le.256))then
+ call ehg182(185)
+ end if
+ return
+ end
+
+C-- For Error messaging, call the "a" routines at the bottom of ./loessc.c :
+ subroutine ehg183(s, i, n, inc)
+ character s*(*)
+ integer i, n, inc
+ call ehg183a(s, len(s), i, n, inc)
+ end
+
+ subroutine ehg184(s, x, n, inc)
+ character s*(*)
+ double precision x
+ integer n, inc
+ call ehg184a(s, len(s), x, n, inc)
+ end
diff --git a/src/modreg.h b/src/modreg.h
new file mode 100644
index 0000000..7c84cdf
--- /dev/null
+++ b/src/modreg.h
@@ -0,0 +1,252 @@
+/*
+
+ * R : A Computer Language for Statistical Data Analysis
+
+ * Copyright (C) 2001-2 The R Development Core Team.
+
+ * Copyright (C) 2003 The R Foundation
+
+ *
+
+ * This program is free software; you can redistribute it and/or modify
+
+ * it under the terms of the GNU General Public License as published by
+
+ * the Free Software Foundation; either version 2 of the License, or
+
+ * (at your option) any later version.
+
+ *
+
+ * This program is distributed in the hope that it will be useful,
+
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+
+ * GNU General Public License for more details.
+
+ *
+
+ * You should have received a copy of the GNU General Public License
+
+ * along with this program; if not, write to the Free Software
+
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+ */
+
+
+
+#ifndef R_MODREG_H
+
+#define R_MODREG_H
+
+
+
+#include <R.h>
+
+/* for Sint .. */
+
+#include <Rinternals.h>
+
+
+
+SEXP R_isoreg(SEXP y);
+
+
+
+void BDRksmooth(double *x, double *y, int *n,
+
+ double *xp, double *yp, int *np,
+
+ int *kern, double *bandwidth);
+
+
+
+void
+
+loess_raw(double *y, double *x, double *weights, double *robust, Sint *d,
+
+ Sint *n, double *span, Sint *degree, Sint *nonparametric,
+
+ Sint *drop_square, Sint *sum_drop_sqr, double *cell,
+
+ char **surf_stat, double *surface, Sint *parameter,
+
+ Sint *a, double *xi, double *vert, double *vval, double *diagonal,
+
+ double *trL, double *one_delta, double *two_delta, Sint *setLf);
+
+void
+
+loess_dfit(double *y, double *x, double *x_evaluate, double *weights,
+
+ double *span, Sint *degree, Sint *nonparametric,
+
+ Sint *drop_square, Sint *sum_drop_sqr,
+
+ Sint *d, Sint *n, Sint *m, double *fit);
+
+void
+
+loess_dfitse(double *y, double *x, double *x_evaluate, double *weights,
+
+ double *robust, Sint *family, double *span, Sint *degree,
+
+ Sint *nonparametric, Sint *drop_square,
+
+ Sint *sum_drop_sqr,
+
+ Sint *d, Sint *n, Sint *m, double *fit, double *L);
+
+void
+
+loess_ifit(Sint *parameter, Sint *a, double *xi, double *vert,
+
+ double *vval, Sint *m, double *x_evaluate, double *fit);
+
+void
+
+loess_ise(double *y, double *x, double *x_evaluate, double *weights,
+
+ double *span, Sint *degree, Sint *nonparametric,
+
+ Sint *drop_square, Sint *sum_drop_sqr, double *cell,
+
+ Sint *d, Sint *n, Sint *m, double *fit, double *L);
+
+
+
+void Srunmed(double *y, double *smo,
+
+ Sint *n, Sint *band, Sint *end_rule, Sint *debug);
+
+
+
+void Trunmed(Sint *nn,/* = length(data) */
+
+ Sint *kk,/* is odd <= nn */
+
+ const double *data,
+
+ double *median, /* (n) */
+
+ Sint *outlist,/* (k+1) */
+
+ Sint *nrlist,/* (2k+1) */
+
+ double *window,/* (2k+1) */
+
+ Sint *end_rule,
+
+ Sint *print_level);
+
+
+
+/* Fortran : */
+
+
+
+void F77_SUB(lowesw)(double *res, int *n, double *rw, int *pi);
+
+void F77_SUB(lowesp)(int *n, double *y, double *yhat, double *pwgts,
+
+ double *rwgts, int *pi, double *ytilde);
+
+void F77_SUB(setppr)(double *span1, double *alpha1,
+
+ int *optlevel, int *ism, double *df1, double *gcvpen1);
+
+void F77_SUB(smart)(int *m, int *mu, int *p, int * q, int *n,
+
+ double *w, double *x, double *y,
+
+ double *ww, double *smod, int *nsmod, double *sp,
+
+ int *nsp, double *dp, int *ndp, double *edf);
+
+void F77_SUB(pppred)(int *np, double *x, double *smod,
+
+ double *y, double *sc);
+
+void F77_SUB(qsbart)(double *penalt, double *dofoff,
+
+ double *xs, double *ys, double *ws, double *ssw,
+
+ int *n, double *knot, int *nk, double *coef,
+
+ double *sz, double *lev, double *crit, int *iparms,
+
+ double *spar, double *parms, int *isetup,
+
+ double *scrtch, int *ld4, int *ldnk, int *ier);
+
+
+
+void F77_NAME(sbart)
+
+ (double *penalt, double *dofoff,
+
+ double *xs, double *ys, double *ws, double *ssw,
+
+ int *n, double *knot, int *nk, double *coef,
+
+ double *sz, double *lev, double *crit, int *icrit,
+
+ double *spar, int *ispar, int *iter, double *lspar,
+
+ double *uspar, double *tol, double *eps, int *isetup,
+
+ double *xwy, double *hs0, double *hs1, double *hs2,
+
+ double *hs3, double *sg0, double *sg1, double *sg2,
+
+ double *sg3, double *abd, double *p1ip, double *p2ip,
+
+ int *ld4, int *ldnk, int *ier);
+
+
+
+void F77_NAME(sgram)(double *sg0, double *sg1, double *sg2, double *sg3,
+
+ double *tb, int *nb);
+
+void F77_NAME(stxwx)(double *x, double *z, double *w,
+
+ int *k, double *xknot, int *n, double *y,
+
+ double *hs0, double *hs1, double *hs2, double *hs3);
+
+void F77_NAME(sslvrg)(double *penalt, double *dofoff,
+
+ double *x, double *y, double *w, double *ssw, int *n,
+
+ double *knot, int *nk, double *coef, double *sz,
+
+ double *lev, double *crit, int *icrit, double *lambda,
+
+ double *xwy,
+
+ double *hs0, double *hs1, double *hs2, double *hs3,
+
+ double *sg0, double *sg1, double *sg2, double *sg3,
+
+ double *abd, double *p1ip, double *p2ip,
+
+ int *ld4, int *ldnk, int *info);
+
+
+
+void F77_SUB(bvalus)(int *n, double *knot, double *coef,
+
+ int *nk, double *x, double *s, int *order);
+
+void F77_SUB(supsmu)(int *n, double *x, double *y,
+
+ double *w, int *iper, double *span, double *alpha,
+
+ double *smo, double *sc, double *edf);
+
+#endif
+
diff --git a/src/qsbart.f b/src/qsbart.f
new file mode 100644
index 0000000..1307fc9
--- /dev/null
+++ b/src/qsbart.f
@@ -0,0 +1,33 @@
+C An interface to sbart() --- fewer arguments BUT unspecified scrtch() dimension
+C
+ subroutine qsbart(penalt,dofoff,xs,ys,ws,ssw,n,knot,nk,
+ & coef,sz,lev,
+ & crit,iparms,spar,parms,
+ & isetup, scrtch, ld4,ldnk,ier)
+c
+ integer n,nk,isetup, iparms(3), ld4,ldnk,ier
+ double precision penalt,dofoff, xs(n),ys(n),ws(n),ssw,
+ & knot(nk+4), coef(nk),sz(n),lev(n),
+ & crit, spar, parms(4),
+ & scrtch(*)
+C ^^^^^^^^ dimension (9+2*ld4+nk)*nk = (17 + nk)*nk
+
+ call sbart(penalt,dofoff,xs,ys,ws,ssw,n,knot,nk,
+ & coef,sz,lev, crit,
+ & iparms(1),spar,iparms(2),iparms(3),
+c = icrit spar ispar iter
+ & parms(1),parms(2),parms(3),parms(4),
+c = lspar uspar tol eps
+ & isetup, scrtch(1),
+c = 0 xwy
+ & scrtch( nk+1),scrtch(2*nk+1),scrtch(3*nk+1),scrtch(4*nk+1),
+c = hs0 hs1 hs2 hs3
+ & scrtch(5*nk+1),scrtch(6*nk+1),scrtch(7*nk+1),scrtch(8*nk+1),
+c = sg0 sg1 sg2 sg3
+ & scrtch(9*nk+1),scrtch(9*nk+ ld4*nk+1),scrtch(9*nk+2*ld4*nk),
+c = abd p1ip p2ip
+ & ld4,ldnk,ier)
+
+ return
+ end
+
diff --git a/src/sbart.c b/src/sbart.c
new file mode 100644
index 0000000..e2a823c
--- /dev/null
+++ b/src/sbart.c
@@ -0,0 +1,758 @@
+/* sbart.f -- translated by f2c (version 20010821).
+
+ * ------- and f2c-clean,v 1.9 2000/01/13
+
+ *
+
+ * According to the GAMFIT sources, this was derived from code by
+
+ * Finbarr O'Sullivan.
+
+ */
+
+#include <R.h>
+
+#include <Rmath.h>
+
+#include <R_ext/PrtUtil.h>
+
+
+
+#include "modreg.h"
+
+
+
+/* sbart() : The cubic spline smoother
+
+ -------
+
+ Calls sgram (sg0,sg1,sg2,sg3,knot,nk)
+
+ stxwx (xs,ys,ws,n,knot,nk,xwy,hs0,hs1,hs2,hs3)
+
+ sslvrg (penalt,dofoff,xs,ys,ws,ssw,n,knot,nk, coef,sz,lev,crit,icrit,
+
+ lambda, xwy, hs0,hs1,hs2,hs3, sg0,sg1,sg2,sg3,
+
+ abd,p1ip,p2ip,ld4,ldnk,ier)
+
+
+
+ is itself called from qsbart() [./qsbart.f] which has only one work array
+
+*/
+
+void F77_SUB(sbart)
+
+ (double *penalt, double *dofoff,
+
+ double *xs, double *ys, double *ws, double *ssw,
+
+ int *n, double *knot, int *nk, double *coef,
+
+ double *sz, double *lev, double *crit, int *icrit,
+
+ double *spar, int *ispar, int *iter, double *lspar,
+
+ double *uspar, double *tol, double *eps, int *isetup,
+
+ double *xwy, double *hs0, double *hs1, double *hs2,
+
+ double *hs3, double *sg0, double *sg1, double *sg2,
+
+ double *sg3, double *abd, double *p1ip, double *p2ip,
+
+ int *ld4, int *ldnk, int *ier)
+
+{
+
+
+
+/* A Cubic B-spline Smoothing routine.
+
+
+
+ The algorithm minimises:
+
+
+
+ (1/n) * sum ws(i)^2 * (ys(i)-sz(i))^2 + lambda* int ( s"(x) )^2 dx
+
+
+
+ lambda is a function of the spar which is assumed to be between 0 and 1
+
+
+
+ INPUT
+
+ -----
+
+ penalt A penalty > 1 to be used in the gcv criterion
+
+ dofoff either `df.offset' for GCV or `df' (to be matched).
+
+ n number of data points
+
+ ys(n) vector of length n containing the observations
+
+ ws(n) vector containing the weights given to each data point
+
+ xs(n) vector containing the ordinates of the observations
+
+ ssw `centered weighted sum of y^2'
+
+ nk number of b-spline coefficients to be estimated
+
+ nk <= n+2
+
+ knot(nk+4) vector of knot points defining the cubic b-spline basis.
+
+ To obtain full cubic smoothing splines one might
+
+ have (provided the xs-values are strictly increasing)
+
+ spar penalised likelihood smoothing parameter
+
+ ispar indicating if spar is supplied (ispar=1) or to be estimated
+
+ lspar, uspar lower and upper values for spar search; 0.,1. are good values
+
+ tol, eps used in Golden Search routine
+
+ isetup setup indicator [initially 0
+
+ icrit indicator saying which cross validation score is to be computed
+
+ 0: none ; 1: GCV ; 2: CV ; 3: 'df matching'
+
+ ld4 the leading dimension of abd (ie ld4=4)
+
+ ldnk the leading dimension of p2ip (not referenced)
+
+
+
+ OUTPUT
+
+ ------
+
+ coef(nk) vector of spline coefficients
+
+ sz(n) vector of smoothed z-values
+
+ lev(n) vector of leverages
+
+ crit either ordinary or generalized CV score
+
+ spar if ispar != 1
+
+ lspar == lambda (a function of spar and the design)
+
+ iter number of iterations needed for spar search (if ispar != 1)
+
+ ier error indicator
+
+ ier = 0 ___ everything fine
+
+ ier = 1 ___ spar too small or too big
+
+ problem in cholesky decomposition
+
+
+
+ Working arrays/matrix
+
+ xwy X'Wy
+
+ hs0,hs1,hs2,hs3 the diagonals of the X'WX matrix
+
+ sg0,sg1,sg2,sg3 the diagonals of the Gram matrix SIGMA
+
+ abd (ld4,nk) [ X'WX + lambda*SIGMA ] in diagonal form
+
+ p1ip(ld4,nk) inner products between columns of L inverse
+
+ p2ip(ldnk,nk) all inner products between columns of L inverse
+
+ where L'L = [X'WX + lambda*SIGMA] NOT REFERENCED
+
+*/
+
+
+
+#define CRIT(FX) (*icrit == 3 ? FX - 3. : FX)
+
+ /* cancellation in (3 + eps) - 3, but still...informative */
+
+
+
+#define BIG_f (1e100)
+
+
+
+ /* c_Gold is the squared inverse of the golden ratio */
+
+ static const double c_Gold = 0.381966011250105151795413165634;
+
+ /* == (3. - sqrt(5.)) / 2. */
+
+
+
+ /* Local variables */
+
+ static double ratio;/* must be static (not needed in R) */
+
+
+
+ double a, b, d, e, p, q, r, u, v, w, x;
+
+ double ax, fu, fv, fw, fx, bx, xm;
+
+ double t1, t2, tol1, tol2;
+
+
+
+ int i, maxit;
+
+ Rboolean Fparabol = FALSE, tracing = (*ispar < 0);
+
+
+
+ /* unnecessary initializations to keep -Wall happy */
+
+ d = 0.; fu = 0.; u = 0.;
+
+ ratio = 1.;
+
+
+
+/* Compute SIGMA, X' W X, X' W z, trace ratio, s0, s1.
+
+
+
+ SIGMA -> sg0,sg1,sg2,sg3
+
+ X' W X -> hs0,hs1,hs2,hs3
+
+ X' W Z -> xwy
+
+*/
+
+
+
+/* trevor fixed this 4/19/88
+
+ * Note: sbart, i.e. stxwx() and sslvrg() {mostly, not always!}, use
+
+ * the square of the weights; the following rectifies that */
+
+ for (i = 0; i < *n; ++i)
+
+ if (ws[i] > 0.)
+
+ ws[i] = sqrt(ws[i]);
+
+
+
+ if (*isetup == 0) {
+
+ /* SIGMA[i,j] := Int B''(i,t) B''(j,t) dt {B(k,.) = k-th B-spline} */
+
+ F77_CALL(sgram)(sg0, sg1, sg2, sg3, knot, nk);
+
+ F77_CALL(stxwx)(xs, ys, ws, n,
+
+ knot, nk,
+
+ xwy,
+
+ hs0, hs1, hs2, hs3);
+
+ /* Compute ratio := tr(X' W X) / tr(SIGMA) */
+
+ t1 = t2 = 0.;
+
+ for (i = 3 - 1; i < (*nk - 3); ++i) {
+
+ t1 += hs0[i];
+
+ t2 += sg0[i];
+
+ }
+
+ ratio = t1 / t2;
+
+ *isetup = 1;
+
+ }
+
+/* Compute estimate */
+
+
+
+ if (*ispar == 1) { /* Value of spar supplied */
+
+ *lspar = ratio * R_pow(16., *spar * 6. - 2.);
+
+ F77_CALL(sslvrg)(penalt, dofoff, xs, ys, ws, ssw, n,
+
+ knot, nk,
+
+ coef, sz, lev, crit, icrit, lspar, xwy,
+
+ hs0, hs1, hs2, hs3,
+
+ sg0, sg1, sg2, sg3, abd,
+
+ p1ip, p2ip, ld4, ldnk, ier);
+
+ /* got through check 2 */
+
+ return;
+
+ }
+
+
+
+/* ELSE ---- spar not supplied --> compute it ! ---------------------------
+
+
+
+ Use Forsythe Malcom and Moler routine to MINIMIZE criterion
+
+ f denotes the value of the criterion
+
+
+
+ an approximation x to the point where f attains a minimum on
+
+ the interval (ax,bx) is determined.
+
+ */
+
+ ax = *lspar;
+
+ bx = *uspar;
+
+
+
+/* INPUT
+
+
+
+ ax left endpoint of initial interval
+
+ bx right endpoint of initial interval
+
+ f function subprogram which evaluates f(x) for any x
+
+ in the interval (ax,bx)
+
+ tol desired length of the interval of uncertainty of the final
+
+ result ( >= 0 )
+
+
+
+ OUTPUT
+
+
+
+ fmin abcissa approximating the point where f attains a minimum
+
+*/
+
+
+
+/*
+
+ The method used is a combination of golden section search and
+
+ successive parabolic interpolation. convergence is never much slower
+
+ than that for a fibonacci search. if f has a continuous second
+
+ derivative which is positive at the minimum (which is not at ax or
+
+ bx), then convergence is superlinear, and usually of the order of
+
+ about 1.324....
+
+ the function f is never evaluated at two points closer together
+
+ than eps*abs(fmin) + (tol/3), where eps is approximately the square
+
+ root of the relative machine precision. if f is a unimodal
+
+ function and the computed values of f are always unimodal when
+
+ separated by at least eps*abs(x) + (tol/3), then fmin approximates
+
+ the abcissa of the global minimum of f on the interval ax,bx with
+
+ an error less than 3*eps*abs(fmin) + tol. if f is not unimodal,
+
+ then fmin may approximate a local, but perhaps non-global, minimum to
+
+ the same accuracy.
+
+ this function subprogram is a slightly modified version of the
+
+ algol 60 procedure localmin given in richard brent, algorithms for
+
+ minimization without derivatives, prentice - hall, inc. (1973).
+
+
+
+ Double a,b,c,d,e,eps,xm,p,q,r,tol1,tol2,u,v,w
+
+ Double fu,fv,fw,fx,x
+
+*/
+
+
+
+/* eps is approximately the square root of the relative machine
+
+ precision.
+
+
+
+ - eps = 1e0
+
+ - 10 eps = eps/2e0
+
+ - tol1 = 1e0 + eps
+
+ - if (tol1 > 1e0) go to 10
+
+ - eps = sqrt(eps)
+
+ R Version <= 1.3.x had
+
+ eps = .000244 ( = sqrt(5.954 e-8) )
+
+ -- now eps is passed as argument
+
+*/
+
+
+
+ /* initialization */
+
+
+
+ maxit = *iter;
+
+ *iter = 0;
+
+ a = ax;
+
+ b = bx;
+
+ v = a + c_Gold * (b - a);
+
+ w = v;
+
+ x = v;
+
+ e = 0.;
+
+ *spar = x;
+
+ *lspar = ratio * R_pow(16., *spar * 6. - 2.);
+
+ F77_CALL(sslvrg)(penalt, dofoff, xs, ys, ws, ssw, n,
+
+ knot, nk,
+
+ coef, sz, lev, crit, icrit, lspar, xwy,
+
+ hs0, hs1, hs2, hs3,
+
+ sg0, sg1, sg2, sg3, abd,
+
+ p1ip, p2ip, ld4, ldnk, ier);
+
+ fx = *crit;
+
+ fv = fx;
+
+ fw = fx;
+
+
+
+/* main loop
+
+ --------- */
+
+ while(*ier == 0) { /* L20: */
+
+ xm = (a + b) * .5;
+
+ tol1 = *eps * fabs(x) + *tol / 3.;
+
+ tol2 = tol1 * 2.;
+
+ ++(*iter);
+
+
+
+ if(tracing) {
+
+ if(*iter == 1) {/* write header */
+
+ Rprintf("sbart (ratio = %15.8g) iterations;"
+
+ " initial tol1 = %12.6e :\n"
+
+ "%11s %14s %9s %11s Kind %11s %12s\n%s\n",
+
+ ratio, tol1, "spar",
+
+ ((*icrit == 1) ? "GCV" :
+
+ (*icrit == 2) ? "CV" :
+
+ (*icrit == 3) ?"(df0-df)^2" :
+
+ /*else (should not happen) */"?f?"),
+
+ "b - a", "e", "NEW lspar", "crit",
+
+ " ---------------------------------------"
+
+ "----------------------------------------");
+
+ }
+
+ Rprintf("%11.8f %14.9g %9.4e %11.5g", x, CRIT(fx), b - a, e);
+
+ Fparabol = FALSE;
+
+ }
+
+
+
+ /* Check the (somewhat peculiar) stopping criterion: note that
+
+ the RHS is negative as long as the interval [a,b] is not small:*/
+
+ if (fabs(x - xm) <= tol2 - (b - a) * .5 || *iter > maxit)
+
+ goto L_End;
+
+
+
+
+
+/* is golden-section necessary */
+
+
+
+ if (fabs(e) <= tol1 ||
+
+ /* if had Inf then go to golden-section */
+
+ fx >= BIG_f || fv >= BIG_f || fw >= BIG_f) goto L_GoldenSect;
+
+
+
+/* Fit Parabola */
+
+ if(tracing) { Rprintf(" FP"); Fparabol = TRUE; }
+
+
+
+ r = (x - w) * (fx - fv);
+
+ q = (x - v) * (fx - fw);
+
+ p = (x - v) * q - (x - w) * r;
+
+ q = (q - r) * 2.;
+
+ if (q > 0.)
+
+ p = -p;
+
+ q = fabs(q);
+
+ r = e;
+
+ e = d;
+
+
+
+/* is parabola acceptable? Otherwise do golden-section */
+
+
+
+ if (fabs(p) >= fabs(.5 * q * r) ||
+
+ q == 0.)
+
+ /* above line added by BDR;
+
+ * [the abs(.) >= abs() = 0 should have branched..]
+
+ * in FTN: COMMON above ensures q is NOT a register variable */
+
+
+
+ goto L_GoldenSect;
+
+
+
+ if (p <= q * (a - x) ||
+
+ p >= q * (b - x)) goto L_GoldenSect;
+
+
+
+
+
+
+
+/* Parabolic Interpolation step */
+
+
+
+ if(tracing) Rprintf(" PI ");
+
+ d = p / q;
+
+ if(!R_FINITE(d))
+
+ REprintf(" !FIN(d:=p/q): ier=%d, (v,w, p,q)= %g, %g, %g, %g\n",
+
+ *ier, v,w, p, q);
+
+ u = x + d;
+
+
+
+ /* f must not be evaluated too close to ax or bx */
+
+ if (u - a < tol2 ||
+
+ b - u < tol2) d = fsign(tol1, xm - x);
+
+
+
+ goto L50;
+
+ /*------*/
+
+
+
+ L_GoldenSect: /* a golden-section step */
+
+
+
+ if(tracing) Rprintf(" GS%s ", Fparabol ? "" : " --");
+
+
+
+ if (x >= xm) e = a - x;
+
+ else/* x < xm*/ e = b - x;
+
+ d = c_Gold * e;
+
+
+
+
+
+ L50:
+
+ u = x + ((fabs(d) >= tol1) ? d : fsign(tol1, d));
+
+ /* tol1 check : f must not be evaluated too close to x */
+
+
+
+ *spar = u;
+
+ *lspar = ratio * R_pow(16., *spar * 6. - 2.);
+
+ F77_CALL(sslvrg)(penalt, dofoff, xs, ys, ws, ssw, n,
+
+ knot, nk,
+
+ coef, sz, lev, crit, icrit, lspar, xwy,
+
+ hs0, hs1, hs2, hs3,
+
+ sg0, sg1, sg2, sg3, abd,
+
+ p1ip, p2ip, ld4, ldnk, ier);
+
+ fu = *crit;
+
+ if(tracing) Rprintf("%11g %12g\n", *lspar, CRIT(fu));
+
+ if(!R_FINITE(fu)) {
+
+ REprintf("spar-finding: non-finite value %g; using BIG value\n", fu);
+
+ fu = 2. * BIG_f;
+
+ }
+
+
+
+/* update a, b, v, w, and x */
+
+
+
+ if (fu <= fx) {
+
+ if (u >= x) a = x; else b = x;
+
+
+
+ v = w; fv = fw;
+
+ w = x; fw = fx;
+
+ x = u; fx = fu;
+
+ }
+
+ else {
+
+ if (u < x) a = u; else b = u;
+
+
+
+ if (fu <= fw || w == x) { /* L70: */
+
+ v = w; fv = fw;
+
+ w = u; fw = fu;
+
+ } else if (fu <= fv || v == x || v == w) { /* L80: */
+
+ v = u; fv = fu;
+
+ }
+
+ }
+
+ }/* end main loop -- goto L20; */
+
+
+
+ L_End:
+
+ if(tracing) Rprintf(" >>> %12g %12g\n", *lspar, CRIT(fx));
+
+ *spar = x;
+
+ *crit = fx;
+
+ return;
+
+} /* sbart */
+
diff --git a/src/sgram.f b/src/sgram.f
new file mode 100644
index 0000000..0ce44d5
--- /dev/null
+++ b/src/sgram.f
@@ -0,0 +1,143 @@
+C Output from Public domain Ratfor, version 1.0
+
+C PURPOSE
+C Calculation of the cubic B-spline smoothness prior
+C for "usual" interior knot setup.
+C Uses BSPVD and INTRV in the CMLIB
+C sgm[0-3](nb) Symmetric matrix
+C whose (i,j)'th element contains the integral of
+C B''(i,.) B''(j,.) , i=1,2 ... nb and j=i,...nb.
+C Only the upper four diagonals are computed.
+
+ subroutine sgram(sg0,sg1,sg2,sg3,tb,nb)
+
+c implicit none
+C indices
+ integer nb
+ DOUBLE precision sg0(nb),sg1(nb),sg2(nb),sg3(nb), tb(nb+4)
+c -------------
+ integer ileft,mflag, i,ii,jj, lentb
+ DOUBLE precision vnikx(4,3),work(16),yw1(4),yw2(4), wpt
+c
+ integer interv
+ external interv
+
+ lentb=nb+4
+C Initialise the sigma vectors
+ do 1 i=1,nb
+ sg0(i)=0.
+ sg1(i)=0.
+ sg2(i)=0.
+ sg3(i)=0.
+ 1 continue
+
+ ileft = 1
+ do 2 i=1,nb
+C Calculate a linear approximation to the
+C second derivative of the non-zero B-splines
+C over the interval [tb(i),tb(i+1)].
+C call intrv(tb(1),(nb+1),tb(i),ilo,ileft,mflag)
+ ileft = interv(tb(1), nb+1,tb(i), 0,0, ileft, mflag)
+C Left end second derivatives
+C call bspvd (tb,4,3,tb(i),ileft,4,vnikx,work)
+ call bsplvd (tb,lentb,4,tb(i),ileft,work,vnikx,3)
+C Put values into yw1
+ do 4 ii=1,4
+ yw1(ii) = vnikx(ii,3)
+ 4 continue
+
+C Right end second derivatives
+C call bspvd (tb,4,3,tb(i+1),ileft,4,vnikx,work)
+ call bsplvd (tb,lentb,4,tb(i+1),ileft,work,vnikx,3)
+
+C Slope*(length of interval) in Linear Approximation to B''
+ do 6 ii=1,4
+ yw2(ii) = vnikx(ii,3) - yw1(ii)
+ 6 continue
+
+ wpt = tb(i+1) - tb(i)
+C Calculate Contributions to the sigma vectors
+ if(ileft.ge.4) then
+ do 10 ii=1,4
+ jj=ii
+ sg0(ileft-4+ii) = sg0(ileft-4+ii) +
+ & wpt*(yw1(ii)*yw1(jj)+
+ & (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50
+ & + yw2(ii)*yw2(jj)*.3330)
+ jj=ii+1
+ if(jj.le.4)then
+ sg1(ileft+ii-4) = sg1(ileft+ii-4) +
+ & wpt* (yw1(ii)*yw1(jj) +
+ * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50
+ & +yw2(ii)*yw2(jj)*.3330 )
+ endif
+ jj=ii+2
+ if(jj.le.4)then
+ sg2(ileft+ii-4) = sg2(ileft+ii-4) +
+ & wpt* (yw1(ii)*yw1(jj) +
+ * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50
+ & +yw2(ii)*yw2(jj)*.3330 )
+ endif
+ jj=ii+3
+ if(jj.le.4)then
+ sg3(ileft+ii-4) = sg3(ileft+ii-4) +
+ & wpt* (yw1(ii)*yw1(jj) +
+ * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50
+ & +yw2(ii)*yw2(jj)*.3330 )
+ endif
+ 10 continue
+
+ else if(ileft.eq.3)then
+ do 20 ii=1,3
+ jj=ii
+ sg0(ileft-3+ii) = sg0(ileft-3+ii) +
+ & wpt* (yw1(ii)*yw1(jj) +
+ * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50
+ & +yw2(ii)*yw2(jj)*.3330 )
+ jj=ii+1
+ if(jj.le.3)then
+ sg1(ileft+ii-3) = sg1(ileft+ii-3) +
+ & wpt* (yw1(ii)*yw1(jj) +
+ * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50
+ & +yw2(ii)*yw2(jj)*.3330 )
+ endif
+ jj=ii+2
+ if(jj.le.3)then
+ sg2(ileft+ii-3) = sg2(ileft+ii-3) +
+ & wpt* (yw1(ii)*yw1(jj) +
+ * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50
+ & +yw2(ii)*yw2(jj)*.3330 )
+ endif
+ 20 continue
+
+ else if(ileft.eq.2)then
+ do 28 ii=1,2
+ jj=ii
+ sg0(ileft-2+ii) = sg0(ileft-2+ii) +
+ & wpt* (yw1(ii)*yw1(jj) +
+ * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50
+ & +yw2(ii)*yw2(jj)*.3330 )
+ jj=ii+1
+ if(jj.le.2)then
+ sg1(ileft+ii-2) = sg1(ileft+ii-2) +
+ & wpt* (yw1(ii)*yw1(jj) +
+ * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50
+ & +yw2(ii)*yw2(jj)*.3330 )
+ endif
+ 28 continue
+
+ else if(ileft.eq.1)then
+ do 34 ii=1,1
+ jj=ii
+ sg0(ileft-1+ii) = sg0(ileft-1+ii) +
+ & wpt* (yw1(ii)*yw1(jj) +
+ * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50
+ & +yw2(ii)*yw2(jj)*.3330 )
+ 34 continue
+
+ endif
+ 2 continue
+
+ return
+ end
+
diff --git a/src/sinerp.f b/src/sinerp.f
new file mode 100644
index 0000000..061aee1
--- /dev/null
+++ b/src/sinerp.f
@@ -0,0 +1,98 @@
+C Output from Public domain Ratfor, version 1.0
+ subroutine sinerp(abd,ld4,nk,p1ip,p2ip,ldnk,flag)
+c
+C Purpose : Computes Inner Products between columns of L^{-1}
+C where L = abd is a Banded Matrix with 3 subdiagonals
+
+C The algorithm works in two passes:
+C
+C Pass 1 computes (cj,ck) k=j,j-1,j-2,j-3 ; j=nk, .. 1
+C Pass 2 computes (cj,ck) k <= j-4 (If flag == 1 ).
+C
+C A refinement of Elden's trick is used.
+c Args
+ integer ld4,nk,ldnk,flag
+ DOUBLE precision abd(ld4,nk),p1ip(ld4,nk), p2ip(ldnk,nk)
+c Locals
+ integer i,j,k
+ DOUBLE precision wjm3(3),wjm2(2),wjm1(1),c0,c1,c2,c3
+c
+c unnecessary initialization of c1 c2 c3 to keep g77 -Wall happy
+c
+ c1 = 0.0d0
+ c2 = 0.0d0
+ c3 = 0.0d0
+C
+C Pass 1
+ wjm3(1)=0d0
+ wjm3(2)=0d0
+ wjm3(3)=0d0
+ wjm2(1)=0d0
+ wjm2(2)=0d0
+ wjm1(1)=0d0
+ do 100 i=1,nk
+ j=nk-i+1
+ c0 = 1d0/abd(4,j)
+ if(j.le.nk-3)then
+ c1 = abd(1,j+3)*c0
+ c2 = abd(2,j+2)*c0
+ c3 = abd(3,j+1)*c0
+ else if(j.eq.nk-2)then
+ c1 = 0d0
+ c2 = abd(2,j+2)*c0
+ c3 = abd(3,j+1)*c0
+ else if(j.eq.nk-1)then
+ c1 = 0d0
+ c2 = 0d0
+ c3 = abd(3,j+1)*c0
+ else if(j.eq.nk)then
+ c1 = 0d0
+ c2 = 0d0
+ c3 = 0d0
+ endif
+ p1ip(1,j) = 0d0- (c1*wjm3(1)+c2*wjm3(2)+c3*wjm3(3))
+ p1ip(2,j) = 0d0- (c1*wjm3(2)+c2*wjm2(1)+c3*wjm2(2))
+ p1ip(3,j) = 0d0- (c1*wjm3(3)+c2*wjm2(2)+c3*wjm1(1))
+ p1ip(4,j) = c0**2 + c1**2*wjm3(1) + 2d0*c1*c2*wjm3(2)+
+ & 2d0*c1*c3*wjm3(3) + c2**2*wjm2(1) + 2d0*c2*c3*wjm2(2) +
+ & c3**2*wjm1(1)
+ wjm3(1)=wjm2(1)
+ wjm3(2)=wjm2(2)
+ wjm3(3)=p1ip(2,j)
+ wjm2(1)=wjm1(1)
+ wjm2(2)=p1ip(3,j)
+ wjm1(1)=p1ip(4,j)
+ 100 continue
+
+ if(flag.ne.0)then
+
+C ____ Pass 2 _____
+
+C Compute p2ip
+ do 120 i=1,nk
+ j=nk-i+1
+C for(k=1;k<=4 & j+k-1<=nk;k=k+1) { p2ip(.) = .. }:
+ do 160 k=1,4
+ if(j+k-1 .gt. nk)goto 120
+ p2ip(j,j+k-1) = p1ip(5-k,j)
+ 160 continue
+ 120 continue
+
+ do 170 i=1,nk
+ j=nk-i+1
+c for(k=j-4;k>=1;k=k-1){
+ if(j-4 .ge. 1) then
+ do 210 k= j-4,1, -1
+ c0 = 1d0/abd(4,k)
+ c1 = abd(1,k+3)*c0
+ c2 = abd(2,k+2)*c0
+ c3 = abd(3,k+1)*c0
+ p2ip(k,j)= 0d0 - ( c1*p2ip(k+3,j) + c2*p2ip(k+2,j) +
+ & c3*p2ip(k+1,j) )
+ 210 continue
+ endif
+ 170 continue
+ endif
+ return
+ end
+
diff --git a/src/splsm.f b/src/splsm.f
new file mode 100644
index 0000000..5d2a480
--- /dev/null
+++ b/src/splsm.f
@@ -0,0 +1,188 @@
+C Output from Public domain Ratfor, version 1.0
+ subroutine sknotl(x,n,knot,k)
+ implicit double precision(a-h,o-z)
+ double precision x(n),knot(n+6),a1,a2,a3,a4
+ integer n,k,ndk,j
+ a1 = log(50d0)/log(2d0)
+ a2 = log(100d0)/log(2d0)
+ a3 = log(140d0)/log(2d0)
+ a4 = log(200d0)/log(2d0)
+ if(n.lt.50)then
+ ndk = n
+ else
+ if(n.ge.50 .and. n.lt.200)then
+ ndk = 2.**(a1+(a2-a1)*(n-50.)/150.)
+ else
+ if(n.ge.200 .and. n.lt.800)then
+ ndk = 2.**(a2+(a3-a2)*(n-200.)/600.)
+ else
+ if(n.ge.800 .and. n.lt.3200)then
+ ndk = 2.**(a3+(a4-a3)*(n-800.)/2400.)
+ else
+ if(n.ge.3200)then
+ ndk = 200. + float(n-3200)**.2
+ endif
+ endif
+ endif
+ endif
+ endif
+ k = ndk + 6
+ do23010 j=1,3
+ knot(j) = x(1)
+23010 continue
+23011 continue
+ do23012 j=1,ndk
+ knot(j+3) = x( 1 + (j-1)*(n-1)/(ndk-1) )
+23012 continue
+23013 continue
+ do23014 j=1,3
+ knot(ndk+3+j) = x(n)
+23014 continue
+23015 continue
+ return
+ end
+ subroutine splsm(x,y,w,n,match,nef,spar,dof,smo,s0,cov,ifcov,work)
+ implicit double precision(a-h,o-z)
+ double precision x(1),y(1),w(1),spar,dof,smo(1),s0,cov(1),work(1)
+ integer n,match(1),nef
+ integer ifcov
+ call splsm1(x,y,w,n,match,nef,spar,dof,smo,s0,cov,ifcov, work(1),
+ *work(nef+2),work(2*nef+3),work(3*nef+4), work(3*nef+n+10))
+ return
+ end
+ subroutine splsm1(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov, xin
+ *,yin,win,knot, work)
+ implicit double precision(a-h,o-z)
+ double precision x(1),y(1),w(1),spar,dof,smo(1),s0,lev(1),work(1)
+ integer n,match(1),nef
+ integer ifcov
+ double precision xin(nef+1),yin(nef+1),win(nef+1),knot(nef+6)
+ integer nk,ldnk,ld4,k
+ double precision xmin,xrange
+ call suff(n,nef,match,x,y,w,xin,yin,win,work(1))
+ xmin=xin(1)
+ xrange=xin(nef)-xin(1)
+ do23016 i=1,nef
+ xin(i)=(xin(i)-xmin)/xrange
+23016 continue
+23017 continue
+ call sknotl(xin,nef,knot,k)
+ nk=k-4
+ ld4=4
+ ldnk=1
+ call splsm2(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov, xin,yin,w
+ *in,knot, work(1), work(nk+1), work(nk+nef+2),work(nk+2*nef+3), wor
+ *k(2*nk+2*nef+3),work(3*nk+2*nef+3),work(4*nk+2*nef+3), work(5*nk+2
+ **nef+3), work(6*nk+2*nef+3),work(7*nk+2*nef+3),work(8*nk+2*nef+3),
+ * work(9*nk+2*nef+3), work(10*nk+2*nef+3),work((10+ld4)*nk+2*nef+3)
+ *, work((10+2*ld4)*nk+2*nef+3), ld4,ldnk,nk)
+ return
+ end
+ subroutine splsm2(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov, xin
+ *,yin,win,knot, coef,sout,levout,xwy, hs0,hs1,hs2,hs3, sg0,sg1,sg2,
+ *sg3, abd,p1ip,p2ip,ld4,ldnk,nk)
+ implicit double precision(a-h,o-z)
+ double precision x(1),y(1),w(1),spar,dof,smo(1),s0,lev(1)
+ integer n,match(1),nef
+ integer nk,ldnk,ld4
+ integer ifcov
+ double precision xin(nef+1),yin(nef+1),win(nef+1),knot(nk+4)
+ double precision coef(nk),sout(nef+1),levout(nef+1),xwy(nk), hs0(n
+ *k),hs1(nk),hs2(nk),hs3(nk), sg0(nk),sg1(nk),sg2(nk),sg3(nk), abd(l
+ *d4,nk),p1ip(ld4,nk),p2ip(ldnk,1)
+ integer ispar,icrit,isetup,ier
+ double precision lspar,uspar,tol,penalt, sumwin,dofoff,crit,xbar,d
+ *sum,xsbar
+ double precision yssw, eps
+ integer maxit
+ double precision wmean
+ crit=0d0
+ if(dof .le. 0d0)then
+ ispar=1
+ icrit=3
+ dofoff=0d0
+ else
+ if( dof .lt. 1d0 )then
+ dof=1d0
+ endif
+ ispar=0
+ icrit=3
+ dofoff=dof+1d0
+ endif
+ isetup=0
+ ier=1
+ penalt=1d0
+ lspar= -1.5
+ uspar= 1.5
+ tol=1d-4
+ eps=2d-8
+ maxit=200
+ do23022 i=1,nef
+ sout(i)=yin(i)*yin(i)
+23022 continue
+23023 continue
+ sumwin=0d0
+ do23024 i=1,nef
+ sumwin=sumwin+win(i)
+23024 continue
+23025 continue
+ yssw=wmean(nef,sout,win)
+ s0=wmean(n,y,w)
+ yssw=yssw*(sumwin-s0*s0)
+ call sbart(penalt,dofoff,xin,yin,win,yssw,nef,knot,nk, coef,sout,l
+ *evout,crit, icrit,spar,ispar,maxit, lspar,uspar,tol,eps, isetup, x
+ *wy, hs0,hs1,hs2,hs3, sg0,sg1,sg2,sg3, abd,p1ip,p2ip,ld4,ldnk,ier)
+ do23026 i=1,nef
+ win(i)=win(i)*win(i)
+23026 continue
+23027 continue
+ sbar=wmean(nef,sout,win)
+ xbar=wmean(nef,xin,win)
+ do23028 i=1,nef
+ lev(i)=(xin(i)-xbar)*sout(i)
+23028 continue
+23029 continue
+ xsbar=wmean(nef,lev,win)
+ do23030 i=1,nef
+ lev(i)=(xin(i)-xbar)**2
+23030 continue
+23031 continue
+ dsum=wmean(nef,lev,win)
+ do23032 i=1,nef
+ if(win(i).gt.0d0)then
+ lev(i)=levout(i)/win(i)-1d0/sumwin -lev(i)/(sumwin*dsum)
+ else
+ lev(i)=0d0
+ endif
+23032 continue
+23033 continue
+ dof=0d0
+ do23036 i=1,nef
+ dof=dof+lev(i)*win(i)
+23036 continue
+23037 continue
+ dof=dof+1d0
+ do23038 i=1,nef
+ sout(i)=sout(i)-sbar -(xin(i)-xbar)*xsbar/dsum
+23038 continue
+23039 continue
+ call unpck(n,nef,match,sout,smo)
+ return
+ end
+ double precision function wmean(n,y,w)
+ integer n
+ double precision y(n),w(n),wtot,wsum
+ wtot=0d0
+ wsum=0d0
+ do23040 i=1,n
+ wsum=wsum+y(i)*w(i)
+ wtot=wtot+w(i)
+23040 continue
+23041 continue
+ if(wtot .gt. 0d0)then
+ wmean=wsum/wtot
+ else
+ wmean=0d0
+ endif
+ return
+ end
diff --git a/src/sslvrg.f b/src/sslvrg.f
new file mode 100644
index 0000000..6646b33
--- /dev/null
+++ b/src/sslvrg.f
@@ -0,0 +1,136 @@
+C Output from Public domain Ratfor, version 1.0
+ subroutine sslvrg(penalt,dofoff,x,y,w,ssw, n, knot,nk,coef,
+ * sz,lev, crit,icrit, lambda, xwy, hs0,hs1,hs2,hs3,
+ * sg0,sg1,sg2,sg3, abd,p1ip,p2ip,ld4,ldnk,info)
+
+C Purpose :
+C Compute smoothing spline for smoothing parameter lambda
+C and compute one of three `criteria' (OCV , GCV , "df match").
+C See comments in ./sbart.f from which this is called
+
+ integer n,nk,icrit,ld4,ldnk,info
+ DOUBLE precision penalt,dofoff,x(n),y(n),w(n),ssw,
+ & knot(nk+4), coef(nk),sz(n),lev(n), crit, lambda,
+ * xwy(nk), hs0(nk),hs1(nk),hs2(nk),hs3(nk),
+ * sg0(nk),sg1(nk),sg2(nk),sg3(nk), abd(ld4,nk),
+ & p1ip(ld4,nk),p2ip(ldnk,nk)
+
+ EXTERNAL bvalue
+ double precision bvalue
+C local variables
+ double precision vnikx(4,1),work(16)
+ integer i,icoef,ileft,j,mflag, lenkno
+ double precision b0,b1,b2,b3,eps, xv,rss,df, sumw
+c
+ integer interv
+ external interv
+
+ lenkno = nk+4
+ ileft = 1
+ eps = 1d-11
+
+C compute the coefficients coef() of estimated smooth
+
+ do 1 i=1,nk
+ coef(i) = xwy(i)
+ abd(4,i) = hs0(i)+lambda*sg0(i)
+ 1 continue
+
+ do 4 i=1,(nk-1)
+ abd(3,i+1) = hs1(i)+lambda*sg1(i)
+ 4 continue
+
+ do 6 i=1,(nk-2)
+ 6 abd(2,i+2) = hs2(i)+lambda*sg2(i)
+
+ do 8 i=1,(nk-3)
+ 8 abd(1,i+3) = hs3(i)+lambda*sg3(i)
+
+c factorize banded matrix abd:
+ call dpbfa(abd,ld4,nk,3,info)
+ if(info.ne.0) then
+C matrix could not be factorized -> ier := info
+ return
+ endif
+c solve linear system (from factorize abd):
+ call dpbsl(abd,ld4,nk,3,coef)
+
+C Value of smooth at the data points
+ icoef = 1
+ do 12 i=1,n
+ xv = x(i)
+ 12 sz(i) = bvalue(knot,lenkno,coef, nk,4,xv,0)
+
+C Compute the criterion function if requested
+
+ if(icrit .eq. 0)then
+ return
+ else
+C --- Ordinary or Generalized CV or "df match" ---
+
+C Get Leverages First
+ call sinerp(abd,ld4,nk,p1ip,p2ip,ldnk,0)
+ do 16 i=1,n
+ xv = x(i)
+ ileft = interv(knot(1), nk+1, xv, 0,0, ileft, mflag)
+ if(mflag .eq. -1) then
+ ileft = 4
+ xv = knot(4)+eps
+ else if(mflag .eq. 1) then
+ ileft = nk
+ xv = knot(nk+1) - eps
+ endif
+ j=ileft-3
+C call bspvd(knot,4,1,xv,ileft,4,vnikx,work)
+ call bsplvd(knot,lenkno,4,xv,ileft,work,vnikx,1)
+ b0=vnikx(1,1)
+ b1=vnikx(2,1)
+ b2=vnikx(3,1)
+ b3=vnikx(4,1)
+ lev(i) = (
+ & p1ip(4,j)*b0**2 + 2.*p1ip(3,j)*b0*b1 +
+ * 2.*p1ip(2,j)*b0*b2 + 2.*p1ip(1,j)*b0*b3 +
+ * p1ip(4,j+1)*b1**2 + 2.*p1ip(3,j+1)*b1*b2 +
+ * 2.*p1ip(2,j+1)*b1*b3 + p1ip(4,j+2)*b2**2 +
+ & 2.*p1ip(3,j+2)*b2*b3 + p1ip(4,j+3)*b3**2
+ & )*w(i)**2
+ 16 continue
+
+C Evaluate Criterion
+
+ if(icrit .eq. 1)then
+C Generalized CV
+ rss = ssw
+ df = 0d0
+ sumw = 0d0
+c w(i) are sqrt( wt[i] ) weights scaled in ../R/smspline.R such
+c that sumw = number of observations with w(i) > 0
+ do 24 i=1,n
+ rss = rss + ((y(i)-sz(i))*w(i))**2
+ df = df + lev(i)
+ sumw = sumw + w(i)**2
+ 24 continue
+
+ crit = (rss/sumw)/((1d0-(dofoff + penalt*df)/sumw)**2)
+c call dblepr("spar", 4, spar, 1)
+c call dblepr("crit", 4, crit, 1)
+
+ else if(icrit .eq. 2) then
+C Ordinary CV
+ crit = 0d0
+ do 30 i = 1,n
+ 30 crit = crit + (((y(i)-sz(i))*w(i))/(1-lev(i)))**2
+ crit = crit/n
+c call dblepr("spar", 4, spar, 1)
+c call dblepr("crit", 4, crit, 1)
+ else
+C df matching
+ crit = 0d0
+ do 32 i=1,n
+ 32 crit = crit+lev(i)
+ crit = 3 + (dofoff-crit)**2
+ endif
+ return
+ endif
+C Criterion evaluation
+ end
diff --git a/src/stxwx.f b/src/stxwx.f
new file mode 100644
index 0000000..b4b5f0a
--- /dev/null
+++ b/src/stxwx.f
@@ -0,0 +1,65 @@
+C Output from Public domain Ratfor, version 1.0
+ subroutine stxwx(x,z,w,k,xknot,n,y,hs0,hs1,hs2,hs3)
+
+c implicit none
+ integer k,n
+ DOUBLE precision x(k),z(k),w(k), xknot(n+4),y(n),
+ & hs0(n),hs1(n),hs2(n),hs3(n)
+C local
+ DOUBLE precision eps,vnikx(4,1),work(16)
+ integer lenxk, i,j, ileft,mflag
+c
+ integer interv
+ external interv
+
+ lenxk=n+4
+C Initialise the output vectors
+ do 1 i=1,n
+ y(i)=0d0
+ hs0(i)=0d0
+ hs1(i)=0d0
+ hs2(i)=0d0
+ hs3(i)=0d0
+ 1 continue
+
+C Compute X' W^2 X -> hs0,hs1,hs2,hs3 and X' W^2 Z -> y
+C Note that here the weights w(i) == sqrt(wt[i]) where wt[] where original weights
+ ileft=1
+ eps= .1d-9
+
+ do 100 i=1,k
+ ileft= interv(xknot(1), n+1, x(i), 0,0, ileft, mflag)
+C if(mflag==-1) {write(6,'("Error in hess ",i2)')mflag;stop}
+C if(mflag==-1) {return}
+ if(mflag.eq. 1)then
+ if(x(i).le.(xknot(ileft)+eps))then
+ ileft=ileft-1
+ else
+ return
+ endif
+C else{write(6,'("Error in hess ",i2)')mflag;stop}}
+ endif
+ call bsplvd (xknot,lenxk,4,x(i),ileft,work,vnikx,1)
+
+ j= ileft-4+1
+ y(j) = y(j)+w(i)**2*z(i)*vnikx(1,1)
+ hs0(j)=hs0(j)+w(i)**2*vnikx(1,1)**2
+ hs1(j)=hs1(j)+w(i)**2*vnikx(1,1)*vnikx(2,1)
+ hs2(j)=hs2(j)+w(i)**2*vnikx(1,1)*vnikx(3,1)
+ hs3(j)=hs3(j)+w(i)**2*vnikx(1,1)*vnikx(4,1)
+ j= ileft-4+2
+ y(j) = y(j)+w(i)**2*z(i)*vnikx(2,1)
+ hs0(j)=hs0(j)+w(i)**2*vnikx(2,1)**2
+ hs1(j)=hs1(j)+w(i)**2*vnikx(2,1)*vnikx(3,1)
+ hs2(j)=hs2(j)+w(i)**2*vnikx(2,1)*vnikx(4,1)
+ j= ileft-4+3
+ y(j) = y(j)+w(i)**2*z(i)*vnikx(3,1)
+ hs0(j)=hs0(j)+w(i)**2*vnikx(3,1)**2
+ hs1(j)=hs1(j)+w(i)**2*vnikx(3,1)*vnikx(4,1)
+ j= ileft-4+4
+ y(j) = y(j)+w(i)**2*z(i)*vnikx(4,1)
+ hs0(j)=hs0(j)+w(i)**2*vnikx(4,1)**2
+ 100 continue
+
+ return
+ end
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/r-cran-gam.git
More information about the debian-science-commits
mailing list