From bab748aa77ac887db1e48cc26982fa80303f405e Mon Sep 17 00:00:00 2001
From: stepan <stepan.sindelar@oracle.com>
Date: Wed, 29 Nov 2017 14:34:13 +0100
Subject: [PATCH] add more GNU R sources from stats package
---
.../patch/src/library/stats/src/HoltWinters.c | 99 +
.../patch/src/library/stats/src/Srunmed.c | 214 +
.../patch/src/library/stats/src/Trunmed.c | 378 +
.../gnur/patch/src/library/stats/src/ansari.c | 157 +
.../gnur/patch/src/library/stats/src/arima.c | 1125 ++
.../patch/src/library/stats/src/bandwidths.c | 171 +
.../gnur/patch/src/library/stats/src/burg.c | 82 +
.../gnur/patch/src/library/stats/src/d2x2xk.c | 65 +
.../gnur/patch/src/library/stats/src/family.c | 155 +
.../gnur/patch/src/library/stats/src/fexact.c | 2077 +++
.../gnur/patch/src/library/stats/src/filter.c | 156 +
.../patch/src/library/stats/src/kendall.c | 110 +
.../gnur/patch/src/library/stats/src/ks.c | 265 +
.../patch/src/library/stats/src/ksmooth.c | 109 +
.../gnur/patch/src/library/stats/src/line.c | 133 +
.../gnur/patch/src/library/stats/src/loglin.c | 392 +
.../gnur/patch/src/library/stats/src/lowess.c | 306 +
.../gnur/patch/src/library/stats/src/mAR.c | 994 ++
.../gnur/patch/src/library/stats/src/pacf.c | 477 +
.../patch/src/library/stats/src/portsrc.f | 12378 ++++++++++++++++
.../gnur/patch/src/library/stats/src/prho.c | 157 +
.../patch/src/library/stats/src/rWishart.c | 119 +
.../gnur/patch/src/library/stats/src/smooth.c | 312 +
.../gnur/patch/src/library/stats/src/starma.c | 521 +
.../gnur/patch/src/library/stats/src/swilk.c | 214 +
25 files changed, 21166 insertions(+)
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/HoltWinters.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Srunmed.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Trunmed.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ansari.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/arima.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/bandwidths.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/burg.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/d2x2xk.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/family.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/fexact.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/filter.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/kendall.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ks.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ksmooth.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/line.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/loglin.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/lowess.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/mAR.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/pacf.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/portsrc.f
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/prho.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/rWishart.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/smooth.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/starma.c
create mode 100644 com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/swilk.c
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/HoltWinters.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/HoltWinters.c
new file mode 100644
index 0000000000..6241fbfa08
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/HoltWinters.c
@@ -0,0 +1,99 @@
+/* R : A Computer Language for Statistical Data Analysis
+ *
+ * Copyright (C) 2003-7 The R Core Team
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/.
+ */
+
+/* Originally contributed by David Meyer */
+
+#include <stdlib.h>
+#include <string.h> // memcpy
+
+#include <R.h>
+#include "ts.h"
+
+void HoltWinters (double *x,
+ int *xl,
+ double *alpha,
+ double *beta,
+ double *gamma,
+ int *start_time,
+ int *seasonal,
+ int *period,
+ int *dotrend,
+ int *doseasonal,
+
+ double *a,
+ double *b,
+ double *s,
+
+ /* return values */
+ double *SSE,
+ double *level,
+ double *trend,
+ double *season
+ )
+
+{
+ double res = 0, xhat = 0, stmp = 0;
+ int i, i0, s0;
+
+ /* copy start values to the beginning of the vectors */
+ level[0] = *a;
+ if (*dotrend == 1) trend[0] = *b;
+ if (*doseasonal == 1) memcpy(season, s, *period * sizeof(double));
+
+ for (i = *start_time - 1; i < *xl; i++) {
+ /* indices for period i */
+ i0 = i - *start_time + 2;
+ s0 = i0 + *period - 1;
+
+ /* forecast *for* period i */
+ xhat = level[i0 - 1] + (*dotrend == 1 ? trend[i0 - 1] : 0);
+ stmp = *doseasonal == 1 ? season[s0 - *period] : (*seasonal != 1);
+ if (*seasonal == 1)
+ xhat += stmp;
+ else
+ xhat *= stmp;
+
+ /* Sum of Squared Errors */
+ res = x[i] - xhat;
+ *SSE += res * res;
+
+ /* estimate of level *in* period i */
+ if (*seasonal == 1)
+ level[i0] = *alpha * (x[i] - stmp)
+ + (1 - *alpha) * (level[i0 - 1] + trend[i0 - 1]);
+ else
+ level[i0] = *alpha * (x[i] / stmp)
+ + (1 - *alpha) * (level[i0 - 1] + trend[i0 - 1]);
+
+ /* estimate of trend *in* period i */
+ if (*dotrend == 1)
+ trend[i0] = *beta * (level[i0] - level[i0 - 1])
+ + (1 - *beta) * trend[i0 - 1];
+
+ /* estimate of seasonal component *in* period i */
+ if (*doseasonal == 1) {
+ if (*seasonal == 1)
+ season[s0] = *gamma * (x[i] - level[i0])
+ + (1 - *gamma) * stmp;
+ else
+ season[s0] = *gamma * (x[i] / level[i0])
+ + (1 - *gamma) * stmp;
+ }
+ }
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Srunmed.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Srunmed.c
new file mode 100644
index 0000000000..0efdfe21df
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Srunmed.c
@@ -0,0 +1,214 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 1995--2002 Martin Maechler <maechler@stat.math.ethz.ch>
+ * Copyright (C) 2003 The R Foundation
+ * Copyright (C) 2012-2016 The R Core Team
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/
+ */
+
+#include "modreg.h"
+
+#include "Trunmed.c"
+
+static void Srunmed(double* y, double* smo, R_xlen_t n, int bw,
+ int end_rule, int debug)
+{
+/*
+ * Computes "Running Median" smoother with medians of 'band'
+
+ * Input:
+ * y(n) - responses in order of increasing predictor values
+ * n - number of observations
+ * bw - span of running medians (MUST be ODD !!)
+ * end_rule -- 0: Keep original data at ends {j; j < b2 | j > n-b2}
+ * -- 1: Constant ends = median(y[1],..,y[bw]) "robust"
+ * Output:
+ * smo(n) - smoothed responses
+
+ * NOTE: The 'end' values are just copied !! this is fast but not too nice !
+ */
+
+/* Local variables */
+ double rmed, rmin, temp, rnew, yout, yi;
+ double rbe, rtb, rse, yin, rts;
+ int imin, ismo, i, j, first, last, band2, kminus, kplus;
+
+
+ double *scrat = (double *) R_alloc(bw, sizeof(double));
+ /*was malloc( (unsigned) bw * sizeof(double));*/
+
+ if(bw > n)
+ error(_("bandwidth/span of running medians is larger than n"));
+
+/* 1. Compute 'rmed' := Median of the first 'band' values
+ ======================================================== */
+
+ for (int i = 0; i < bw; ++i)
+ scrat[i] = y[i];
+
+ /* find minimal value rmin = scrat[imin] <= scrat[j] */
+ rmin = scrat[0]; imin = 0;
+ for (int i = 1; i < bw; ++i)
+ if (scrat[i] < rmin) {
+ rmin = scrat[i]; imin = i;
+ }
+ /* swap scrat[0] <-> scrat[imin] */
+ temp = scrat[0]; scrat[0] = rmin; scrat[imin] = temp;
+ /* sort the rest of of scrat[] by bubble (?) sort -- */
+ for (int i = 2; i < bw; ++i) {
+ if (scrat[i] < scrat[i - 1]) {/* find the proper place for scrat[i] */
+ temp = scrat[i];
+ j = i;
+ do {
+ scrat[j] = scrat[j - 1];
+ --j;
+ } while (scrat[j - 1] > temp); /* now: scrat[j-1] <= temp */
+ scrat[j] = temp;
+ }
+ }
+
+ band2 = bw / 2;
+ rmed = scrat[band2];/* == Median( y[(1:band2)-1] ) */
+ /* "malloc" had free( (char*) scrat);*/ /*-- release scratch memory --*/
+
+ if(end_rule == 0) { /*-- keep DATA at end values */
+ for (i = 0; i < band2; ++i)
+ smo[i] = y[i];
+ }
+ else { /* if(end_rule == 1) copy median to CONSTANT end values */
+ for (i = 0; i < band2; ++i)
+ smo[i] = rmed;
+ }
+ smo[band2] = rmed;
+ band2++; /* = bw / 2 + 1*/;
+
+ if(debug) REprintf("(bw,b2)= (%d,%d)\n", bw, band2);
+
+/* Big FOR Loop: RUNNING median, update the median 'rmed'
+ ======================================================= */
+ for (first = 1, last = bw, ismo = band2;
+ last < n;
+ ++first, ++last, ++ismo) {
+
+ yin = y[last];
+ yout = y[first - 1];
+
+ if(debug) REprintf(" is=%d, y(in/out)= %10g, %10g", ismo ,yin, yout);
+
+ rnew = rmed; /* New median = old one in all the simple cases --*/
+
+ if (yin < rmed) {
+ if (yout >= rmed) {
+ kminus = 0;
+ if (yout > rmed) {/* --- yin < rmed < yout --- */
+ if(debug) REprintf(": yin < rmed < yout ");
+ rnew = yin;/* was -rinf */
+ for (i = first; i <= last; ++i) {
+ yi = y[i];
+ if (yi < rmed) {
+ ++kminus;
+ if (yi > rnew) rnew = yi;
+ }
+ }
+ if (kminus < band2) rnew = rmed;
+ }
+ else {/* --- yin < rmed = yout --- */
+ if(debug) REprintf(": yin < rmed == yout ");
+ rse = rts = yin;/* was -rinf */
+ for (i = first; i <= last; ++i) {
+ yi = y[i];
+ if (yi <= rmed) {
+ if (yi < rmed) {
+ ++kminus;
+ if (yi > rts) rts = yi;
+ if (yi > rse) rse = yi;
+ } else rse = yi;
+
+ }
+ }
+ rnew = (kminus == band2) ? rts : rse ;
+ if(debug) REprintf("k- : %d,", kminus);
+ }
+ } /* else: both yin, yout < rmed -- nothing to do .... */
+ }
+ else if (yin != rmed) { /* yin > rmed */
+ if (yout <= rmed) {
+ kplus = 0;
+ if (yout < rmed) {/* -- yout < rmed < yin --- */
+ if(debug) REprintf(": yout < rmed < yin ");
+ rnew = yin; /* was rinf */
+ for (i = first; i <= last; ++i) {
+ yi = y[i];
+ if (yi > rmed) {
+ ++kplus;
+ if (yi < rnew) rnew = yi;
+ }
+ }
+ if (kplus < band2) rnew = rmed;
+
+ } else { /* -- yout = rmed < yin --- */
+ if(debug) REprintf(": yout == rmed < yin ");
+ rbe = rtb = yin; /* was rinf */
+ for (i = first; i <= last; ++i) {
+ yi = y[i];
+ if (yi >= rmed) {
+ if (yi > rmed) {
+ ++kplus;
+ if (yi < rtb) rtb = yi;
+ if (yi < rbe) rbe = yi;
+ } else rbe = yi;
+ }
+ }
+ rnew = (kplus == band2) ? rtb : rbe;
+ if(debug) REprintf("k+ : %d,", kplus);
+ }
+ } /* else: both yin, yout > rmed --> nothing to do */
+ } /* else: yin == rmed -- nothing to do .... */
+ if(debug) REprintf("=> %12g, %12g\n", rmed, rnew);
+ rmed = rnew;
+ smo[ismo] = rmed;
+ } /* END FOR ------------ big Loop -------------------- */
+
+ if(end_rule == 0) { /*-- keep DATA at end values */
+ for (i = ismo; i < n; ++i)
+ smo[i] = y[i];
+ }
+ else { /* if(end_rule == 1) copy median to CONSTANT end values */
+ for (i = ismo; i < n; ++i)
+ smo[i] = rmed;
+ }
+} /* Srunmed */
+
+SEXP runmed(SEXP x, SEXP stype, SEXP sk, SEXP end, SEXP print_level)
+{
+ if (TYPEOF(x) != REALSXP) error("numeric 'x' required");
+ R_xlen_t n = XLENGTH(x);
+ int type = asInteger(stype), k = asInteger(sk),
+ iend = asInteger(end), pl = asInteger(print_level);
+ SEXP ans = PROTECT(allocVector(REALSXP, n));
+ if (type == 1) {
+ if (IS_LONG_VEC(x))
+ error("long vectors are not supported for algorithm = \"Turlach\"");
+ int *i1 = (int *) R_alloc(k + 1, sizeof(int)),
+ *i2 = (int *) R_alloc(2*k + 1, sizeof(int));
+ double *d1 = (double *) R_alloc(2*k + 1, sizeof(double));
+ Trunmed(n, k, REAL(x), REAL(ans), i1, i2, d1, iend, pl);
+ } else {
+ Srunmed(REAL(x), REAL(ans), n, k, iend, pl > 0);
+ }
+ UNPROTECT(1);
+ return ans;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Trunmed.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Trunmed.c
new file mode 100644
index 0000000000..efa326b2b5
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/Trunmed.c
@@ -0,0 +1,378 @@
+/* Copyright (C) 1995 Berwin A. Turlach <berwin@alphasun.anu.edu.au>
+ * Copyright (C) 2000-2 Martin Maechler <maechler@stat.math.ethz.ch>
+ * Copyright (C) 2003 The R Foundation
+ * Copyright (C) 2012-2016 The R Core Team
+
+ * 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, a copy is available at
+ * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ */
+
+/* These routines implement a running median smoother according to the
+ * algorithm described in Haerdle und Steiger (1995).
+ *
+ * A tech-report of that paper is available under
+ * ftp://amadeus.wiwi.hu-berlin.de/pub/papers/sfb/sfb1994/dpsfb940015.ps.Z
+ *
+ * The current implementation does not use any global variables!
+ */
+
+/* Changes for R port by Martin Maechler ((C) above):
+ *
+ * s/long/int/ R uses int, not long (as S does)
+ * s/void/static void/ most routines are internal
+ *
+ * Added print_level and end_rule arguments
+ */
+
+/* Variable name descri- | Identities from paper
+ * name here paper ption | (1-indexing)
+ * --------- ----- -----------------------------------
+ * window[] H the array containing the double heap
+ * data[] X the data (left intact)
+ * ... i 1st permuter H[i[m]] == X[i + m]
+ * ... j 2nd permuter X[i +j[m]] == H[m]
+ */
+
+#include <math.h>
+
+static void
+swap(int l, int r, double *window, int *outlist, int *nrlist, int print_level)
+{
+ /* swap positions `l' and `r' in window[] and nrlist[]
+ *
+ * ---- Used in R_heapsort() and many other routines
+ */
+ int nl, nr;
+ double tmp;
+
+ if(print_level >= 3) Rprintf("SW(%d,%d) ", l,r);
+ tmp = window[l]; window[l] = window[r]; window[r] = tmp;
+ nl = nrlist[l]; nrlist[l] = (nr= nrlist[r]); nrlist[r] = nl;
+
+ outlist[nl/* = nrlist[r] */] = r;
+ outlist[nr/* = nrlist[l] */] = l;
+}
+
+static void
+siftup(int l, int r, double *window, int *outlist, int *nrlist, int print_level)
+{
+/* Used only in R_heapsort() */
+ int i, j, nrold;
+ double x;
+
+ if(print_level >= 2) Rprintf("siftup(%d,%d) ", l,r);
+ i = l;
+ j = 2*i;
+ x = window[i];
+ nrold = nrlist[i];
+ while (j <= r) {
+ if (j < r)
+ if (window[j] < window[j+1])
+ j++;
+ if (x >= window[j])
+ break;
+
+ window[i] = window[j];
+ outlist[nrlist[j]] = i;
+ nrlist[i] = nrlist[j];
+ i = j;
+ j = 2*i;
+ }
+ window[i] = x;
+ outlist[nrold] = i;
+ nrlist[i] = nrold;
+}
+
+static void
+R_heapsort(int low, int up, double *window, int *outlist, int *nrlist,
+ int print_level)
+{
+ int l, u;
+
+ l = (up/2) + 1;
+ u = up;
+ while(l > low) {
+ l--;
+ siftup(l, u, window, outlist, nrlist, print_level);
+ }
+ while(u > low) {
+ swap(l, u, window, outlist, nrlist, print_level);
+ u--;
+ siftup(l, u, window, outlist, nrlist, print_level);
+ }
+}
+
+static void
+inittree(R_xlen_t n, int k, int k2, const double *data, double *window,
+ int *outlist, int *nrlist, int print_level)
+{
+ int i, k2p1;
+ double big;
+
+ for(i=1; i <= k; i++) { /* use 1-indexing for our three arrays !*/
+ window[i] = data[i-1];
+ nrlist[i] = outlist[i] = i;
+ }
+
+ /* sort the window[] -- sort *only* called here */
+ R_heapsort(1, k, window, outlist, nrlist, print_level);
+
+ big = fabs(window[k]);
+ if (big < fabs(window[1]))
+ big = fabs(window[1]);
+ /* big := max | X[1..k] | */
+ for(i=k; i < n; i++)
+ if (big < fabs(data[i]))
+ big = fabs(data[i]);
+ /* big == max(|data_i|, i = 1,..,n) */
+ big = 1 + 2. * big;/* such that -big < data[] < +big (strictly !) */
+
+ for(i=k; i > 0; i--) {
+ window[i+k2] = window[i];
+ nrlist[i+k2] = nrlist[i]-1;
+ }
+
+ for(i=0; i<k; i++)
+ outlist[i]=outlist[i+1]+k2;
+
+ k2p1 = k2+1;
+ for(i=0; i<k2p1; i++) {
+ window[i] = -big;
+ window[k+k2p1+i] = big;
+ }
+} /* inittree*/
+
+static void
+toroot(int outvirt, int k, R_xlen_t nrnew, int outnext,
+ const double *data, double *window, int *outlist, int *nrlist,
+ int print_level)
+{
+ int father;
+
+ if(print_level >= 2) Rprintf("toroot(%d, %d,%d) ", k, (int) nrnew, outnext);
+
+ do {
+ father = outvirt/2;
+ window[outvirt+k] = window[father+k];
+ outlist[nrlist[father+k]] = outvirt+k;
+ nrlist[outvirt+k] = nrlist[father+k];
+ outvirt = father;
+ } while (father != 0);
+ window[k] = data[nrnew];
+ outlist[outnext] = k;
+ nrlist[k] = outnext;
+}
+
+static void
+downtoleave(int outvirt, int k,
+ double *window, int *outlist, int *nrlist, int print_level)
+{
+ int childl, childr;
+
+ if(print_level >= 2) Rprintf("\n downtoleave(%d, %d)\n ", outvirt,k);
+ for(;;) {
+ childl = outvirt*2;
+ childr = childl-1;
+ if (window[childl+k] < window[childr+k])
+ childl = childr;
+ if (window[outvirt+k] >= window[childl+k])
+ break;
+ /* seg.fault happens here: invalid outvirt/childl ? */
+ swap(outvirt+k, childl+k, window, outlist, nrlist, print_level);
+ outvirt = childl;
+ }
+}
+
+static void
+uptoleave(int outvirt, int k,
+ double *window, int *outlist, int *nrlist, int print_level)
+{
+ int childl, childr;
+
+ if(print_level >= 2) Rprintf("\n uptoleave(%d, %d)\n ", outvirt,k);
+ for(;;) {
+ childl = outvirt*2;
+ childr = childl+1;
+ if (window[childl+k] > window[childr+k])
+ childl = childr;
+ if (window[outvirt+k] <= window[childl+k])
+ break;
+ swap(outvirt+k, childl+k, window, outlist, nrlist, print_level);
+ outvirt = childl;
+ }
+}
+
+static void
+upperoutupperin(int outvirt, int k,
+ double *window, int *outlist, int *nrlist, int print_level)
+{
+ int father;
+
+ if(print_level >= 2) Rprintf("\nUpperoutUPPERin(%d, %d)\n ", outvirt,k);
+ uptoleave(outvirt, k, window, outlist, nrlist, print_level);
+ father = outvirt/2;
+ while (window[outvirt+k] < window[father+k]) {
+ swap(outvirt+k, father+k, window, outlist, nrlist, print_level);
+ outvirt = father;
+ father = outvirt/2;
+ }
+ if(print_level >= 2) Rprintf("\n");
+}
+
+static void
+upperoutdownin(int outvirt, int k, R_xlen_t nrnew, int outnext,
+ const double *data, double *window, int *outlist, int *nrlist,
+ int print_level)
+{
+ if(print_level >= 2) Rprintf("\n__upperoutDOWNin(%d, %d)\n ", outvirt,k);
+ toroot(outvirt, k, nrnew, outnext, data, window, outlist, nrlist, print_level);
+ if(window[k] < window[k-1]) {
+ swap(k, k-1, window, outlist, nrlist, print_level);
+ downtoleave(/*outvirt = */ -1, k, window, outlist, nrlist, print_level);
+ }
+}
+
+static void
+downoutdownin(int outvirt, int k,
+ double *window, int *outlist, int *nrlist, int print_level)
+{
+ int father;
+
+ if(print_level >= 2) Rprintf("\nDownoutDOWNin(%d, %d)\n ", outvirt,k);
+ downtoleave(outvirt, k, window, outlist, nrlist, print_level);
+ father = outvirt/2;
+ while (window[outvirt+k] > window[father+k]) {
+ swap(outvirt+k, father+k, window, outlist, nrlist, print_level);
+ outvirt = father;
+ father = outvirt/2;
+ }
+ if(print_level >= 2) Rprintf("\n");
+}
+
+static void
+downoutupperin(int outvirt, int k, R_xlen_t nrnew, int outnext,
+ const double *data, double *window, int *outlist, int *nrlist,
+ int print_level)
+{
+ if(print_level >= 2) Rprintf("\n__downoutUPPERin(%d, %d)\n ", outvirt,k);
+ toroot(outvirt, k, nrnew, outnext, data, window, outlist, nrlist, print_level);
+ if(window[k] > window[k+1]) {
+ swap(k, k+1, window, outlist, nrlist, print_level);
+ uptoleave(/*outvirt = */ +1, k, window, outlist, nrlist, print_level);
+ }
+}
+
+static void
+wentoutone(int k, double *window, int *outlist, int *nrlist, int print_level)
+{
+ if(print_level >= 2) Rprintf("\nwentOUT_1(%d)\n ", k);
+ swap(k, k+1, window, outlist, nrlist, print_level);
+ uptoleave(/*outvirt = */ +1, k, window, outlist, nrlist, print_level);
+}
+
+static void
+wentouttwo(int k, double *window, int *outlist, int *nrlist, int print_level)
+{
+ if(print_level >= 2) Rprintf("\nwentOUT_2(%d)\n ", k);
+ swap(k, k-1, window, outlist, nrlist, print_level);
+ downtoleave(/*outvirt = */ -1, k, window, outlist, nrlist, print_level);
+}
+
+/* For Printing `diagnostics' : */
+#define Rm_PR(_F_,_A_) for(j = 0; j <= 2*k; j++) Rprintf(_F_, _A_)
+#define RgPRINT_j(A_J) Rm_PR("%6g", A_J); Rprintf("\n")
+#define RdPRINT_j(A_J) Rm_PR("%6d", A_J); Rprintf("\n")
+
+#define R_PRINT_4vec() \
+ Rprintf(" %9s: ","j"); RdPRINT_j(j); \
+ Rprintf(" %9s: ","window []");RgPRINT_j(window[j]); \
+ Rprintf(" %9s: "," nrlist[]");RdPRINT_j(nrlist[j]); \
+ Rprintf(" %9s: ","outlist[]");RdPRINT_j((j <= k2|| j > k+k2)? -9\
+ : outlist[j - k2])
+
+static void
+runmedint(R_xlen_t n, int k, int k2, const double *data, double *median,
+ double *window, int *outlist, int *nrlist,
+ int end_rule, int print_level)
+{
+ /* Running Median of `k' , k == 2*k2 + 1 *
+ * end_rule == 0: leave values at the end,
+ * otherwise: "constant" end values
+ */
+ int outnext, out, outvirt;
+
+ if(end_rule)
+ for(int i = 0; i <= k2; median[i++] = window[k]);
+ else {
+ for(int i = 0; i < k2; median[i] = data[i], i++);
+ median[k2] = window[k];
+ }
+ outnext = 0;
+ for(R_xlen_t i = k2+1; i < n-k2; i++) {/* compute (0-index) median[i] == X*_{i+1} */
+ out = outlist[outnext];
+ R_xlen_t nrnew = i+k2;
+ window[out] = data[nrnew];
+ outvirt = out-k;
+ if (out > k)
+ if(data[nrnew] >= window[k])
+ upperoutupperin(outvirt, k, window, outlist, nrlist, print_level);
+ else
+ upperoutdownin(outvirt, k, nrnew, outnext,
+ data, window, outlist, nrlist, print_level);
+ else if(out < k)
+ if(data[nrnew] < window[k])
+ downoutdownin(outvirt, k, window, outlist, nrlist, print_level);
+ else
+ downoutupperin(outvirt, k, nrnew, outnext,
+ data, window, outlist, nrlist, print_level);
+ else if(window[k] > window[k+1])
+ wentoutone(k, window, outlist, nrlist, print_level);
+ else if(window[k] < window[k-1])
+ wentouttwo(k, window, outlist, nrlist, print_level);
+ median[i] = window[k];
+ outnext = (outnext+1)%k;
+ }
+ if(end_rule)
+ for(R_xlen_t i = n-k2; i < n; median[i++] = window[k]);
+ else
+ for(R_xlen_t i = n-k2; i < n; median[i] = data[i], i++);
+}/* runmedint() */
+
+/* This is the function called from R or S: */
+static void Trunmed(R_xlen_t n,/* = length(data) */
+ int k,/* is odd <= n */
+ const double *data,
+ double *median, /* (n) */
+ int *outlist,/* (k+1) */
+ int *nrlist,/* (2k+1) */
+ double *window,/* (2k+1) */
+ int end_rule,
+ int print_level)
+{
+ int k2 = (k - 1)/2, /* k == *kk == 2 * k2 + 1 */
+ j;
+
+ inittree (n, k, k2, data,
+ /* initialize these: */
+ window, (int *)outlist, (int *)nrlist, (int) print_level);
+
+ /* window[], outlist[], and nrlist[] are all 1-based (indices) */
+
+ if(print_level) {
+ Rprintf("After inittree():\n");
+ R_PRINT_4vec();
+ }
+ runmedint(n, k, k2, data, median, window, outlist, nrlist,
+ end_rule, print_level);
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ansari.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ansari.c
new file mode 100644
index 0000000000..7aed745c40
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ansari.c
@@ -0,0 +1,157 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 1999-2016 The R Core Team
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/
+ *
+ */
+
+/* ansari.c
+ Compute the exact distribution of the Ansari-Bradley test statistic.
+ */
+
+#include <string.h>
+#include <R.h>
+#include <math.h> // for floor
+#include <Rmath.h> /* uses choose() */
+#include "stats.h"
+
+static double ***
+w_init(int m, int n)
+{
+ int i;
+ double ***w;
+
+ w = (double ***) R_alloc(m + 1, sizeof(double **));
+ memset(w, '\0', (m+1) * sizeof(double**));
+ for (i = 0; i <= m; i++) {
+ w[i] = (double**) R_alloc(n + 1, sizeof(double *));
+ memset(w[i], '\0', (n+1) * sizeof(double*));
+ }
+ return(w);
+}
+
+
+static double
+cansari(int k, int m, int n, double ***w)
+{
+ int i, l, u;
+
+ l = (m + 1) * (m + 1) / 4;
+ u = l + m * n / 2;
+
+ if ((k < l) || (k > u))
+ return(0);
+
+ if (w[m][n] == 0) {
+ w[m][n] = (double *) R_alloc(u + 1, sizeof(double));
+ memset(w[m][n], '\0', (u + 1) * sizeof(double));
+ for (i = 0; i <= u; i++)
+ w[m][n][i] = -1;
+ }
+
+ if (w[m][n][k] < 0) {
+ if (m == 0)
+ w[m][n][k] = (k == 0);
+ else if (n == 0)
+ w[m][n][k] = (k == l);
+ else
+ w[m][n][k] = cansari(k, m, n - 1, w)
+ + cansari(k - (m + n + 1) / 2, m - 1, n, w);
+ }
+
+ return(w[m][n][k]);
+}
+
+
+static void
+pansari(int len, double *Q, double *P, int m, int n)
+{
+ int i, j, l, u;
+ double c, p, q;
+ double ***w;
+
+ w = w_init(m, n);
+ l = (m + 1) * (m + 1) / 4;
+ u = l + m * n / 2;
+ c = choose(m + n, m);
+ for (i = 0; i < len; i++) {
+ q = floor(Q[i] + 1e-7);
+ if (q < l)
+ P[i] = 0;
+ else if (q > u)
+ P[i] = 1;
+ else {
+ p = 0;
+ for (j = l; j <= q; j++) p += cansari(j, m, n, w);
+ P[i] = p / c;
+ }
+ }
+}
+
+static void
+qansari(int len, double *P, double *Q, int m, int n)
+{
+ int i, l, u;
+ double c, p, xi;
+ double ***w;
+
+ w = w_init(m, n);
+ l = (m + 1) * (m + 1) / 4;
+ u = l + m * n / 2;
+ c = choose(m + n, m);
+ for (i = 0; i < len; i++) {
+ xi = P[i];
+ if(xi < 0 || xi > 1)
+ error(_("probabilities outside [0,1] in qansari()"));
+ if(xi == 0)
+ Q[i] = l;
+ else if(xi == 1)
+ Q[i] = u;
+ else {
+ p = 0.;
+ int q = 0;
+ for(;;) {
+ p += cansari(q, m, n, w) / c;
+ if (p >= xi) break;
+ q++;
+ }
+ Q[i] = q;
+ }
+ }
+}
+
+#include <Rinternals.h>
+SEXP pAnsari(SEXP q, SEXP sm, SEXP sn)
+{
+ int m = asInteger(sm), n = asInteger(sn);
+ q = PROTECT(coerceVector(q, REALSXP));
+ int len = LENGTH(q);
+ SEXP p = PROTECT(allocVector(REALSXP, len));
+ pansari(len, REAL(q), REAL(p), m, n);
+ UNPROTECT(2);
+ return p;
+}
+
+SEXP qAnsari(SEXP p, SEXP sm, SEXP sn)
+{
+ int m = asInteger(sm), n = asInteger(sn);
+ p = PROTECT(coerceVector(p, REALSXP));
+ int len = LENGTH(p);
+ SEXP q = PROTECT(allocVector(REALSXP, len));
+ qansari(len, REAL(p), REAL(q), m, n);
+ UNPROTECT(2);
+ return q;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/arima.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/arima.c
new file mode 100644
index 0000000000..3d6fae8823
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/arima.c
@@ -0,0 +1,1125 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2002-2016 The R Core Team.
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdlib.h> // for abs
+#include <string.h>
+
+#include <R.h>
+#include "ts.h"
+#include "statsR.h" // for getListElement
+
+#ifndef max
+#define max(a,b) ((a < b)?(b):(a))
+#endif
+#ifndef min
+#define min(a,b) ((a < b)?(a):(b))
+#endif
+
+
+/*
+ KalmanLike, internal to StructTS:
+ .Call(C_KalmanLike, y, mod$Z, mod$a, mod$P, mod$T, mod$V, mod$h, mod$Pn,
+ nit, FALSE, update)
+ KalmanRun:
+ .Call(C_KalmanLike, y, mod$Z, mod$a, mod$P, mod$T, mod$V, mod$h, mod$Pn,
+ nit, TRUE, update)
+*/
+
+/* y vector length n of observations
+ Z vector length p for observation equation y_t = Za_t + eps_t
+ a vector length p of initial state
+ P p x p matrix for initial state uncertainty (contemparaneous)
+ T p x p transition matrix
+ V p x p = RQR'
+ h = var(eps_t)
+ anew used for a[t|t-1]
+ Pnew used for P[t|t -1]
+ M used for M = P[t|t -1]Z
+
+ op is FALSE for KalmanLike, TRUE for KalmanRun.
+ The latter computes residuals and states and has
+ a more elaborate return value.
+
+ Almost no checking here!
+ */
+
+SEXP
+KalmanLike(SEXP sy, SEXP mod, SEXP sUP, SEXP op, SEXP update)
+{
+ int lop = asLogical(op);
+ mod = PROTECT(duplicate(mod));
+
+ SEXP sZ = getListElement(mod, "Z"), sa = getListElement(mod, "a"),
+ sP = getListElement(mod, "P"), sT = getListElement(mod, "T"),
+ sV = getListElement(mod, "V"), sh = getListElement(mod, "h"),
+ sPn = getListElement(mod, "Pn");
+
+ if (TYPEOF(sy) != REALSXP || TYPEOF(sZ) != REALSXP ||
+ TYPEOF(sa) != REALSXP || TYPEOF(sP) != REALSXP ||
+ TYPEOF(sPn) != REALSXP ||
+ TYPEOF(sT) != REALSXP || TYPEOF(sV) != REALSXP)
+ error(_("invalid argument type"));
+
+ int n = LENGTH(sy), p = LENGTH(sa);
+ double *y = REAL(sy), *Z = REAL(sZ), *T = REAL(sT), *V = REAL(sV),
+ *P = REAL(sP), *a = REAL(sa), *Pnew = REAL(sPn), h = asReal(sh);
+
+ double *anew = (double *) R_alloc(p, sizeof(double));
+ double *M = (double *) R_alloc(p, sizeof(double));
+ double *mm = (double *) R_alloc(p * p, sizeof(double));
+ // These are only used if(lop), but avoid -Wall trouble
+ SEXP ans = R_NilValue, resid = R_NilValue, states = R_NilValue;
+ if(lop) {
+ PROTECT(ans = allocVector(VECSXP, 3));
+ SET_VECTOR_ELT(ans, 1, resid = allocVector(REALSXP, n));
+ SET_VECTOR_ELT(ans, 2, states = allocMatrix(REALSXP, n, p));
+ SEXP nm = PROTECT(allocVector(STRSXP, 3));
+ SET_STRING_ELT(nm, 0, mkChar("values"));
+ SET_STRING_ELT(nm, 1, mkChar("resid"));
+ SET_STRING_ELT(nm, 2, mkChar("states"));
+ setAttrib(ans, R_NamesSymbol, nm);
+ UNPROTECT(1);
+ }
+
+ double sumlog = 0.0, ssq = 0.0;
+ int nu = 0;
+ for (int l = 0; l < n; l++) {
+ for (int i = 0; i < p; i++) {
+ double tmp = 0.0;
+ for (int k = 0; k < p; k++)
+ tmp += T[i + p * k] * a[k];
+ anew[i] = tmp;
+ }
+ if (l > asInteger(sUP)) {
+ for (int i = 0; i < p; i++)
+ for (int j = 0; j < p; j++) {
+ double tmp = 0.0;
+ for (int k = 0; k < p; k++)
+ tmp += T[i + p * k] * P[k + p * j];
+ mm[i + p * j] = tmp;
+ }
+ for (int i = 0; i < p; i++)
+ for (int j = 0; j < p; j++) {
+ double tmp = V[i + p * j];
+ for (int k = 0; k < p; k++)
+ tmp += mm[i + p * k] * T[j + p * k];
+ Pnew[i + p * j] = tmp;
+ }
+ }
+ if (!ISNAN(y[l])) {
+ nu++;
+ double *rr = NULL /* -Wall */;
+ if(lop) rr = REAL(resid);
+ double resid0 = y[l];
+ for (int i = 0; i < p; i++)
+ resid0 -= Z[i] * anew[i];
+ double gain = h;
+ for (int i = 0; i < p; i++) {
+ double tmp = 0.0;
+ for (int j = 0; j < p; j++)
+ tmp += Pnew[i + j * p] * Z[j];
+ M[i] = tmp;
+ gain += Z[i] * M[i];
+ }
+ ssq += resid0 * resid0 / gain;
+ if(lop) rr[l] = resid0 / sqrt(gain);
+ sumlog += log(gain);
+ for (int i = 0; i < p; i++)
+ a[i] = anew[i] + M[i] * resid0 / gain;
+ for (int i = 0; i < p; i++)
+ for (int j = 0; j < p; j++)
+ P[i + j * p] = Pnew[i + j * p] - M[i] * M[j] / gain;
+ } else {
+ double *rr = NULL /* -Wall */;
+ if(lop) rr = REAL(resid);
+ for (int i = 0; i < p; i++)
+ a[i] = anew[i];
+ for (int i = 0; i < p * p; i++)
+ P[i] = Pnew[i];
+ if(lop) rr[l] = NA_REAL;
+ }
+ if(lop) {
+ double *rs = REAL(states);
+ for (int j = 0; j < p; j++) rs[l + n*j] = a[j];
+ }
+ }
+
+ SEXP res = PROTECT(allocVector(REALSXP, 2));
+ REAL(res)[0] = ssq/nu; REAL(res)[1] = sumlog/nu;
+ if(lop) {
+ SET_VECTOR_ELT(ans, 0, res);
+ if(asLogical(update)) setAttrib(ans, install("mod"), mod);
+ UNPROTECT(3);
+ return ans;
+ } else {
+ if(asLogical(update)) setAttrib(res, install("mod"), mod);
+ UNPROTECT(2);
+ return res;
+ }
+}
+
+SEXP
+KalmanSmooth(SEXP sy, SEXP mod, SEXP sUP)
+{
+ SEXP sZ = getListElement(mod, "Z"), sa = getListElement(mod, "a"),
+ sP = getListElement(mod, "P"), sT = getListElement(mod, "T"),
+ sV = getListElement(mod, "V"), sh = getListElement(mod, "h"),
+ sPn = getListElement(mod, "Pn");
+
+ if (TYPEOF(sy) != REALSXP || TYPEOF(sZ) != REALSXP ||
+ TYPEOF(sa) != REALSXP || TYPEOF(sP) != REALSXP ||
+ TYPEOF(sT) != REALSXP || TYPEOF(sV) != REALSXP)
+ error(_("invalid argument type"));
+
+ SEXP ssa, ssP, ssPn, res, states = R_NilValue, sN;
+ int n = LENGTH(sy), p = LENGTH(sa);
+ double *y = REAL(sy), *Z = REAL(sZ), *a, *P,
+ *T = REAL(sT), *V = REAL(sV), h = asReal(sh), *Pnew;
+ double *at, *rt, *Pt, *gains, *resids, *Mt, *L, gn, *Nt;
+ Rboolean var = TRUE;
+
+ PROTECT(ssa = duplicate(sa)); a = REAL(ssa);
+ PROTECT(ssP = duplicate(sP)); P = REAL(ssP);
+ PROTECT(ssPn = duplicate(sPn)); Pnew = REAL(ssPn);
+
+ PROTECT(res = allocVector(VECSXP, 2));
+ SEXP nm = PROTECT(allocVector(STRSXP, 2));
+ SET_STRING_ELT(nm, 0, mkChar("smooth"));
+ SET_STRING_ELT(nm, 1, mkChar("var"));
+ setAttrib(res, R_NamesSymbol, nm);
+ UNPROTECT(1);
+ SET_VECTOR_ELT(res, 0, states = allocMatrix(REALSXP, n, p));
+ at = REAL(states);
+ SET_VECTOR_ELT(res, 1, sN = allocVector(REALSXP, n*p*p));
+ Nt = REAL(sN);
+
+ double *anew, *mm, *M;
+ anew = (double *) R_alloc(p, sizeof(double));
+ M = (double *) R_alloc(p, sizeof(double));
+ mm = (double *) R_alloc(p * p, sizeof(double));
+
+ Pt = (double *) R_alloc(n * p * p, sizeof(double));
+ gains = (double *) R_alloc(n, sizeof(double));
+ resids = (double *) R_alloc(n, sizeof(double));
+ Mt = (double *) R_alloc(n * p, sizeof(double));
+ L = (double *) R_alloc(p * p, sizeof(double));
+
+ for (int l = 0; l < n; l++) {
+ for (int i = 0; i < p; i++) {
+ double tmp = 0.0;
+ for (int k = 0; k < p; k++)
+ tmp += T[i + p * k] * a[k];
+ anew[i] = tmp;
+ }
+ if (l > asInteger(sUP)) {
+ for (int i = 0; i < p; i++)
+ for (int j = 0; j < p; j++) {
+ double tmp = 0.0;
+ for (int k = 0; k < p; k++)
+ tmp += T[i + p * k] * P[k + p * j];
+ mm[i + p * j] = tmp;
+ }
+ for (int i = 0; i < p; i++)
+ for (int j = 0; j < p; j++) {
+ double tmp = V[i + p * j];
+ for (int k = 0; k < p; k++)
+ tmp += mm[i + p * k] * T[j + p * k];
+ Pnew[i + p * j] = tmp;
+ }
+ }
+ for (int i = 0; i < p; i++) at[l + n*i] = anew[i];
+ for (int i = 0; i < p*p; i++) Pt[l + n*i] = Pnew[i];
+ if (!ISNAN(y[l])) {
+ double resid0 = y[l];
+ for (int i = 0; i < p; i++)
+ resid0 -= Z[i] * anew[i];
+ double gain = h;
+ for (int i = 0; i < p; i++) {
+ double tmp = 0.0;
+ for (int j = 0; j < p; j++)
+ tmp += Pnew[i + j * p] * Z[j];
+ Mt[l + n*i] = M[i] = tmp;
+ gain += Z[i] * M[i];
+ }
+ gains[l] = gain;
+ resids[l] = resid0;
+ for (int i = 0; i < p; i++)
+ a[i] = anew[i] + M[i] * resid0 / gain;
+ for (int i = 0; i < p; i++)
+ for (int j = 0; j < p; j++)
+ P[i + j * p] = Pnew[i + j * p] - M[i] * M[j] / gain;
+ } else {
+ for (int i = 0; i < p; i++) {
+ a[i] = anew[i];
+ Mt[l + n * i] = 0.0;
+ }
+ for (int i = 0; i < p * p; i++)
+ P[i] = Pnew[i];
+ gains[l] = NA_REAL;
+ resids[l] = NA_REAL;
+ }
+ }
+
+ /* rt stores r_{t-1} */
+ rt = (double *) R_alloc(n * p, sizeof(double));
+ for (int l = n - 1; l >= 0; l--) {
+ if (!ISNAN(gains[l])) {
+ gn = 1/gains[l];
+ for (int i = 0; i < p; i++)
+ rt[l + n * i] = Z[i] * resids[l] * gn;
+ } else {
+ for (int i = 0; i < p; i++) rt[l + n * i] = 0.0;
+ gn = 0.0;
+ }
+
+ if (var) {
+ for (int i = 0; i < p; i++)
+ for (int j = 0; j < p; j++)
+ Nt[l + n*i + n*p*j] = Z[i] * Z[j] * gn;
+ }
+
+ if (l < n - 1) {
+ /* compute r_{t-1} */
+ for (int i = 0; i < p; i++)
+ for (int j = 0; j < p; j++)
+ mm[i + p * j] = ((i==j) ? 1:0) - Mt[l + n * i] * Z[j] * gn;
+ for (int i = 0; i < p; i++)
+ for (int j = 0; j < p; j++) {
+ double tmp = 0.0;
+ for (int k = 0; k < p; k++)
+ tmp += T[i + p * k] * mm[k + p * j];
+ L[i + p * j] = tmp;
+ }
+ for (int i = 0; i < p; i++) {
+ double tmp = 0.0;
+ for (int j = 0; j < p; j++)
+ tmp += L[j + p * i] * rt[l + 1 + n * j];
+ rt[l + n * i] += tmp;
+ }
+ if(var) { /* compute N_{t-1} */
+ for (int i = 0; i < p; i++)
+ for (int j = 0; j < p; j++) {
+ double tmp = 0.0;
+ for (int k = 0; k < p; k++)
+ tmp += L[k + p * i] * Nt[l + 1 + n*k + n*p*j];
+ mm[i + p * j] = tmp;
+ }
+ for (int i = 0; i < p; i++)
+ for (int j = 0; j < p; j++) {
+ double tmp = 0.0;
+ for (int k = 0; k < p; k++)
+ tmp += mm[i + p * k] * L[k + p * j];
+ Nt[l + n*i + n*p*j] += tmp;
+ }
+ }
+ }
+
+ for (int i = 0; i < p; i++) {
+ double tmp = 0.0;
+ for (int j = 0; j < p; j++)
+ tmp += Pt[l + n*i + n*p*j] * rt[l + n * j];
+ at[l + n*i] += tmp;
+ }
+ }
+ if (var)
+ for (int l = 0; l < n; l++) {
+ for (int i = 0; i < p; i++)
+ for (int j = 0; j < p; j++) {
+ double tmp = 0.0;
+ for (int k = 0; k < p; k++)
+ tmp += Pt[l + n*i + n*p*k] * Nt[l + n*k + n*p*j];
+ mm[i + p * j] = tmp;
+ }
+ for (int i = 0; i < p; i++)
+ for (int j = 0; j < p; j++) {
+ double tmp = Pt[l + n*i + n*p*j];
+ for (int k = 0; k < p; k++)
+ tmp -= mm[i + p * k] * Pt[l + n*k + n*p*j];
+ Nt[l + n*i + n*p*j] = tmp;
+ }
+ }
+ UNPROTECT(4);
+ return res;
+}
+
+
+SEXP
+KalmanFore(SEXP nahead, SEXP mod, SEXP update)
+{
+ mod = PROTECT(duplicate(mod));
+ SEXP sZ = getListElement(mod, "Z"), sa = getListElement(mod, "a"),
+ sP = getListElement(mod, "P"), sT = getListElement(mod, "T"),
+ sV = getListElement(mod, "V"), sh = getListElement(mod, "h");
+
+ if (TYPEOF(sZ) != REALSXP ||
+ TYPEOF(sa) != REALSXP || TYPEOF(sP) != REALSXP ||
+ TYPEOF(sT) != REALSXP || TYPEOF(sV) != REALSXP)
+ error(_("invalid argument type"));
+
+ int n = asInteger(nahead), p = LENGTH(sa);
+ double *Z = REAL(sZ), *a = REAL(sa), *P = REAL(sP), *T = REAL(sT),
+ *V = REAL(sV), h = asReal(sh);
+ double *mm, *anew, *Pnew;
+
+ anew = (double *) R_alloc(p, sizeof(double));
+ Pnew = (double *) R_alloc(p * p, sizeof(double));
+ mm = (double *) R_alloc(p * p, sizeof(double));
+ SEXP res, forecasts, se;
+ PROTECT(res = allocVector(VECSXP, 2));
+ SET_VECTOR_ELT(res, 0, forecasts = allocVector(REALSXP, n));
+ SET_VECTOR_ELT(res, 1, se = allocVector(REALSXP, n));
+ {
+ SEXP nm = PROTECT(allocVector(STRSXP, 2));
+ SET_STRING_ELT(nm, 0, mkChar("pred"));
+ SET_STRING_ELT(nm, 1, mkChar("var"));
+ setAttrib(res, R_NamesSymbol, nm);
+ UNPROTECT(1);
+ }
+ for (int l = 0; l < n; l++) {
+ double fc = 0.0;
+ for (int i = 0; i < p; i++) {
+ double tmp = 0.0;
+ for (int k = 0; k < p; k++)
+ tmp += T[i + p * k] * a[k];
+ anew[i] = tmp;
+ fc += tmp * Z[i];
+ }
+ for (int i = 0; i < p; i++)
+ a[i] = anew[i];
+ REAL(forecasts)[l] = fc;
+
+ for (int i = 0; i < p; i++)
+ for (int j = 0; j < p; j++) {
+ double tmp = 0.0;
+ for (int k = 0; k < p; k++)
+ tmp += T[i + p * k] * P[k + p * j];
+ mm[i + p * j] = tmp;
+ }
+ for (int i = 0; i < p; i++)
+ for (int j = 0; j < p; j++) {
+ double tmp = V[i + p * j];
+ for (int k = 0; k < p; k++)
+ tmp += mm[i + p * k] * T[j + p * k];
+ Pnew[i + p * j] = tmp;
+ }
+ double tmp = h;
+ for (int i = 0; i < p; i++)
+ for (int j = 0; j < p; j++) {
+ P[i + j * p] = Pnew[i + j * p];
+ tmp += Z[i] * Z[j] * P[i + j * p];
+ }
+ REAL(se)[l] = tmp;
+ }
+ if(asLogical(update)) setAttrib(res, install("mod"), mod);
+ UNPROTECT(2);
+ return res;
+}
+
+
+static void partrans(int p, double *raw, double *new)
+{
+ int j, k;
+ double a, work[100];
+
+ if(p > 100) error(_("can only transform 100 pars in arima0"));
+
+ /* Step one: map (-Inf, Inf) to (-1, 1) via tanh
+ The parameters are now the pacf phi_{kk} */
+ for(j = 0; j < p; j++) work[j] = new[j] = tanh(raw[j]);
+ /* Step two: run the Durbin-Levinson recursions to find phi_{j.},
+ j = 2, ..., p and phi_{p.} are the autoregression coefficients */
+ for(j = 1; j < p; j++) {
+ a = new[j];
+ for(k = 0; k < j; k++)
+ work[k] -= a * new[j - k - 1];
+ for(k = 0; k < j; k++) new[k] = work[k];
+ }
+}
+
+SEXP ARIMA_undoPars(SEXP sin, SEXP sarma)
+{
+ int *arma = INTEGER(sarma), mp = arma[0], mq = arma[1], msp = arma[2],
+ v, n = LENGTH(sin);
+ double *params, *in = REAL(sin);
+ SEXP res = allocVector(REALSXP, n);
+
+ params = REAL(res);
+ for (int i = 0; i < n; i++) params[i] = in[i];
+ if (mp > 0) partrans(mp, in, params);
+ v = mp + mq;
+ if (msp > 0) partrans(msp, in + v, params + v);
+ return res;
+}
+
+
+SEXP ARIMA_transPars(SEXP sin, SEXP sarma, SEXP strans)
+{
+ int *arma = INTEGER(sarma), trans = asLogical(strans);
+ int mp = arma[0], mq = arma[1], msp = arma[2], msq = arma[3],
+ ns = arma[4], i, j, p = mp + ns * msp, q = mq + ns * msq, v;
+ double *in = REAL(sin), *params = REAL(sin), *phi, *theta;
+ SEXP res, sPhi, sTheta;
+
+ PROTECT(res = allocVector(VECSXP, 2));
+ SET_VECTOR_ELT(res, 0, sPhi = allocVector(REALSXP, p));
+ SET_VECTOR_ELT(res, 1, sTheta = allocVector(REALSXP, q));
+ phi = REAL(sPhi);
+ theta = REAL(sTheta);
+ if (trans) {
+ int n = mp + mq + msp + msq;
+
+ params = (double *) R_alloc(n, sizeof(double));
+ for (i = 0; i < n; i++) params[i] = in[i];
+ if (mp > 0) partrans(mp, in, params);
+ v = mp + mq;
+ if (msp > 0) partrans(msp, in + v, params + v);
+ }
+ if (ns > 0) {
+ /* expand out seasonal ARMA models */
+ for (i = 0; i < mp; i++) phi[i] = params[i];
+ for (i = 0; i < mq; i++) theta[i] = params[i + mp];
+ for (i = mp; i < p; i++) phi[i] = 0.0;
+ for (i = mq; i < q; i++) theta[i] = 0.0;
+ for (j = 0; j < msp; j++) {
+ phi[(j + 1) * ns - 1] += params[j + mp + mq];
+ for (i = 0; i < mp; i++)
+ phi[(j + 1) * ns + i] -= params[i] * params[j + mp + mq];
+ }
+ for (j = 0; j < msq; j++) {
+ theta[(j + 1) * ns - 1] += params[j + mp + mq + msp];
+ for (i = 0; i < mq; i++)
+ theta[(j + 1) * ns + i] += params[i + mp] *
+ params[j + mp + mq + msp];
+ }
+ } else {
+ for (i = 0; i < mp; i++) phi[i] = params[i];
+ for (i = 0; i < mq; i++) theta[i] = params[i + mp];
+ }
+ UNPROTECT(1);
+ return res;
+}
+
+#if !defined(atanh) && defined(HAVE_DECL_ATANH) && !HAVE_DECL_ATANH
+extern double atanh(double x);
+#endif
+static void invpartrans(int p, double *phi, double *new)
+{
+ int j, k;
+ double a, work[100];
+
+ if(p > 100) error(_("can only transform 100 pars in arima0"));
+
+ for(j = 0; j < p; j++) work[j] = new[j] = phi[j];
+ /* Run the Durbin-Levinson recursions backwards
+ to find the PACF phi_{j.} from the autoregression coefficients */
+ for(j = p - 1; j > 0; j--) {
+ a = new[j];
+ for(k = 0; k < j; k++)
+ work[k] = (new[k] + a * new[j - k - 1]) / (1 - a * a);
+ for(k = 0; k < j; k++) new[k] = work[k];
+ }
+ for(j = 0; j < p; j++) new[j] = atanh(new[j]);
+}
+
+SEXP ARIMA_Invtrans(SEXP in, SEXP sarma)
+{
+ int *arma = INTEGER(sarma), mp = arma[0], mq = arma[1], msp = arma[2],
+ i, v, n = LENGTH(in);
+ SEXP y = allocVector(REALSXP, n);
+ double *raw = REAL(in), *new = REAL(y);
+
+ for(i = 0; i < n; i++) new[i] = raw[i];
+ if (mp > 0) invpartrans(mp, raw, new);
+ v = mp + mq;
+ if (msp > 0) invpartrans(msp, raw + v, new + v);
+ return y;
+}
+
+#define eps 1e-3
+SEXP ARIMA_Gradtrans(SEXP in, SEXP sarma)
+{
+ int *arma = INTEGER(sarma), mp = arma[0], mq = arma[1], msp = arma[2],
+ n = LENGTH(in);
+ SEXP y = allocMatrix(REALSXP, n, n);
+ double *raw = REAL(in), *A = REAL(y), w1[100], w2[100], w3[100];
+
+ for (int i = 0; i < n; i++)
+ for (int j = 0; j < n; j++)
+ A[i + j*n] = (i == j);
+ if(mp > 0) {
+ for (int i = 0; i < mp; i++) w1[i] = raw[i];
+ partrans(mp, w1, w2);
+ for (int i = 0; i < mp; i++) {
+ w1[i] += eps;
+ partrans(mp, w1, w3);
+ for (int j = 0; j < mp; j++) A[i + j*n] = (w3[j] - w2[j])/eps;
+ w1[i] -= eps;
+ }
+ }
+ if(msp > 0) {
+ int v = mp + mq;
+ for (int i = 0; i < msp; i++) w1[i] = raw[i + v];
+ partrans(msp, w1, w2);
+ for(int i = 0; i < msp; i++) {
+ w1[i] += eps;
+ partrans(msp, w1, w3);
+ for(int j = 0; j < msp; j++)
+ A[i + v + (j+v)*n] = (w3[j] - w2[j])/eps;
+ w1[i] -= eps;
+ }
+ }
+ return y;
+}
+
+
+SEXP
+ARIMA_Like(SEXP sy, SEXP mod, SEXP sUP, SEXP giveResid)
+{
+ SEXP sPhi = getListElement(mod, "phi"),
+ sTheta = getListElement(mod, "theta"),
+ sDelta = getListElement(mod, "Delta"),
+ sa = getListElement(mod, "a"),
+ sP = getListElement(mod, "P"),
+ sPn = getListElement(mod, "Pn");
+
+ if (TYPEOF(sPhi) != REALSXP || TYPEOF(sTheta) != REALSXP ||
+ TYPEOF(sDelta) != REALSXP || TYPEOF(sa) != REALSXP ||
+ TYPEOF(sP) != REALSXP || TYPEOF(sPn) != REALSXP)
+ error(_("invalid argument type"));
+
+ SEXP res, nres, sResid = R_NilValue;
+ int n = LENGTH(sy), rd = LENGTH(sa), p = LENGTH(sPhi),
+ q = LENGTH(sTheta), d = LENGTH(sDelta), r = rd - d;
+ double *y = REAL(sy), *a = REAL(sa), *P = REAL(sP), *Pnew = REAL(sPn);
+ double *phi = REAL(sPhi), *theta = REAL(sTheta), *delta = REAL(sDelta);
+ double sumlog = 0.0, ssq = 0, *anew, *mm = NULL, *M;
+ int nu = 0;
+ Rboolean useResid = asLogical(giveResid);
+ double *rsResid = NULL /* -Wall */;
+
+ anew = (double *) R_alloc(rd, sizeof(double));
+ M = (double *) R_alloc(rd, sizeof(double));
+ if (d > 0) mm = (double *) R_alloc(rd * rd, sizeof(double));
+
+ if (useResid) {
+ PROTECT(sResid = allocVector(REALSXP, n));
+ rsResid = REAL(sResid);
+ }
+
+ for (int l = 0; l < n; l++) {
+ for (int i = 0; i < r; i++) {
+ double tmp = (i < r - 1) ? a[i + 1] : 0.0;
+ if (i < p) tmp += phi[i] * a[0];
+ anew[i] = tmp;
+ }
+ if (d > 0) {
+ for (int i = r + 1; i < rd; i++) anew[i] = a[i - 1];
+ double tmp = a[0];
+ for (int i = 0; i < d; i++) tmp += delta[i] * a[r + i];
+ anew[r] = tmp;
+ }
+ if (l > asInteger(sUP)) {
+ if (d == 0) {
+ for (int i = 0; i < r; i++) {
+ double vi = 0.0;
+ if (i == 0) vi = 1.0; else if (i - 1 < q) vi = theta[i - 1];
+ for (int j = 0; j < r; j++) {
+ double tmp = 0.0;
+ if (j == 0) tmp = vi; else if (j - 1 < q) tmp = vi * theta[j - 1];
+ if (i < p && j < p) tmp += phi[i] * phi[j] * P[0];
+ if (i < r - 1 && j < r - 1) tmp += P[i + 1 + r * (j + 1)];
+ if (i < p && j < r - 1) tmp += phi[i] * P[j + 1];
+ if (j < p && i < r - 1) tmp += phi[j] * P[i + 1];
+ Pnew[i + r * j] = tmp;
+ }
+ }
+ } else {
+ /* mm = TP */
+ for (int i = 0; i < r; i++)
+ for (int j = 0; j < rd; j++) {
+ double tmp = 0.0;
+ if (i < p) tmp += phi[i] * P[rd * j];
+ if (i < r - 1) tmp += P[i + 1 + rd * j];
+ mm[i + rd * j] = tmp;
+ }
+ for (int j = 0; j < rd; j++) {
+ double tmp = P[rd * j];
+ for (int k = 0; k < d; k++)
+ tmp += delta[k] * P[r + k + rd * j];
+ mm[r + rd * j] = tmp;
+ }
+ for (int i = 1; i < d; i++)
+ for (int j = 0; j < rd; j++)
+ mm[r + i + rd * j] = P[r + i - 1 + rd * j];
+
+ /* Pnew = mmT' */
+ for (int i = 0; i < r; i++)
+ for (int j = 0; j < rd; j++) {
+ double tmp = 0.0;
+ if (i < p) tmp += phi[i] * mm[j];
+ if (i < r - 1) tmp += mm[rd * (i + 1) + j];
+ Pnew[j + rd * i] = tmp;
+ }
+ for (int j = 0; j < rd; j++) {
+ double tmp = mm[j];
+ for (int k = 0; k < d; k++)
+ tmp += delta[k] * mm[rd * (r + k) + j];
+ Pnew[rd * r + j] = tmp;
+ }
+ for (int i = 1; i < d; i++)
+ for (int j = 0; j < rd; j++)
+ Pnew[rd * (r + i) + j] = mm[rd * (r + i - 1) + j];
+ /* Pnew <- Pnew + (1 theta) %o% (1 theta) */
+ for (int i = 0; i <= q; i++) {
+ double vi = (i == 0) ? 1. : theta[i - 1];
+ for (int j = 0; j <= q; j++)
+ Pnew[i + rd * j] += vi * ((j == 0) ? 1. : theta[j - 1]);
+ }
+ }
+ }
+ if (!ISNAN(y[l])) {
+ double resid = y[l] - anew[0];
+ for (int i = 0; i < d; i++)
+ resid -= delta[i] * anew[r + i];
+
+ for (int i = 0; i < rd; i++) {
+ double tmp = Pnew[i];
+ for (int j = 0; j < d; j++)
+ tmp += Pnew[i + (r + j) * rd] * delta[j];
+ M[i] = tmp;
+ }
+
+ double gain = M[0];
+ for (int j = 0; j < d; j++) gain += delta[j] * M[r + j];
+ if(gain < 1e4) {
+ nu++;
+ ssq += resid * resid / gain;
+ sumlog += log(gain);
+ }
+ if (useResid) rsResid[l] = resid / sqrt(gain);
+ for (int i = 0; i < rd; i++)
+ a[i] = anew[i] + M[i] * resid / gain;
+ for (int i = 0; i < rd; i++)
+ for (int j = 0; j < rd; j++)
+ P[i + j * rd] = Pnew[i + j * rd] - M[i] * M[j] / gain;
+ } else {
+ for (int i = 0; i < rd; i++) a[i] = anew[i];
+ for (int i = 0; i < rd * rd; i++) P[i] = Pnew[i];
+ if (useResid) rsResid[l] = NA_REAL;
+ }
+ }
+
+ if (useResid) {
+ PROTECT(res = allocVector(VECSXP, 3));
+ SET_VECTOR_ELT(res, 0, nres = allocVector(REALSXP, 3));
+ REAL(nres)[0] = ssq;
+ REAL(nres)[1] = sumlog;
+ REAL(nres)[2] = (double) nu;
+ SET_VECTOR_ELT(res, 1, sResid);
+ UNPROTECT(2);
+ return res;
+ } else {
+ nres = allocVector(REALSXP, 3);
+ REAL(nres)[0] = ssq;
+ REAL(nres)[1] = sumlog;
+ REAL(nres)[2] = (double) nu;
+ return nres;
+ }
+}
+
+/* do differencing here */
+/* arma is p, q, sp, sq, ns, d, sd */
+SEXP
+ARIMA_CSS(SEXP sy, SEXP sarma, SEXP sPhi, SEXP sTheta,
+ SEXP sncond, SEXP giveResid)
+{
+ SEXP res, sResid = R_NilValue;
+ double ssq = 0.0, *y = REAL(sy), tmp;
+ double *phi = REAL(sPhi), *theta = REAL(sTheta), *w, *resid;
+ int n = LENGTH(sy), *arma = INTEGER(sarma), p = LENGTH(sPhi),
+ q = LENGTH(sTheta), ncond = asInteger(sncond);
+ int ns, nu = 0;
+ Rboolean useResid = asLogical(giveResid);
+
+ w = (double *) R_alloc(n, sizeof(double));
+ for (int l = 0; l < n; l++) w[l] = y[l];
+ for (int i = 0; i < arma[5]; i++)
+ for (int l = n - 1; l > 0; l--) w[l] -= w[l - 1];
+ ns = arma[4];
+ for (int i = 0; i < arma[6]; i++)
+ for (int l = n - 1; l >= ns; l--) w[l] -= w[l - ns];
+
+ PROTECT(sResid = allocVector(REALSXP, n));
+ resid = REAL(sResid);
+ if (useResid) for (int l = 0; l < ncond; l++) resid[l] = 0;
+
+ for (int l = ncond; l < n; l++) {
+ tmp = w[l];
+ for (int j = 0; j < p; j++) tmp -= phi[j] * w[l - j - 1];
+ for (int j = 0; j < min(l - ncond, q); j++)
+ tmp -= theta[j] * resid[l - j - 1];
+ resid[l] = tmp;
+ if (!ISNAN(tmp)) {
+ nu++;
+ ssq += tmp * tmp;
+ }
+ }
+ if (useResid) {
+ PROTECT(res = allocVector(VECSXP, 2));
+ SET_VECTOR_ELT(res, 0, ScalarReal(ssq / (double) (nu)));
+ SET_VECTOR_ELT(res, 1, sResid);
+ UNPROTECT(2);
+ return res;
+ } else {
+ UNPROTECT(1);
+ return ScalarReal(ssq / (double) (nu));
+ }
+}
+
+SEXP TSconv(SEXP a, SEXP b)
+{
+ int na, nb, nab;
+ SEXP ab;
+ double *ra, *rb, *rab;
+
+ PROTECT(a = coerceVector(a, REALSXP));
+ PROTECT(b = coerceVector(b, REALSXP));
+ na = LENGTH(a);
+ nb = LENGTH(b);
+ nab = na + nb - 1;
+ PROTECT(ab = allocVector(REALSXP, nab));
+ ra = REAL(a); rb = REAL(b); rab = REAL(ab);
+ for (int i = 0; i < nab; i++) rab[i] = 0.0;
+ for (int i = 0; i < na; i++)
+ for (int j = 0; j < nb; j++)
+ rab[i + j] += ra[i] * rb[j];
+ UNPROTECT(3);
+ return (ab);
+}
+
+/* based on code from AS154 */
+
+static void
+inclu2(size_t np, double *xnext, double *xrow, double ynext,
+ double *d, double *rbar, double *thetab)
+{
+ double cbar, sbar, di, xi, xk, rbthis, dpi;
+ size_t i, k, ithisr;
+
+/* This subroutine updates d, rbar, thetab by the inclusion
+ of xnext and ynext. */
+
+ for (i = 0; i < np; i++) xrow[i] = xnext[i];
+
+ for (ithisr = 0, i = 0; i < np; i++) {
+ if (xrow[i] != 0.0) {
+ xi = xrow[i];
+ di = d[i];
+ dpi = di + xi * xi;
+ d[i] = dpi;
+ cbar = di / dpi;
+ sbar = xi / dpi;
+ for (k = i + 1; k < np; k++) {
+ xk = xrow[k];
+ rbthis = rbar[ithisr];
+ xrow[k] = xk - xi * rbthis;
+ rbar[ithisr++] = cbar * rbthis + sbar * xk;
+ }
+ xk = ynext;
+ ynext = xk - xi * thetab[i];
+ thetab[i] = cbar * thetab[i] + sbar * xk;
+ if (di == 0.0) return;
+ } else
+ ithisr = ithisr + np - i - 1;
+ }
+}
+
+#ifdef DEBUG_Q0bis
+# include <R_ext/Print.h>
+ double chk_V(double v[], char* nm, int jj, int len) {
+ // len = length(<vector>) <==> index must be in {0, len-1}
+ if(jj < 0 || jj >= len)
+ REprintf(" %s[%2d]\n", nm, jj);
+ return(v[jj]);
+ }
+#endif
+
+/*
+ Matwey V. Kornilov's implementation of algorithm by
+ Dr. Raphael Rossignol
+ See https://bugs.r-project.org/bugzilla3/show_bug.cgi?id=14682 for details.
+*/
+SEXP getQ0bis(SEXP sPhi, SEXP sTheta, SEXP sTol)
+{
+ SEXP res;
+ int p = LENGTH(sPhi), q = LENGTH(sTheta);
+ double *phi = REAL(sPhi), *theta = REAL(sTheta); // tol = REAL(sTol)[0];
+
+ int i,j, r = max(p, q + 1);
+
+ /* Final result is block product
+ * Q0 = A1 SX A1^T + A1 SXZ A2^T + (A1 SXZ A2^T)^T + A2 A2^T ,
+ * where A1 [i,j] = phi[i+j],
+ * A2 [i,j] = ttheta[i+j], and SX, SXZ are defined below */
+ PROTECT(res = allocMatrix(REALSXP, r, r));
+ double *P = REAL(res);
+
+ /* Clean P */
+ Memzero(P, r*r);
+
+#ifdef DEBUG_Q0bis
+#define _ttheta(j) chk_V(ttheta, "ttheta", j, q+1)// was r
+#define _tphi(j) chk_V(tphi, "tphi", j, p+1)
+#define _rrz(j) chk_V(rrz, "rrz", j, q)
+#else
+#define _ttheta(j) ttheta[j]
+#define _tphi(j) tphi[j]
+#define _rrz(j) rrz [j]
+#endif
+
+ double *ttheta = (double *) R_alloc(q + 1, sizeof(double));
+ /* Init ttheta = c(1, theta) */
+ ttheta[0] = 1.;
+ for (i = 1; i < q + 1; ++i) ttheta[i] = theta[i - 1];
+
+ if( p > 0 ) {
+ int r2 = max(p + q, p + 1);
+ SEXP sgam = PROTECT(allocMatrix(REALSXP, r2, r2)),
+ sg = PROTECT(allocVector(REALSXP, r2));
+ double *gam = REAL(sgam);
+ double *g = REAL(sg);
+ double *tphi = (double *) R_alloc(p + 1, sizeof(double));
+ /* Init tphi = c(1, -phi) */
+ tphi[0] = 1.;
+ for (i = 1; i < p + 1; ++i) tphi[i] = -phi[i - 1];
+
+ /* Compute the autocovariance function of U, the AR part of X */
+
+ /* Gam := C1 + C2 ; initialize */
+ Memzero(gam, r2*r2);
+
+ /* C1[E] */
+ for (j = 0; j < r2; ++j)
+ for (i = j; i < r2 && i - j < p + 1; ++i)
+ gam[j*r2 + i] += _tphi(i-j);
+
+ /* C2[E] */
+ for (i = 0; i < r2; ++i)
+ for (j = 1; j < r2 && i + j < p + 1; ++j)
+ gam[j*r2 + i] += _tphi(i+j);
+
+ /* Initialize g = (1 0 0 .... 0) */
+ g[0] = 1.;
+ for (i = 1; i < r2; ++i)
+ g[i] = 0.;
+
+ /* rU = solve(Gam, g) -> solve.default() -> .Internal(La_solve, .,)
+ * --> fiddling with R-objects -> C and then F77_CALL(.) of dgesv, dlange, dgecon
+ * FIXME: call these directly here, possibly even use 'info' instead of error(.)
+ * e.g., in case of exact singularity.
+ */
+ SEXP callS = PROTECT(lang4(install("solve.default"), sgam, sg, sTol)),
+ su = PROTECT(eval(callS, R_BaseEnv));
+ double *u = REAL(su);
+ /* SX = A SU A^T */
+ /* A[i,j] = ttheta[j-i] */
+ /* SU[i,j] = u[abs(i-j)] */
+ /* Q0 += ( A1 SX A1^T == A1 A SU A^T A1^T) */
+ // (relying on good compiler optimization here:)
+ for (i = 0; i < r; ++i)
+ for (j = i; j < r; ++j)
+ for (int k = 0; i + k < p; ++k)
+ for (int L = k; L - k < q + 1; ++L)
+ for (int m = 0; j + m < p; ++m)
+ for (int n = m; n - m < q + 1; ++n)
+ P[r*i + j] += phi[i + k] * phi[j + m] *
+ _ttheta(L - k) * _ttheta(n - m) * u[abs(L - n)];
+ UNPROTECT(4);
+ /* Compute correlation matrix between X and Z */
+ /* forwardsolve(C1, g) */
+ /* C[i,j] = tphi[i-j] */
+ /* g[i] = _ttheta(i) */
+ double *rrz = (double *) R_alloc(q, sizeof(double));
+ if(q > 0) {
+ for (i = 0; i < q; ++i) {
+ rrz[i] = _ttheta(i);
+ for (j = max(0, i - p); j < i; ++j)
+ rrz[i] -= _rrz(j) * _tphi(i-j);
+ }
+ }
+
+ /* Q0 += A1 SXZ A2^T + (A1 SXZ A2^T)^T */
+ /* SXZ[i,j] = rrz[j-i-1], j > 0 */
+ for (i = 0; i < r; ++i)
+ for (j = i; j < r; ++j) {
+ int k, L;
+ for (k = 0; i + k < p; ++k)
+ for (L = k+1; j + L < q + 1; ++L)
+ P[r*i + j] += phi[i + k] * _ttheta(j + L) * _rrz(L - k - 1);
+ for (k = 0; j + k < p; ++k)
+ for (L = k+1; i + L < q + 1; ++L)
+ P[r*i + j] += phi[j + k] * _ttheta(i + L) * _rrz(L - k - 1);
+ }
+ } // end if(p > 0)
+
+ /* Q0 += A2 A2^T */
+ for (i = 0; i < r; ++i)
+ for (j = i; j < r; ++j)
+ for (int k = 0; j + k < q + 1; ++k)
+ P[r*i + j] += _ttheta(i + k) * _ttheta(j + k);
+
+ /* Symmetrize result */
+ for (i = 0; i < r; ++i)
+ for (j = i+1; j < r; ++j)
+ P[r*j + i] = P[r*i + j];
+
+ UNPROTECT(1);
+ return res;
+}
+
+SEXP getQ0(SEXP sPhi, SEXP sTheta)
+{
+ SEXP res;
+ int p = LENGTH(sPhi), q = LENGTH(sTheta);
+ double *phi = REAL(sPhi), *theta = REAL(sTheta);
+
+ /* thetab[np], xnext[np], xrow[np]. rbar[rbar] */
+ /* NB: nrbar could overflow */
+ int r = max(p, q + 1);
+ size_t np = r * (r + 1) / 2, nrbar = np * (np - 1) / 2, npr, npr1;
+ size_t indi, indj, indn, i, j, ithisr, ind, ind1, ind2, im, jm;
+
+
+ /* This is the limit using an int index. We could use
+ size_t and get more on a 64-bit system,
+ but there seems no practical need. */
+ if(r > 350) error(_("maximum supported lag is 350"));
+ double *xnext, *xrow, *rbar, *thetab, *V;
+ xnext = (double *) R_alloc(np, sizeof(double));
+ xrow = (double *) R_alloc(np, sizeof(double));
+ rbar = (double *) R_alloc(nrbar, sizeof(double));
+ thetab = (double *) R_alloc(np, sizeof(double));
+ V = (double *) R_alloc(np, sizeof(double));
+ for (ind = 0, j = 0; j < r; j++) {
+ double vj = 0.0;
+ if (j == 0) vj = 1.0; else if (j - 1 < q) vj = theta[j - 1];
+ for (i = j; i < r; i++) {
+ double vi = 0.0;
+ if (i == 0) vi = 1.0; else if (i - 1 < q) vi = theta[i - 1];
+ V[ind++] = vi * vj;
+ }
+ }
+
+ PROTECT(res = allocMatrix(REALSXP, r, r));
+ double *P = REAL(res);
+
+ if (r == 1) {
+ if (p == 0) P[0] = 1.0; // PR#16419
+ else P[0] = 1.0 / (1.0 - phi[0] * phi[0]);
+ UNPROTECT(1);
+ return res;
+ }
+ if (p > 0) {
+/* The set of equations s * vec(P0) = vec(v) is solved for
+ vec(P0). s is generated row by row in the array xnext. The
+ order of elements in P is changed, so as to bring more leading
+ zeros into the rows of s. */
+
+ for (i = 0; i < nrbar; i++) rbar[i] = 0.0;
+ for (i = 0; i < np; i++) {
+ P[i] = 0.0;
+ thetab[i] = 0.0;
+ xnext[i] = 0.0;
+ }
+ ind = 0;
+ ind1 = -1;
+ npr = np - r;
+ npr1 = npr + 1;
+ indj = npr;
+ ind2 = npr - 1;
+ for (j = 0; j < r; j++) {
+ double phij = (j < p) ? phi[j] : 0.0;
+ xnext[indj++] = 0.0;
+ indi = npr1 + j;
+ for (i = j; i < r; i++) {
+ double ynext = V[ind++];
+ double phii = (i < p) ? phi[i] : 0.0;
+ if (j != r - 1) {
+ xnext[indj] = -phii;
+ if (i != r - 1) {
+ xnext[indi] -= phij;
+ xnext[++ind1] = -1.0;
+ }
+ }
+ xnext[npr] = -phii * phij;
+ if (++ind2 >= np) ind2 = 0;
+ xnext[ind2] += 1.0;
+ inclu2(np, xnext, xrow, ynext, P, rbar, thetab);
+ xnext[ind2] = 0.0;
+ if (i != r - 1) {
+ xnext[indi++] = 0.0;
+ xnext[ind1] = 0.0;
+ }
+ }
+ }
+
+ ithisr = nrbar - 1;
+ im = np - 1;
+ for (i = 0; i < np; i++) {
+ double bi = thetab[im];
+ for (jm = np - 1, j = 0; j < i; j++)
+ bi -= rbar[ithisr--] * P[jm--];
+ P[im--] = bi;
+ }
+
+/* now re-order p. */
+
+ ind = npr;
+ for (i = 0; i < r; i++) xnext[i] = P[ind++];
+ ind = np - 1;
+ ind1 = npr - 1;
+ for (i = 0; i < npr; i++) P[ind--] = P[ind1--];
+ for (i = 0; i < r; i++) P[i] = xnext[i];
+ } else {
+
+/* P0 is obtained by backsubstitution for a moving average process. */
+
+ indn = np;
+ ind = np;
+ for (i = 0; i < r; i++)
+ for (j = 0; j <= i; j++) {
+ --ind;
+ P[ind] = V[ind];
+ if (j != 0) P[ind] += P[--indn];
+ }
+ }
+ /* now unpack to a full matrix */
+ for (i = r - 1, ind = np; i > 0; i--)
+ for (j = r - 1; j >= i; j--)
+ P[r * i + j] = P[--ind];
+ for (i = 0; i < r - 1; i++)
+ for (j = i + 1; j < r; j++)
+ P[i + r * j] = P[j + r * i];
+ UNPROTECT(1);
+ return res;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/bandwidths.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/bandwidths.c
new file mode 100644
index 0000000000..404c4c7477
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/bandwidths.c
@@ -0,0 +1,171 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * bandwidth.c by W. N. Venables and B. D. Ripley Copyright (C) 1994-2001
+ * Copyright (C) 2012-2017 The R Core Team
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/
+ */
+
+#include <stdlib.h> //abs
+#include <math.h>
+#include <Rmath.h> // M_* constants
+#include <Rinternals.h>
+
+// or include "stats.h"
+#ifdef ENABLE_NLS
+#include <libintl.h>
+#define _(String) dgettext ("stats", String)
+#else
+#define _(String) (String)
+#endif
+
+#define DELMAX 1000
+/* Avoid slow and possibly error-producing underflows by cutting off at
+ plus/minus sqrt(DELMAX) std deviations */
+/* Formulae (6.67) and (6.69) of Scott (1992), the latter corrected. */
+
+SEXP bw_ucv(SEXP sn, SEXP sd, SEXP cnt, SEXP sh)
+{
+ double h = asReal(sh), d = asReal(sd), sum = 0.0, term, u;
+ int n = asInteger(sn), nbin = LENGTH(cnt);
+ double *x = REAL(cnt);
+ for (int i = 0; i < nbin; i++) {
+ double delta = i * d / h;
+ delta *= delta;
+ if (delta >= DELMAX) break;
+ term = exp(-delta / 4.) - sqrt(8.0) * exp(-delta / 2.);
+ sum += term * x[i];
+ }
+ u = (0.5 + sum/n) / (n * h * M_SQRT_PI);
+ // = 1 / (2 * n * h * sqrt(PI)) + sum / (n * n * h * sqrt(PI));
+ return ScalarReal(u);
+}
+
+SEXP bw_bcv(SEXP sn, SEXP sd, SEXP cnt, SEXP sh)
+{
+ double h = asReal(sh), d = asReal(sd), sum = 0.0, term, u;
+ int n = asInteger(sn), nbin = LENGTH(cnt);
+ double *x = REAL(cnt);
+
+ sum = 0.0;
+ for (int i = 0; i < nbin; i++) {
+ double delta = i * d / h; delta *= delta;
+ if (delta >= DELMAX) break;
+ term = exp(-delta / 4) * (delta * delta - 12 * delta + 12);
+ sum += term * x[i];
+ }
+ u = (1 + sum/(32.0*n)) / (2.0 * n * h * M_SQRT_PI);
+ // = 1 / (2 * n * h * sqrt(PI)) + sum / (64 * n * n * h * sqrt(PI));
+ return ScalarReal(u);
+}
+
+SEXP bw_phi4(SEXP sn, SEXP sd, SEXP cnt, SEXP sh)
+{
+ double h = asReal(sh), d = asReal(sd), sum = 0.0, term, u;
+ int n = asInteger(sn), nbin = LENGTH(cnt);
+ double *x = REAL(cnt);
+
+ for (int i = 0; i < nbin; i++) {
+ double delta = i * d / h; delta *= delta;
+ if (delta >= DELMAX) break;
+ term = exp(-delta / 2.) * (delta * delta - 6. * delta + 3.);
+ sum += term * x[i];
+ }
+ sum = 2. * sum + n * 3.; /* add in diagonal */
+ u = sum / ((double)n * (n - 1) * pow(h, 5.0)) * M_1_SQRT_2PI;
+ // = sum / (n * (n - 1) * pow(h, 5.0) * sqrt(2 * PI));
+ return ScalarReal(u);
+}
+
+SEXP bw_phi6(SEXP sn, SEXP sd, SEXP cnt, SEXP sh)
+{
+ double h = asReal(sh), d = asReal(sd), sum = 0.0, term, u;
+ int n = asInteger(sn), nbin = LENGTH(cnt);
+ double *x = REAL(cnt);
+
+ for (int i = 0; i < nbin; i++) {
+ double delta = i * d / h; delta *= delta;
+ if (delta >= DELMAX) break;
+ term = exp(-delta / 2) *
+ (delta * delta * delta - 15 * delta * delta + 45 * delta - 15);
+ sum += term * x[i];
+ }
+ sum = 2. * sum - 15. * n; /* add in diagonal */
+ u = sum / ((double)n * (n - 1) * pow(h, 7.0)) * M_1_SQRT_2PI;
+ // = sum / (n * (n - 1) * pow(h, 7.0) * sqrt(2 * PI));
+ return ScalarReal(u);
+}
+
+/*
+ Use double cnt as from R 3.4.0, as counts can exceed INT_MAX for
+ large n (65537 in the worse case but typically not at n = 1 million
+ for a smooth distribution -- and this is by default no longer used
+ for n > 500).
+*/
+
+SEXP bw_den(SEXP nbin, SEXP sx)
+{
+ int nb = asInteger(nbin), n = LENGTH(sx);
+ double xmin, xmax, rang, dd, *x = REAL(sx);
+
+ xmin = R_PosInf; xmax = R_NegInf;
+ for (int i = 0; i < n; i++) {
+ if(!R_FINITE(x[i]))
+ error(_("non-finite x[%d] in bandwidth calculation"), i+1);
+ if(x[i] < xmin) xmin = x[i];
+ if(x[i] > xmax) xmax = x[i];
+ }
+ rang = (xmax - xmin) * 1.01;
+ dd = rang / nb;
+
+ SEXP ans = PROTECT(allocVector(VECSXP, 2)),
+ sc = SET_VECTOR_ELT(ans, 1, allocVector(REALSXP, nb));
+ SET_VECTOR_ELT(ans, 0, ScalarReal(dd));
+ double *cnt = REAL(sc);
+ for (int i = 0; i < nb; i++) cnt[i] = 0.0;
+
+ for (int i = 1; i < n; i++) {
+ int ii = (int)(x[i] / dd);
+ for (int j = 0; j < i; j++) {
+ int jj = (int)(x[j] / dd);
+ cnt[abs(ii - jj)] += 1.0;
+ }
+ }
+
+ UNPROTECT(1);
+ return ans;
+}
+
+/* Input: counts for nb bins */
+SEXP bw_den_binned(SEXP sx)
+{
+ int nb = LENGTH(sx);
+ int *x = INTEGER(sx);
+
+ SEXP ans = PROTECT(allocVector(REALSXP, nb));
+ double *cnt = REAL(ans);
+ for (int ib = 0; ib < nb; ib++) cnt[ib] = 0.0;
+
+ for (int ii = 0; ii < nb; ii++) {
+ int w = x[ii];
+ cnt[0] += w*(w-1.); // don't count distances to self
+ for (int jj = 0; jj < ii; jj++)
+ cnt[ii - jj] += w * x[jj];
+ }
+ cnt[0] *= 0.5; // counts in the same bin got double-counted
+
+ UNPROTECT(1);
+ return ans;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/burg.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/burg.c
new file mode 100644
index 0000000000..df4e814235
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/burg.c
@@ -0,0 +1,82 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+
+ * Copyright (C) 1999-2016 The R Core Team
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/.
+ */
+
+#include <R.h>
+
+static void
+burg(int n, double*x, int pmax, double *coefs, double *var1, double *var2)
+{
+ double d, phii, *u, *v, *u0, sum;
+
+ u = (double *) R_alloc(n, sizeof(double));
+ v = (double *) R_alloc(n, sizeof(double));
+ u0 = (double *) R_alloc(n, sizeof(double));
+
+ for(int i = 0; i < pmax*pmax; i++) coefs[i] = 0.0;
+ sum = 0.0;
+ for(int t = 0; t < n; t++) {
+ u[t] = v[t] = x[n - 1 - t];
+ sum += x[t] * x[t];
+ }
+ var1[0] = var2[0] = sum/n;
+ for(int p = 1; p <= pmax; p++) { /* do AR(p) */
+ sum = 0.0;
+ d = 0;
+ for(int t = p; t < n; t++) {
+ sum += v[t]*u[t-1];
+ d += v[t]*v[t] + u[t-1]*u[t-1];
+ }
+ phii = 2*sum/d;
+ coefs[pmax*(p-1) + (p-1)] = phii;
+ if(p > 1)
+ for(int j = 1; j < p; j++)
+ coefs[p-1 + pmax*(j-1)] =
+ coefs[p-2 + pmax*(j-1)] - phii* coefs[p-2 + pmax*(p-j-1)];
+ /* update u and v */
+ for(int t = 0; t < n; t++)
+ u0[t] = u[t];
+ for(int t = p; t < n; t++) {
+ u[t] = u0[t-1] - phii * v[t];
+ v[t] = v[t] - phii * u0[t-1];
+ }
+ var1[p] = var1[p-1] * (1 - phii * phii);
+ d = 0.0;
+ for(int t = p; t < n; t++) d += v[t]*v[t] + u[t]*u[t];
+ var2[p] = d/(2.0*(n-p));
+ }
+}
+
+#include <Rinternals.h>
+
+SEXP Burg(SEXP x, SEXP order)
+{
+ x = PROTECT(coerceVector(x, REALSXP));
+ int n = LENGTH(x), pmax = asInteger(order);
+ SEXP coefs = PROTECT(allocVector(REALSXP, pmax * pmax)),
+ var1 = PROTECT(allocVector(REALSXP, pmax + 1)),
+ var2 = PROTECT(allocVector(REALSXP, pmax + 1));
+ burg(n, REAL(x), pmax, REAL(coefs), REAL(var1), REAL(var2));
+ SEXP ans = PROTECT(allocVector(VECSXP, 3));
+ SET_VECTOR_ELT(ans, 0, coefs);
+ SET_VECTOR_ELT(ans, 1, var1);
+ SET_VECTOR_ELT(ans, 2, var2);
+ UNPROTECT(5);
+ return ans;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/d2x2xk.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/d2x2xk.c
new file mode 100644
index 0000000000..0047ee6f35
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/d2x2xk.c
@@ -0,0 +1,65 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2000-2016 The R Core Team.
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/
+ */
+
+/* for mantelhaen.test */
+
+#include <R.h>
+#include <Rmath.h>
+
+static void
+int_d2x2xk(int K, double *m, double *n, double *t, double *d)
+{
+ int i, j, l, w, y, z;
+ double u, **c;
+
+ c = (double **) R_alloc(K + 1, sizeof(double *));
+ l = y = z = 0;
+ c[0] = (double *) R_alloc(1, sizeof(double));
+ c[0][0] = 1;
+ for(i = 0; i < K; i++) {
+ y = imax2(0, (int)(*t - *n));
+ z = imin2((int)*m, (int)*t);
+ c[i + 1] = (double *) R_alloc(l + z - y + 1, sizeof(double));
+ for(j = 0; j <= l + z - y; j++) c[i + 1][j] = 0;
+ for(j = 0; j <= z - y; j++) {
+ u = dhyper(j + y, *m, *n, *t, FALSE);
+ for(w = 0; w <= l; w++) c[i + 1][w + j] += c[i][w] * u;
+ }
+ l = l + z - y;
+ m++; n++; t++;
+ }
+
+ u = 0;
+ for(j = 0; j <= l; j++) u += c[K][j];
+ for(j = 0; j <= l; j++) d[j] = c[K][j] / u;
+}
+
+#include <Rinternals.h>
+
+SEXP d2x2xk(SEXP sK, SEXP m, SEXP n, SEXP t, SEXP srn)
+{
+ int K = asInteger(sK), rn = asInteger(srn);
+ m = PROTECT(coerceVector(m, REALSXP));
+ n = PROTECT(coerceVector(n, REALSXP));
+ t = PROTECT(coerceVector(t, REALSXP));
+ SEXP ans = PROTECT(allocVector(REALSXP, rn));
+ int_d2x2xk(K, REAL(m), REAL(n), REAL(t), REAL(ans));
+ UNPROTECT(4);
+ return ans;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/family.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/family.c
new file mode 100644
index 0000000000..ab96566199
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/family.c
@@ -0,0 +1,155 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2005-2016 The R Core Team
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/
+ *
+ * Quartz Quartz device module header file
+ *
+ */
+
+#include <Rinternals.h>
+#include <Rconfig.h>
+#include <R_ext/Constants.h>
+#include <float.h>
+#include <math.h>
+#include "stats.h"
+#include "statsR.h"
+
+static const double THRESH = 30.;
+static const double MTHRESH = -30.;
+static const double INVEPS = 1/DOUBLE_EPS;
+
+/**
+ * Evaluate x/(1 - x). An inline function is used so that x is
+ * evaluated once only.
+ *
+ * @param x input in the range (0, 1)
+ *
+ * @return x/(1 - x)
+ */
+static R_INLINE double x_d_omx(double x) {
+ if (x < 0 || x > 1)
+ error(_("Value %g out of range (0, 1)"), x);
+ return x/(1 - x);
+}
+
+/**
+ * Evaluate x/(1 + x). An inline function is used so that x is
+ * evaluated once only. [but inlining is optional!]
+ *
+ * @param x input
+ *
+ * @return x/(1 + x)
+ */
+static R_INLINE double x_d_opx(double x) {return x/(1 + x);}
+
+SEXP logit_link(SEXP mu)
+{
+ int i, n = LENGTH(mu);
+ SEXP ans = PROTECT(shallow_duplicate(mu));
+ double *rans = REAL(ans), *rmu=REAL(mu);
+
+ if (!n || !isReal(mu))
+ error(_("Argument %s must be a nonempty numeric vector"), "mu");
+ for (i = 0; i < n; i++)
+ rans[i] = log(x_d_omx(rmu[i]));
+ UNPROTECT(1);
+ return ans;
+}
+
+SEXP logit_linkinv(SEXP eta)
+{
+ SEXP ans = PROTECT(shallow_duplicate(eta));
+ int i, n = LENGTH(eta);
+ double *rans = REAL(ans), *reta = REAL(eta);
+
+ if (!n || !isReal(eta))
+ error(_("Argument %s must be a nonempty numeric vector"), "eta");
+ for (i = 0; i < n; i++) {
+ double etai = reta[i], tmp;
+ tmp = (etai < MTHRESH) ? DOUBLE_EPS :
+ ((etai > THRESH) ? INVEPS : exp(etai));
+ rans[i] = x_d_opx(tmp);
+ }
+ UNPROTECT(1);
+ return ans;
+}
+
+SEXP logit_mu_eta(SEXP eta)
+{
+ SEXP ans = PROTECT(shallow_duplicate(eta));
+ int i, n = LENGTH(eta);
+ double *rans = REAL(ans), *reta = REAL(eta);
+
+ if (!n || !isReal(eta))
+ error(_("Argument %s must be a nonempty numeric vector"), "eta");
+ for (i = 0; i < n; i++) {
+ double etai = reta[i];
+ double opexp = 1 + exp(etai);
+
+ rans[i] = (etai > THRESH || etai < MTHRESH) ? DOUBLE_EPS :
+ exp(etai)/(opexp * opexp);
+ }
+ UNPROTECT(1);
+ return ans;
+}
+
+static R_INLINE
+double y_log_y(double y, double mu)
+{
+ return (y != 0.) ? (y * log(y/mu)) : 0;
+}
+
+SEXP binomial_dev_resids(SEXP y, SEXP mu, SEXP wt)
+{
+ int i, n = LENGTH(y), lmu = LENGTH(mu), lwt = LENGTH(wt), nprot = 1;
+ SEXP ans;
+ double mui, yi, *rmu, *ry, *rwt, *rans;
+
+ if (!isReal(y)) {y = PROTECT(coerceVector(y, REALSXP)); nprot++;}
+ ry = REAL(y);
+ ans = PROTECT(shallow_duplicate(y));
+ rans = REAL(ans);
+ if (!isReal(mu)) {mu = PROTECT(coerceVector(mu, REALSXP)); nprot++;}
+ if (!isReal(wt)) {wt = PROTECT(coerceVector(wt, REALSXP)); nprot++;}
+ rmu = REAL(mu);
+ rwt = REAL(wt);
+ if (lmu != n && lmu != 1)
+ error(_("argument %s must be a numeric vector of length 1 or length %d"),
+ "mu", n);
+ if (lwt != n && lwt != 1)
+ error(_("argument %s must be a numeric vector of length 1 or length %d"),
+ "wt", n);
+ /* Written separately to avoid an optimization bug on Solaris cc */
+ if(lmu > 1) {
+ for (i = 0; i < n; i++) {
+ mui = rmu[i];
+ yi = ry[i];
+ rans[i] = 2 * rwt[lwt > 1 ? i : 0] *
+ (y_log_y(yi, mui) + y_log_y(1 - yi, 1 - mui));
+ }
+ } else {
+ mui = rmu[0];
+ for (i = 0; i < n; i++) {
+ yi = ry[i];
+ rans[i] = 2 * rwt[lwt > 1 ? i : 0] *
+ (y_log_y(yi, mui) + y_log_y(1 - yi, 1 - mui));
+ }
+ }
+
+ UNPROTECT(nprot);
+ return ans;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/fexact.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/fexact.c
new file mode 100644
index 0000000000..7d9c64aa43
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/fexact.c
@@ -0,0 +1,2077 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 1999-2010 The R Core Team.
+ *
+ * Based on ACM TOMS643 (1993)
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/
+ */
+
+/* -*- mode: c; kept-new-versions: 25; kept-old-versions: 20 -*-
+
+ Fisher's exact test for contingency tables -- usage see below
+
+ fexact.f -- translated by f2c (version 19971204).
+ Run through a slightly modified version of MM's f2c-clean.
+ Heavily hand-edited by KH and MM.
+ */
+
+/* <UTF8> chars are handled as whole strings */
+
+#include <stdio.h>
+#include <limits.h>
+#include <math.h>
+#include <R.h>
+
+static void f2xact(int nrow, int ncol, int *table, int ldtabl,
+ double *expect, double *percnt, double *emin,
+ double *prt, double *pre, double *fact, int *ico, int *iro,
+ int *kyy, int *idif, int *irn, int *key,
+ int *ldkey, int *ipoin, double *stp, int *ldstp,
+ int *ifrq, double *LP, double *SP, double *tm,
+ int *key2, int *iwk, double *rwk);
+static double f3xact(int nrow, int *irow, int ncol, int *icol, int ntot,
+ double *fact, int *ico, int *iro,
+ int *it, int *lb, int *nr, int *nt, int *nu,
+ int *itc, int *ist, double *stv, double *alen,
+ const double *tol);
+static double f4xact(int nrow, int *irow, int ncol, int *icol, double dspt,
+ double *fact, int *icstk, int *ncstk,
+ int *lstk, int *mstk, int *nstk, int *nrstk, int *irstk,
+ double *ystk, const double *tol);
+static void f5xact(double *pastp, const double *tol, int *kval, int *key,
+ int *ldkey, int *ipoin, double *stp, int *ldstp,
+ int *ifrq, int *npoin, int *nr, int *nl, int *ifreq,
+ int *itop, Rboolean psh);
+static Rboolean f6xact(int nrow, int *irow, int *kyy,
+ int *key, int *ldkey, int *last, int *ipn);
+static void f7xact(int nrow, int *imax, int *idif, int *k, int *ks,
+ int *iflag);
+static void f8xact(int *irow, int is, int i1, int izero, int *new);
+static double f9xact(int n, int ntot, int *ir, double *fact);
+static Rboolean f10act(int nrow, int *irow, int ncol, int *icol, double *val,
+ double *fact, int *nd, int *ne, int *m);
+static void f11act(int *irow, int i1, int i2, int *new);
+static void NORET prterr(int icode, const char *mes);
+static int iwork(int iwkmax, int *iwkpt, int number, int itype);
+
+#ifdef USING_R
+# define isort(n, ix) R_isort(ix, *n)
+# include <Rmath.h> /* -> pgamma() */
+#else
+ static void isort(int *n, int *ix);
+ static double gammds(double *y, double *p, int *ifault);
+ static double alogam(double *x, int *ifault);
+#endif
+
+/* The only public function : */
+void
+fexact(int *nrow, int *ncol, int *table, int *ldtabl,
+ double *expect, double *percnt, double *emin, double *prt,
+ double *pre, /* new in C : */ int *workspace,
+ /* new arg, was const = 30*/int *mult)
+{
+
+/*
+ ALGORITHM 643, COLLECTED ALGORITHMS FROM ACM.
+ THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
+ VOL. 19, NO. 4, DECEMBER, 1993, PP. 484-488.
+ -----------------------------------------------------------------------
+ Name: FEXACT
+ Purpose: Computes Fisher's exact test probabilities and a hybrid
+ approximation to Fisher exact test probabilities for a
+ contingency table using the network algorithm.
+
+ Arguments:
+ NROW - The number of rows in the table. (Input)
+ NCOL - The number of columns in the table. (Input)
+ TABLE - NROW by NCOL matrix containing the contingency
+ table. (Input)
+ LDTABL - Leading dimension of TABLE exactly as specified
+ in the dimension statement in the calling
+ program. (Input)
+ EXPECT - Expected value used in the hybrid algorithm for
+ deciding when to use asymptotic theory
+ probabilities. (Input)
+ If EXPECT <= 0.0 then asymptotic theory probabilities
+ are not used and Fisher exact test probabilities are
+ computed. Otherwise, if PERCNT or more of the cells in
+ the remaining table have estimated expected values of
+ EXPECT or more, with no remaining cell having expected
+ value less than EMIN, then asymptotic chi-squared
+ probabilities are used. See the algorithm section of the
+ manual document for details.
+ Use EXPECT = 5.0 to obtain the 'Cochran' condition.
+ PERCNT - Percentage of remaining cells that must have
+ estimated expected values greater than EXPECT
+ before asymptotic probabilities can be used. (Input)
+ See argument EXPECT for details.
+ Use PERCNT = 80.0 to obtain the 'Cochran' condition.
+ EMIN - Minimum cell estimated expected value allowed for
+ asymptotic chi-squared probabilities to be used. (Input)
+ See argument EXPECT for details.
+ Use EMIN = 1.0 to obtain the 'Cochran' condition.
+ PRT - Probability of the observed table for fixed
+ marginal totals. (Output)
+ PRE - Table p-value. (Output)
+ PRE is the probability of a more extreme table,
+ where `extreme' is in a probabilistic sense.
+ If EXPECT < 0 then the Fisher exact probability
+ is returned. Otherwise, an approximation to the
+ Fisher exact probability is computed based upon
+ asymptotic chi-squared probabilities for ``large''
+ table expected values. The user defines ``large''
+ through the arguments EXPECT, PERCNT, and EMIN.
+
+ Remarks:
+ 1. For many problems one megabyte or more of workspace can be
+ required. If the environment supports it, the user should begin
+ by increasing the workspace used to 200,000 units.
+ 2. In FEXACT, LDSTP = MULT*LDKEY. The proportion of table space used
+ by STP may be changed by changing the line MULT = 30 below to
+ another value. --> MULT is now an __argument__ of the function
+ 3. FEXACT may be converted to single precision by setting IREAL = 3,
+ and converting all DOUBLE PRECISION specifications (except the
+ specifications for RWRK, IWRK, and DWRK) to REAL. This will
+ require changing the names and specifications of the intrinsic
+ functions ALOG, AMAX1, AMIN1, EXP, and REAL. In addition, the
+ machine specific constants will need to be changed, and the name
+ DWRK will need to be changed to RWRK in the call to F2XACT.
+ 4. Machine specific constants are specified and documented in F2XACT.
+ A missing value code is specified in both FEXACT and F2XACT.
+ 5. Although not a restriction, is is not generally practical to call
+ this routine with large tables which are not sparse and in
+ which the 'hybrid' algorithm has little effect. For example,
+ although it is feasible to compute exact probabilities for the
+ table
+ 1 8 5 4 4 2 2
+ 5 3 3 4 3 1 0
+ 10 1 4 0 0 0 0,
+ computing exact probabilities for a similar table which has been
+ enlarged by the addition of an extra row (or column) may not be
+ feasible.
+ -----------------------------------------------------------------------
+ */
+
+ /* CONSTANT Parameters : */
+
+ /* To increase the length of the table of past path lengths relative
+ to the length of the hash table, increase MULT.
+ */
+
+ /* AMISS is a missing value indicator which is returned when the
+ probability is not defined.
+ */
+ const double amiss = -12345.;
+ /*
+ Set IREAL = 4 for DOUBLE PRECISION
+ Set IREAL = 3 for SINGLE PRECISION
+ */
+#define i_real 4
+#define i_int 2
+
+ /* System generated locals */
+ int ikh;
+ /* Local variables */
+ int nco, nro, ntot, numb, iiwk, irwk;
+ int i, j, k, kk, ldkey, ldstp, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10;
+ int i3a, i3b, i3c, i9a, iwkmax, iwkpt;
+
+ /* Workspace Allocation (freed when returning to R) */
+ double *equiv;
+ iwkmax = 2 * (int) (*workspace / 2);
+ equiv = (double *) R_alloc(iwkmax / 2, sizeof(double));
+
+#define dwrk (equiv)
+#define iwrk ((int *)equiv)
+#define rwrk ((float *)equiv)
+
+ /* Function Body */
+ iwkpt = 0;
+
+ if (*nrow > *ldtabl)
+ prterr(1, "NROW must be less than or equal to LDTABL.");
+
+ ntot = 0;
+ for (i = 0; i < *nrow; ++i) {
+ for (j = 0; j < *ncol; ++j) {
+ if (table[i + j * *ldtabl] < 0)
+ prterr(2, "All elements of TABLE may not be negative.");
+ ntot += table[i + j * *ldtabl];
+ }
+ }
+ if (ntot == 0) {
+ prterr(3, "All elements of TABLE are zero.\n"
+ "PRT and PRE are set to missing values.");
+ *pre = *prt = amiss;
+ return;
+ }
+
+ /* nco := max(*nrow, *ncol)
+ * nro := min(*nrow, *ncol) */
+ if(*ncol > *nrow) {
+ nco = *ncol;
+ nro = *nrow;
+ } else {
+ nco = *nrow;
+ nro = *ncol;
+ }
+ k = *nrow + *ncol + 1;
+ kk = k * nco;
+
+ ikh = ntot + 1;
+ i1 = iwork(iwkmax, &iwkpt, ikh, i_real);
+ i2 = iwork(iwkmax, &iwkpt, nco, i_int);
+ i3 = iwork(iwkmax, &iwkpt, nco, i_int);
+ i3a = iwork(iwkmax, &iwkpt, nco, i_int);
+ i3b = iwork(iwkmax, &iwkpt, nro, i_int);
+ i3c = iwork(iwkmax, &iwkpt, nro, i_int);
+ ikh = imax2(k * 5 + (kk << 1), nco * 7 + 800);
+ iiwk= iwork(iwkmax, &iwkpt, ikh, i_int);
+ ikh = imax2(nco + 401, k);
+ irwk= iwork(iwkmax, &iwkpt, ikh, i_real);
+
+ /* NOTE:
+ What follows below splits the remaining amount iwkmax - iwkpt of
+ (int) workspace into hash tables as follows.
+ type size index
+ INT 2 * ldkey i4 i5 i11
+ REAL 2 * ldkey i8 i9 i10
+ REAL 2 * ldstp i6
+ INT 6 * ldstp i7
+ Hence, we need ldkey times
+ 3 * 2 + 3 * 2 * s + 2 * mult * s + 6 * mult
+ chunks of integer memory, where s = sizeof(REAL) / sizeof(INT).
+ If doubles are used and are twice as long as ints, this gives
+ 18 + 10 * mult
+ so that the value of ldkey can be obtained by dividing available
+ (int) workspace by this number.
+
+ In fact, because iwork() can actually s * n + s - 1 int chunks
+ when allocating a REAL, we use ldkey = available / numb - 1.
+
+ FIXME:
+ Can we always assume that sizeof(double) / sizeof(int) is 2?
+ */
+
+ if (i_real == 4) { /* Double precision reals */
+ numb = 18 + 10 * *mult;
+ } else { /* Single precision reals */
+ numb = (*mult << 3) + 12;
+ }
+ ldkey = (iwkmax - iwkpt) / numb - 1;
+ ldstp = *mult * ldkey;
+ ikh = ldkey << 1; i4 = iwork(iwkmax, &iwkpt, ikh, i_int);
+ ikh = ldkey << 1; i5 = iwork(iwkmax, &iwkpt, ikh, i_int);
+ ikh = ldstp << 1; i6 = iwork(iwkmax, &iwkpt, ikh, i_real);
+ ikh = ldstp * 6; i7 = iwork(iwkmax, &iwkpt, ikh, i_int);
+ ikh = ldkey << 1; i8 = iwork(iwkmax, &iwkpt, ikh, i_real);
+ ikh = ldkey << 1; i9 = iwork(iwkmax, &iwkpt, ikh, i_real);
+ ikh = ldkey << 1; i9a = iwork(iwkmax, &iwkpt, ikh, i_real);
+ ikh = ldkey << 1; i10 = iwork(iwkmax, &iwkpt, ikh, i_int);
+
+
+ /* To convert to double precision, change RWRK to DWRK in the next CALL.
+ */
+ f2xact(*nrow,
+ *ncol,
+ table,
+ *ldtabl,
+ expect,
+ percnt,
+ emin,
+ prt,
+ pre,
+ dwrk + i1,
+ iwrk + i2,
+ iwrk + i3,
+ iwrk + i3a,
+ iwrk + i3b,
+ iwrk + i3c,
+ iwrk + i4,
+ &ldkey,
+ iwrk + i5,
+ dwrk + i6,
+ &ldstp,
+ iwrk + i7,
+ dwrk + i8,
+ dwrk + i9,
+ dwrk + i9a,
+ iwrk + i10,
+ iwrk + iiwk,
+ dwrk + irwk);
+
+ return;
+}
+
+#undef rwrk
+#undef iwrk
+#undef dwrk
+
+
+void
+f2xact(int nrow, int ncol, int *table, int ldtabl,
+ double *expect, double *percnt, double *emin, double *prt,
+ double *pre, double *fact, int *ico, int *iro, int *kyy,
+ int *idif, int *irn, int *key, int *ldkey, int *ipoin,
+ double *stp, int *ldstp, int *ifrq, double *LP, double *SP,
+ double *tm, int *key2, int *iwk, double *rwk)
+{
+/*
+ -----------------------------------------------------------------------
+ Name: F2XACT
+ Purpose: Computes Fisher's exact test for a contingency table,
+ routine with workspace variables specified.
+ -----------------------------------------------------------------------
+ */
+ const int imax = INT_MAX;/* the largest representable int on the machine.*/
+
+ /* AMISS is a missing value indicator which is returned when the
+ probability is not defined. */
+ const double amiss = -12345.;
+
+ /* TOL is chosen as the square root of the smallest relative spacing. */
+ const static double tol = 3.45254e-7;
+
+ const char* ch_err_5 =
+ "The hash table key cannot be computed because the largest key\n"
+ "is larger than the largest representable int.\n"
+ "The algorithm cannot proceed.\n"
+ "Reduce the workspace size or use another algorithm.";
+
+ /* Local variables -- changed from "static"
+ * (*does* change results very slightly on i386 linux) */
+ int i, ii, j, k, n,
+ iflag,ifreq, ikkey, ikstp, ikstp2, ipn, ipo, itop, itp = 0,
+ jkey, jstp, jstp2, jstp3, jstp4, k1, kb, kd, ks, kval = 0, kmax, last,
+ ncell, ntot, nco, nro, nro2, nrb,
+ i31, i32, i33, i34, i35, i36, i37, i38, i39,
+ i41, i42, i43, i44, i45, i46, i47, i48, i310, i311;
+
+ double dspt, d1,dd,df,ddf, drn,dro, obs, obs2, obs3, pastp,pv, tmp=0.;
+
+#ifndef USING_R
+ double d2;
+ int ifault;
+#endif
+ Rboolean nr_gt_nc, maybe_chisq, chisq = FALSE/* -Wall */, psh;
+
+ /* Parameter adjustments */
+ table -= ldtabl + 1;
+ --ico;
+ --iro;
+ --kyy;
+ --idif;
+ --irn;
+
+ --key;
+ --ipoin;
+ --stp;
+ --ifrq;
+ --LP;
+ --SP;
+ --tm;
+ --key2;
+ --iwk;
+ --rwk;
+
+
+ /* Check table dimensions */
+ if (nrow > ldtabl)
+ prterr(1, "NROW must be less than or equal to LDTABL.");
+ if (ncol <= 1)
+ prterr(4, "NCOL must be at least 2");
+
+ /* Initialize KEY array */
+ for (i = 1; i <= *ldkey << 1; ++i) {
+ key[i] = -9999;
+ key2[i] = -9999;
+ }
+
+ nr_gt_nc = nrow > ncol;
+ /* nco := max(nrow, ncol) : */
+ if(nr_gt_nc)
+ nco = nrow;
+ else
+ nco = ncol;
+ /* Compute row marginals and total */
+ ntot = 0;
+ for (i = 1; i <= nrow; ++i) {
+ iro[i] = 0;
+ for (j = 1; j <= ncol; ++j) {
+ if (table[i + j * ldtabl] < 0.)
+ prterr(2, "All elements of TABLE may not be negative.");
+ iro[i] += table[i + j * ldtabl];
+ }
+ ntot += iro[i];
+ }
+
+ if (ntot == 0) {
+ prterr(3, "All elements of TABLE are zero.\n"
+ "PRT and PRE are set to missing values.");
+ *pre = *prt = amiss;
+ return;
+ }
+
+ /* Column marginals */
+ for (i = 1; i <= ncol; ++i) {
+ ico[i] = 0;
+ for (j = 1; j <= nrow; ++j)
+ ico[i] += table[j + i * ldtabl];
+ }
+
+ /* sort marginals */
+ isort(&nrow, &iro[1]);
+ isort(&ncol, &ico[1]);
+
+ /* Determine row and column marginals.
+ Define max(nrow,ncol) =: nco >= nro := min(nrow,ncol)
+ nco is defined above
+
+ Swap marginals if necessary to ico[1:nco] & iro[1:nro]
+ */
+ if (nr_gt_nc) {
+ nro = ncol;
+ /* Swap marginals */
+ for (i = 1; i <= nco; ++i) {
+ ii = iro[i];
+ if (i <= nro)
+ iro[i] = ico[i];
+ ico[i] = ii;
+ }
+ } else
+ nro = nrow;
+
+ /* Get multiplers for stack */
+ kyy[1] = 1;
+ for (i = 1; i < nro; ++i) {
+ /* Hash table multipliers */
+ if (iro[i] + 1 <= imax / kyy[i]) {
+ kyy[i + 1] = kyy[i] * (iro[i] + 1);
+ j /= kyy[i];
+ }
+ else {
+ prterr(5, ch_err_5);
+ return;
+ }
+ }
+
+ /* Check for Maximum product : */
+ /* original code: if (iro[nro - 1] + 1 > imax / kyy[nro - 1]) */
+ if (iro[nro] + 1 > imax / kyy[nro]) {
+ /* L_ERR_5: */
+ prterr(501, ch_err_5);
+ return;
+ }
+
+ /* Compute log factorials */
+ fact[0] = 0.;
+ fact[1] = 0.;
+ if(ntot >= 2) fact[2] = log(2.);
+ /* MM: old code assuming log() to be SLOW */
+ for (i = 3; i <= ntot; i += 2) {
+ fact[i] = fact[i - 1] + log((double) i);
+ j = i + 1;
+ if (j <= ntot)
+ fact[j] = fact[i] + fact[2] + fact[j / 2] - fact[j / 2 - 1];
+ }
+ /* Compute obs := observed path length */
+ obs = tol;
+ ntot = 0;
+ for (j = 1; j <= nco; ++j) {
+ dd = 0.;
+ if (nr_gt_nc) {
+ for (i = 1; i <= nro; ++i) {
+ dd += fact[table[j + i * ldtabl]];
+ ntot += table[j + i * ldtabl];
+ }
+ } else {
+ for (i = 1, ii = j * ldtabl + 1; i <= nro; i++, ii++) {
+ dd += fact[table[ii]];
+ ntot += table[ii];
+ }
+ }
+ obs += fact[ico[j]] - dd;
+ }
+
+ /* Denominator of observed table: DRO */
+ dro = f9xact(nro, ntot, &iro[1], fact);
+ /* improve: the following "easily" underflows to zero -- return "log()" */
+ *prt = exp(obs - dro);
+ *pre = 0.;
+ itop = 0;
+ maybe_chisq = (*expect > 0.);
+
+ /* Initialize pointers for workspace */
+ /* f3xact */
+ i31 = 1;
+ i32 = i31 + nco;
+ i33 = i32 + nco;
+ i34 = i33 + nco;
+ i35 = i34 + nco;
+ i36 = i35 + nco;
+ i37 = i36 + nco;
+ i38 = i37 + nco;
+ i39 = i38 + 400;
+ i310 = 1;
+ i311 = 1 + 400;
+ /* f4xact */
+ i = nrow + ncol + 1;
+ i41 = 1;
+ i42 = i41 + i;
+ i43 = i42 + i;
+ i44 = i43 + i;
+ i45 = i44 + i;
+ i46 = i45 + i;
+ i47 = i46 + i * nco;
+ i48 = 1;
+
+ /* Initialize pointers */
+ k = nco;
+ last = *ldkey + 1;
+ jkey = *ldkey + 1;
+ jstp = *ldstp + 1;
+ jstp2 = *ldstp * 3 + 1;
+ jstp3 = (*ldstp << 2) + 1;
+ jstp4 = *ldstp * 5 + 1;
+ ikkey = 0;
+ ikstp = 0;
+ ikstp2 = *ldstp << 1;
+ ipo = 1;
+ ipoin[1] = 1;
+ stp[1] = 0.;
+ ifrq[1] = 1;
+ ifrq[ikstp2 + 1] = -1;
+
+Outer_Loop:
+ kb = nco - k + 1;
+ ks = 0;
+ n = ico[kb];
+ kd = nro + 1;
+ kmax = nro;
+ /* IDIF is the difference in going to the daughter */
+ for (i = 1; i <= nro; ++i)
+ idif[i] = 0;
+
+ /* Generate the first daughter */
+ do {
+ --kd;
+ ntot = imin2(n, iro[kd]);
+ idif[kd] = ntot;
+ if (idif[kmax] == 0)
+ --kmax;
+ n -= ntot;
+
+ } while (n > 0 && kd != 1);
+
+ if (n != 0) /* i.e. kd == 1 */
+ goto L310;
+
+
+ k1 = k - 1;
+ n = ico[kb];
+ ntot = 0;
+ for (i = kb + 1; i <= nco; ++i)
+ ntot += ico[i];
+
+
+L150:
+ /* Arc to daughter length=ICO[KB] */
+ for (i = 1; i <= nro; ++i)
+ irn[i] = iro[i] - idif[i];
+
+ if (k1 > 1) {
+ /* Sort irn */
+ if (nro == 2) {
+ if (irn[1] > irn[2]) {
+ ii = irn[1]; irn[1] = irn[2]; irn[2] = ii;
+ }
+ } else
+ isort(&nro, &irn[1]);
+
+ /* Adjust start for zero */
+ for (i = 1; i <= nro; ++i) {
+ if (irn[i] != 0)
+ break;
+ }
+ nrb = i;
+ }
+ else {
+ nrb = 1;
+ }
+ nro2 = nro - nrb + 1;
+
+ /* Some table values */
+ ddf = f9xact(nro, n, &idif[1], fact);
+ drn = f9xact(nro2, ntot, &irn[nrb], fact) - dro + ddf;
+ /* Get hash value */
+ if (k1 > 1) {
+ kval = irn[1];
+ /* Note that with the corrected check at error "502",
+ * we won't have overflow in kval below : */
+ for (i = 2; i <= nro; ++i)
+ kval += irn[i] * kyy[i];
+
+ /* Get hash table entry */
+ i = kval % (*ldkey << 1) + 1;
+ /* Search for unused location */
+ for (itp = i; itp <= *ldkey << 1; ++itp) {
+ ii = key2[itp];
+ if (ii == kval) {
+ goto L240;
+ } else if (ii < 0) {
+ key2[itp] = kval;
+ LP[itp] = 1.;
+ SP[itp] = 1.;
+ goto L240;
+ }
+ }
+
+ for (itp = 1; itp <= i - 1; ++itp) {
+ ii = key2[itp];
+ if (ii == kval) {
+ goto L240;
+ } else if (ii < 0) {
+ key2[itp] = kval;
+ LP[itp] = 1.;
+ goto L240;
+ }
+ }
+
+ /* KH
+ prterr(6, "LDKEY is too small.\n"
+ "It is not possible to give the value of LDKEY required,\n"
+ "but you could try doubling LDKEY (and possibly LDSTP).");
+ */
+ prterr(6, "LDKEY is too small for this problem.\n"
+ "Try increasing the size of the workspace.");
+ }
+
+L240:
+ psh = TRUE;
+ /* Recover pastp */
+ ipn = ipoin[ipo + ikkey];
+ pastp = stp[ipn + ikstp];
+ ifreq = ifrq[ipn + ikstp];
+ /* Compute shortest and longest path */
+ if (k1 > 1) {
+ obs2 = obs - fact[ico[kb + 1]] - fact[ico[kb + 2]] - ddf;
+ for (i = 3; i <= k1; ++i)
+ obs2 -= fact[ico[kb + i]];
+
+ if (LP[itp] > 0.) {
+ dspt = obs - obs2 - ddf;
+ /* Compute longest path */
+ LP[itp] = f3xact(nro2, &irn[nrb], k1, &ico[kb + 1], ntot, fact,
+ &iwk[i31], &iwk[i32], &iwk[i33], &iwk[i34],
+ &iwk[i35], &iwk[i36], &iwk[i37], &iwk[i38],
+ &iwk[i39], &rwk[i310], &rwk[i311], &tol);
+ if(LP[itp] > 0.) {/* can this happen? */
+ REprintf("___ LP[itp=%d] = %g > 0\n", itp, LP[itp]);
+ LP[itp] = 0.;
+ }
+
+ /* Compute shortest path -- using dspt as offset */
+ SP[itp] = f4xact(nro2, &irn[nrb], k1, &ico[kb + 1], dspt, fact,
+ &iwk[i47], &iwk[i41], &iwk[i42], &iwk[i43],
+ &iwk[i44], &iwk[i45], &iwk[i46], &rwk[i48], &tol);
+ /* SP[itp] = fmin2(0., SP[itp] - dspt);*/
+ if(SP[itp] > 0.) { /* can this happen? */
+ REprintf("___ SP[itp=%d] = %g > 0\n", itp, SP[itp]);
+ SP[itp] = 0.;
+ }
+
+ /* Use chi-squared approximation? */
+ if (maybe_chisq && (irn[nrb] * ico[kb + 1]) > ntot * *emin) {
+ ncell = 0.;
+ for (i = 0; i < nro2; ++i)
+ for (j = 1; j <= k1; ++j)
+ if (irn[nrb + i] * ico[kb + j] >= ntot * *expect)
+ ncell++;
+
+ if (ncell * 100 >= k1 * nro2 * *percnt) {
+ tmp = 0.;
+ for (i = 0; i < nro2; ++i)
+ tmp += (fact[irn[nrb + i]] -
+ fact[irn[nrb + i] - 1]);
+ tmp *= k1 - 1;
+ for (j = 1; j <= k1; ++j)
+ tmp += (nro2 - 1) * (fact[ico[kb + j]] -
+ fact[ico[kb + j] - 1]);
+ df = (double) ((nro2 - 1) * (k1 - 1));
+ tmp += df * 1.83787706640934548356065947281;
+ tmp -= (nro2 * k1 - 1) * (fact[ntot] - fact[ntot - 1]);
+ tm[itp] = (obs - dro) * -2. - tmp;
+ } else {
+ /* tm[itp] set to a flag value */
+ tm[itp] = -9876.;
+ }
+ } else {
+ tm[itp] = -9876.;
+ }
+ }
+ obs3 = obs2 - LP[itp];
+ obs2 -= SP[itp];
+ if (tm[itp] == -9876.) {
+ chisq = FALSE;
+ } else {
+ chisq = TRUE;
+ tmp = tm[itp];
+ }
+ } else {
+ obs2 = obs - drn - dro;
+ obs3 = obs2;
+ }
+
+L300:
+ /* Process node with new PASTP */
+ if (pastp <= obs3) {
+ /* Update pre */
+ *pre += (double) ifreq * exp(pastp + drn);
+ } else if (pastp < obs2) {
+ if (chisq) {
+ df = (double) ((nro2 - 1) * (k1 - 1));
+#ifdef USING_R
+ pv = pgamma(fmax2(0., tmp + (pastp + drn) * 2.) / 2.,
+ df / 2., /*scale = */ 1.,
+ /*lower_tail = */FALSE, /*log_p = */ FALSE);
+#else
+ d1 = fmax2(0., tmp + (pastp + drn) * 2.) / 2.;
+ d2 = df / 2.;
+ pv = 1. - gammds(&d1, &d2, &ifault);
+#endif
+ *pre += (double) ifreq * exp(pastp + drn) * pv;
+ } else {
+ /* Put daughter on queue */
+ d1 = pastp + ddf;
+ f5xact(&d1, &tol, &kval, &key[jkey], ldkey, &ipoin[jkey],
+ &stp[jstp], ldstp, &ifrq[jstp], &ifrq[jstp2],
+ &ifrq[jstp3], &ifrq[jstp4], &ifreq, &itop, psh);
+ psh = FALSE;
+ }
+ }
+ /* Get next PASTP on chain */
+ ipn = ifrq[ipn + ikstp2];
+ if (ipn > 0) {
+ pastp = stp[ipn + ikstp];
+ ifreq = ifrq[ipn + ikstp];
+ goto L300;
+ }
+ /* Generate a new daughter node */
+ f7xact(kmax, &iro[1], &idif[1], &kd, &ks, &iflag);
+ if (iflag != 1)
+ goto L150;
+
+
+L310:
+ /* Go get a new mother from stage K */
+ do {
+ if(!f6xact(nro, &iro[1], &kyy[1], &key[ikkey + 1], ldkey, &last, &ipo))
+ /* Update pointers */
+ goto Outer_Loop;
+
+ /* else : no additional nodes to process */
+ --k;
+ itop = 0;
+ ikkey = jkey - 1;
+ ikstp = jstp - 1;
+ ikstp2 = jstp2 - 1;
+ jkey = *ldkey - jkey + 2;
+ jstp = *ldstp - jstp + 2;
+ jstp2 = (*ldstp << 1) + jstp;
+ for (i = 1; i <= *ldkey << 1; ++i)
+ key2[i] = -9999;
+
+ } while (k >= 2);
+
+}/* f2xact() */
+
+
+double
+f3xact(int nrow, int *irow, int ncol, int *icol,
+ int ntot, double *fact, int *ico, int *iro, int *it,
+ int *lb, int *nr, int *nt, int *nu, int *itc, int *ist,
+ double *stv, double *alen, const double *tol)
+{
+/*
+ -----------------------------------------------------------------------
+ Name: F3XACT
+ Purpose: Computes the longest path length for a given table.
+
+ Arguments:
+ NROW - The number of rows in the table. (Input)
+ IROW - Vector of length NROW containing the row sums
+ for the table. (Input)
+ NCOL - The number of columns in the table. (Input)
+ ICOL - Vector of length K containing the column sums
+ for the table. (Input)
+ NTOT - The total count in the table. (Input)
+ FACT - Vector containing the logarithms of factorials. (Input)
+ ICO - Work vector of length MAX(NROW,NCOL).
+ IRO - Work vector of length MAX(NROW,NCOL).
+ IT - Work vector of length MAX(NROW,NCOL).
+ LB - Work vector of length MAX(NROW,NCOL).
+ NR - Work vector of length MAX(NROW,NCOL).
+ NT - Work vector of length MAX(NROW,NCOL).
+ NU - Work vector of length MAX(NROW,NCOL).
+ ITC - Work vector of length 400.
+ IST - Work vector of length 400.
+ STV - Work vector of length 400.
+ ALEN - Work vector of length MAX(NROW,NCOL).
+ TOL - Tolerance. (Input)
+
+ Return Value :
+ LP - The longest path for the table. (Output)
+
+ -----------------------------------------------------------------------
+ */
+
+ const int ldst = 200;/* half stack size */
+ /* Initialized data */
+ static int nst = 0;
+ static int nitc = 0;
+
+ /* Local variables */
+ int i, k;
+ int n11, n12, ii, nn, ks, ic1, ic2, nc1, nn1;
+ int nr1, nco, nct, ipn, irl, key, lev, itp, nro, nrt, kyy, nc1s;
+ double LP, v, val, vmn;
+ Rboolean xmin;
+
+ /* Parameter adjustments */
+ --stv;
+ --ist;
+ --itc;
+ --nu;
+ --nt;
+ --nr;
+ --lb;
+ --it;
+ --iro;
+ --ico;
+ --icol;
+ --irow;
+
+ if (nrow <= 1) { /* nrow is 1 */
+ LP = 0.;
+ if (nrow > 0) {
+ for (i = 1; i <= ncol; ++i)
+ LP -= fact[icol[i]];
+ }
+ return LP;
+ }
+
+ if (ncol <= 1) { /* ncol is 1 */
+ LP = 0.;
+ if (ncol > 0) {
+ for (i = 1; i <= nrow; ++i)
+ LP -= fact[irow[i]];
+ }
+ return LP;
+ }
+
+ /* 2 by 2 table */
+ if (nrow * ncol == 4) {
+ n11 = (irow[1] + 1) * (icol[1] + 1) / (ntot + 2);
+ n12 = irow[1] - n11;
+ return -(fact[n11] + fact[n12] +
+ fact[icol[1] - n11] + fact[icol[2] - n12]);
+ }
+
+ /* ELSE: larger than 2 x 2 : */
+
+ /* Test for optimal table */
+ val = 0.;
+ if (irow[nrow] <= irow[1] + ncol) {
+ xmin = f10act(nrow, &irow[1], ncol, &icol[1], &val, fact,
+ &lb[1], &nu[1], &nr[1]);
+ } else xmin = FALSE;
+ if (! xmin && icol[ncol] <= icol[1] + nrow) {
+ xmin = f10act(ncol, &icol[1], nrow, &irow[1], &val, fact,
+ &lb[1], &nu[1], &nr[1]);
+ }
+ if (xmin)
+ return - val;
+
+
+ /* Setup for dynamic programming */
+
+ for (i = 0; i <= ncol; ++i)
+ alen[i] = 0.;
+ for (i = 1; i <= 2*ldst; ++i)
+ ist[i] = -1;
+
+ nn = ntot;
+ /* Minimize ncol */
+ if (nrow >= ncol) {
+ nro = nrow;
+ nco = ncol;
+ ico[1] = icol[1];
+ nt[1] = nn - ico[1];
+ for (i = 2; i <= ncol; ++i) {
+ ico[i] = icol[i];
+ nt[i] = nt[i - 1] - ico[i];
+ }
+ for (i = 1; i <= nrow; ++i)
+ iro[i] = irow[i];
+
+ } else {
+ nro = ncol;
+ nco = nrow;
+ ico[1] = irow[1];
+ nt[1] = nn - ico[1];
+ for (i = 2; i <= nrow; ++i) {
+ ico[i] = irow[i];
+ nt[i] = nt[i - 1] - ico[i];
+ }
+ for (i = 1; i <= ncol; ++i)
+ iro[i] = icol[i];
+ }
+
+ nc1s = nco - 1;
+ kyy = ico[nco] + 1;
+ /* Initialize pointers */
+ vmn = 1e100;/* to contain min(v..) */
+ irl = 1;
+ ks = 0;
+ k = ldst;
+
+
+LnewNode: /* Setup to generate new node */
+
+ lev = 1;
+ nr1 = nro - 1;
+ nrt = iro[irl];
+ nct = ico[1];
+ lb[1] = (int) ((((double) nrt + 1) * (nct + 1)) /
+ (double) (nn + nr1 * nc1s + 1) - *tol) - 1;
+ nu[1] = (int) ((((double) nrt + nc1s) * (nct + nr1)) /
+ (double) (nn + nr1 + nc1s)) - lb[1] + 1;
+ nr[1] = nrt - lb[1];
+
+LoopNode: /* Generate a node */
+ --nu[lev];
+ if (nu[lev] == 0) {
+ if (lev == 1)
+ goto L200;
+
+ --lev;
+ goto LoopNode;
+ }
+ ++lb[lev];
+ --nr[lev];
+
+ while(1) {
+ alen[lev] = alen[lev - 1] + fact[lb[lev]];
+ if (lev >= nc1s)
+ break;
+
+ nn1 = nt[lev];
+ nrt = nr[lev];
+ ++lev;
+ nc1 = nco - lev;
+ nct = ico[lev];
+ lb[lev] = (int) ((((double) nrt + 1) * (nct + 1)) /
+ (double) (nn1 + nr1 * nc1 + 1) - *tol);
+ nu[lev] = (int) ((((double) nrt + nc1) * (nct + nr1)) /
+ (double) (nn1 + nr1 + nc1) - lb[lev] + 1);
+ nr[lev] = nrt - lb[lev];
+ }
+ alen[nco] = alen[lev] + fact[nr[lev]];
+ lb[nco] = nr[lev];
+
+ v = val + alen[nco];
+
+ if (nro == 2) { /* Only 1 row left */
+ v += fact[ico[1] - lb[1]] + fact[ico[2] - lb[2]];
+ for (i = 3; i <= nco; ++i)
+ v += fact[ico[i] - lb[i]];
+
+ if (v < vmn)
+ vmn = v;
+
+ } else if (nro == 3 && nco == 2) { /* 3 rows and 2 columns */
+ nn1 = nn - iro[irl] + 2;
+ ic1 = ico[1] - lb[1];
+ ic2 = ico[2] - lb[2];
+ n11 = (iro[irl + 1] + 1) * (ic1 + 1) / nn1;
+ n12 = iro[irl + 1] - n11;
+ v += fact[n11] + fact[n12] + fact[ic1 - n11] + fact[ic2 - n12];
+ if (v < vmn)
+ vmn = v;
+
+ } else { /* Column marginals are new node */
+
+ for (i = 1; i <= nco; ++i)
+ it[i] = imax2(ico[i] - lb[i], 0);
+
+ /* Sort column marginals it[] : */
+ if (nco == 2) {
+ if (it[1] > it[2]) { /* swap */
+ ii = it[1]; it[1] = it[2]; it[2] = ii;
+ }
+ } else
+ isort(&nco, &it[1]);
+
+ /* Compute hash value */
+ key = it[1] * kyy + it[2];
+ for (i = 3; i <= nco; ++i) {
+ key = it[i] + key * kyy;
+ }
+ if (key < -1)
+ PROBLEM "Bug in FEXACT: gave negative key" RECOVER(NULL_ENTRY);
+ /* Table index */
+ ipn = key % ldst + 1;
+ /* Find empty position */
+ for (itp = ipn, ii = ks + ipn; itp <= ldst; ++itp, ++ii) {
+ if (ist[ii] < 0) {
+ goto L180;
+ } else if (ist[ii] == key) {
+ goto L190;
+ }
+ }
+
+ for (itp = 1, ii = ks + 1; itp <= ipn - 1; ++itp, ++ii) {
+ if (ist[ii] < 0) {
+ goto L180;
+ } else if (ist[ii] == key) {
+ goto L190;
+ }
+ }
+
+ /* this happens less, now that we check for negative key above: */
+ prterr(30, "Stack length exceeded in f3xact.\n"
+ "This problem should not occur.");
+
+L180: /* Push onto stack */
+ ist[ii] = key;
+ stv[ii] = v;
+ ++nst;
+ ii = nst + ks;
+ itc[ii] = itp;
+ goto LoopNode;
+
+L190: /* Marginals already on stack */
+ stv[ii] = fmin2(v, stv[ii]);
+ }
+ goto LoopNode;
+
+
+L200: /* Pop item from stack */
+ if (nitc > 0) {
+ /* Stack index */
+ itp = itc[nitc + k] + k;
+ --nitc;
+ val = stv[itp];
+ key = ist[itp];
+ ist[itp] = -1;
+ /* Compute marginals */
+ for (i = nco; i >= 2; --i) {
+ ico[i] = key % kyy;
+ key /= kyy;
+ }
+ ico[1] = key;
+ /* Set up nt array */
+ nt[1] = nn - ico[1];
+ for (i = 2; i <= nco; ++i)
+ nt[i] = nt[i - 1] - ico[i];
+
+ /* Test for optimality (L90) */
+ if (iro[nro] <= iro[irl] + nco) {
+ xmin = f10act(nro, &iro[irl], nco, &ico[1], &val, fact,
+ &lb[1], &nu[1], &nr[1]);
+ } else xmin = FALSE;
+
+ if (!xmin && ico[nco] <= ico[1] + nro)
+ xmin = f10act(nco, &ico[1], nro, &iro[irl], &val, fact,
+ &lb[1], &nu[1], &nr[1]);
+ if (xmin) {
+ if (vmn > val)
+ vmn = val;
+ goto L200;
+ }
+ else goto LnewNode;
+
+ } else if (nro > 2 && nst > 0) {
+ /* Go to next level */
+ nitc = nst;
+ nst = 0;
+ k = ks;
+ ks = ldst - ks;
+ nn -= iro[irl];
+ ++irl;
+ --nro;
+ goto L200;
+ }
+
+ return - vmn;
+}
+
+double
+f4xact(int nrow, int *irow, int ncol, int *icol, double dspt,
+ double *fact, int *icstk, int *ncstk, int *lstk, int *mstk,
+ int *nstk, int *nrstk, int *irstk, double *ystk, const double *tol)
+{
+/*
+ -----------------------------------------------------------------------
+ Name: F4XACT
+ Purpose: Computes the shortest path length for a given table.
+
+ Arguments:
+ NROW - The number of rows in the table. (Input)
+ IROW - Vector of length NROW containing the row sums for the
+ table. (Input)
+ NCOL - The number of columns in the table. (Input)
+ ICOL - Vector of length K containing the column sums for the
+ table. (Input)
+ DSPT - "offset" for SP computation
+ FACT - Vector containing the logarithms of factorials. (Input)
+ ICSTK - NCOL by NROW+NCOL+1 work array.
+ NCSTK - Work vector of length NROW+NCOL+1.
+ LSTK - Work vector of length NROW+NCOL+1.
+ MSTK - Work vector of length NROW+NCOL+1.
+ NSTK - Work vector of length NROW+NCOL+1.
+ NRSTK - Work vector of length NROW+NCOL+1.
+ IRSTK - NROW by MAX(NROW,NCOL) work array.
+ YSTK - Work vector of length NROW+NCOL+1.
+ TOL - Tolerance. (Input)
+
+ Return Value :
+
+ SP - The shortest path for the table. (Output)
+ -----------------------------------------------------------------------
+ */
+
+ /* Local variables */
+ int i, j, k, l, m, n, ic1, ir1, ict, irt, istk, nco, nro;
+ double y, amx, SP;
+
+ /* Take care of the easy cases first */
+ if (nrow == 1) {
+ SP = 0.;
+ for (i = 0; i < ncol; ++i)
+ SP -= fact[icol[i]];
+ return SP;
+ }
+ if (ncol == 1) {
+ SP = 0.;
+ for (i = 0; i < nrow; ++i)
+ SP -= fact[irow[i]];
+ return SP;
+ }
+ if (nrow * ncol == 4) {
+ if (irow[1] <= icol[1])
+ return -(fact[irow[1]] + fact[icol[1]] + fact[icol[1] - irow[1]]);
+ else
+ return -(fact[icol[1]] + fact[irow[1]] + fact[irow[1] - icol[1]]);
+ }
+
+ /* Parameter adjustments */
+ irstk -= nrow + 1;
+ icstk -= ncol + 1;
+
+ --nrstk;
+ --ncstk;
+ --lstk;
+ --mstk;
+ --nstk;
+ --ystk;
+
+ /* initialization before loop */
+ for (i = 1; i <= nrow; ++i)
+ irstk[i + nrow] = irow[nrow - i];
+
+ for (j = 1; j <= ncol; ++j)
+ icstk[j + ncol] = icol[ncol - j];
+
+ nro = nrow;
+ nco = ncol;
+ nrstk[1] = nro;
+ ncstk[1] = nco;
+ ystk[1] = 0.;
+ y = 0.;
+ istk = 1;
+ l = 1;
+ amx = 0.;
+ SP = dspt;
+
+ /* First LOOP */
+ do {
+ ir1 = irstk[istk * nrow + 1];
+ ic1 = icstk[istk * ncol + 1];
+ if (ir1 > ic1) {
+ if (nro >= nco) {
+ m = nco - 1; n = 2;
+ } else {
+ m = nro; n = 1;
+ }
+ } else if (ir1 < ic1) {
+ if (nro <= nco) {
+ m = nro - 1; n = 1;
+ } else {
+ m = nco; n = 2;
+ }
+ } else {
+ if (nro <= nco) {
+ m = nro - 1; n = 1;
+ } else {
+ m = nco - 1; n = 2;
+ }
+ }
+
+ L60:
+ if (n == 1) {
+ i = l; j = 1;
+ } else {
+ i = 1; j = l;
+ }
+
+ irt = irstk[i + istk * nrow];
+ ict = icstk[j + istk * ncol];
+ y += fact[imin2(irt, ict)];
+ if (irt == ict) {
+ --nro;
+ --nco;
+ f11act(&irstk[istk * nrow + 1], i, nro,
+ &irstk[(istk + 1) * nrow + 1]);
+ f11act(&icstk[istk * ncol + 1], j, nco,
+ &icstk[(istk + 1) * ncol + 1]);
+ } else if (irt > ict) {
+ --nco;
+ f11act(&icstk[istk * ncol + 1], j, nco,
+ &icstk[(istk + 1) * ncol + 1]);
+ f8xact(&irstk[istk * nrow + 1], irt - ict, i, nro,
+ &irstk[(istk + 1) * nrow + 1]);
+ } else {
+ --nro;
+ f11act(&irstk[istk * nrow + 1], i, nro,
+ &irstk[(istk + 1) * nrow + 1]);
+ f8xact(&icstk[istk * ncol + 1], ict - irt, j, nco,
+ &icstk[(istk + 1) * ncol + 1]);
+ }
+
+ if (nro == 1) {
+ for (k = 1; k <= nco; ++k)
+ y += fact[icstk[k + (istk + 1) * ncol]];
+ break;
+ }
+ if (nco == 1) {
+ for (k = 1; k <= nro; ++k)
+ y += fact[irstk[k + (istk + 1) * nrow]];
+ break;
+ }
+
+ lstk[istk] = l;
+ mstk[istk] = m;
+ nstk[istk] = n;
+ ++istk;
+ nrstk[istk] = nro;
+ ncstk[istk] = nco;
+ ystk[istk] = y;
+ l = 1;
+ } while(1);/* end do */
+
+/* L90:*/
+ if (y > amx) {
+ amx = y;
+ if (SP - amx <= *tol)
+ return -dspt;
+ }
+
+/* L100: */
+ do {
+ --istk;
+ if (istk == 0) {
+ SP -= amx;
+ if (SP - amx <= *tol)
+ return -dspt;
+ else
+ return SP - dspt;
+ }
+ l = lstk[istk] + 1;
+
+ /* L110: */
+ for(;; ++l) {
+ if (l > mstk[istk]) break;
+
+ n = nstk[istk];
+ nro = nrstk[istk];
+ nco = ncstk[istk];
+ y = ystk[istk];
+ if (n == 1) {
+ if (irstk[l + istk * nrow] <
+ irstk[l - 1 + istk * nrow]) goto L60;
+ }
+ else if (n == 2) {
+ if (icstk[l + istk * ncol] <
+ icstk[l - 1 + istk * ncol]) goto L60;
+ }
+ }
+ } while(1);
+}
+
+
+void
+f5xact(double *pastp, const double *tol, int *kval, int *key, int *ldkey,
+ int *ipoin, double *stp, int *ldstp, int *ifrq, int *npoin,
+ int *nr, int *nl, int *ifreq, int *itop, Rboolean psh)
+{
+/*
+ -----------------------------------------------------------------------
+ Name: F5XACT aka "PUT"
+ Purpose: Put node on stack in network algorithm.
+
+ Arguments:
+ PASTP - The past path length. (Input)
+ TOL - Tolerance for equivalence of past path lengths. (Input)
+ KVAL - Key value. (Input)
+ KEY - Vector of length LDKEY containing the key values. (in/out)
+ LDKEY - Length of vector KEY. (Input)
+ IPOIN - Vector of length LDKEY pointing to the
+ linked list of past path lengths. (in/out)
+ STP - Vector of length LSDTP containing the
+ linked lists of past path lengths. (in/out)
+ LDSTP - Length of vector STP. (Input)
+ IFRQ - Vector of length LDSTP containing the past path
+ frequencies. (in/out)
+ NPOIN - Vector of length LDSTP containing the pointers to
+ the next past path length. (in/out)
+ NR - Vector of length LDSTP containing the right object
+ pointers in the tree of past path lengths. (in/out)
+ NL - Vector of length LDSTP containing the left object
+ pointers in the tree of past path lengths. (in/out)
+ IFREQ - Frequency of the current path length. (Input)
+ ITOP - Pointer to the top of STP. (Input)
+ PSH - Logical. (Input)
+ If PSH is true, the past path length is found in the
+ table KEY. Otherwise the location of the past path
+ length is assumed known and to have been found in
+ a previous call. ==>>>>> USING "static" variables
+ -----------------------------------------------------------------------
+ */
+
+ /* Local variables */
+ static int itmp, ird, ipn, itp; /* << *need* static, see PSH above */
+ double test1, test2;
+
+ /* Parameter adjustments */
+ --nl;
+ --nr;
+ --npoin;
+ --ifrq;
+ --stp;
+
+ /* Function Body */
+ if (psh) {
+ /* Convert KVAL to int in range 1, ..., LDKEY. */
+ ird = *kval % *ldkey;
+ /* Search for an unused location */
+ for (itp = ird; itp < *ldkey; ++itp) {
+ if (key[itp] == *kval)
+ goto L40;
+
+ if (key[itp] < 0)
+ goto L30;
+ }
+ for (itp = 0; itp < ird; ++itp) {
+ if (key[itp] == *kval)
+ goto L40;
+
+ if (key[itp] < 0)
+ goto L30;
+ }
+ /* Return if KEY array is full */
+ /* KH
+ prterr(6, "LDKEY is too small for this problem.\n"
+ "It is not possible to estimate the value of LDKEY "
+ "required,\n"
+ "but twice the current value may be sufficient.");
+ */
+ prterr(6, "LDKEY is too small for this problem.\n"
+ "Try increasing the size of the workspace.");
+
+
+L30: /* Update KEY */
+
+ key[itp] = *kval;
+ ++(*itop);
+ ipoin[itp] = *itop;
+ /* Return if STP array full */
+ if (*itop > *ldstp) {
+ /* KH
+ prterr(7, "LDSTP is too small for this problem.\n"
+ "It is not possible to estimate the value of LDSTP "
+ "required,\n"
+ "but twice the current value may be sufficient.");
+ */
+ prterr(7, "LDSTP is too small for this problem.\n"
+ "Try increasing the size of the workspace.");
+ }
+ /* Update STP, etc. */
+ npoin[*itop] = -1;
+ nr [*itop] = -1;
+ nl [*itop] = -1;
+ stp [*itop] = *pastp;
+ ifrq [*itop] = *ifreq;
+ return;
+ }
+
+L40: /* Find location, if any, of pastp */
+
+ ipn = ipoin[itp];
+ test1 = *pastp - *tol;
+ test2 = *pastp + *tol;
+
+ do {
+ if (stp[ipn] < test1)
+ ipn = nl[ipn];
+ else if (stp[ipn] > test2)
+ ipn = nr[ipn];
+ else {
+ ifrq[ipn] += *ifreq;
+ return;
+ }
+ } while (ipn > 0);
+
+ /* Return if STP array full */
+ ++(*itop);
+ if (*itop > *ldstp) {
+ /*
+ prterr(7, "LDSTP is too small for this problem.\n"
+ "It is not possible to estimate the value of LDSTP "
+ "required,\n"
+ "but twice the current value may be sufficient.");
+ */
+ prterr(7, "LDSTP is too small for this problem.\n"
+ "Try increasing the size of the workspace.");
+ return;
+ }
+
+ /* Find location to add value */
+ ipn = ipoin[itp];
+ itmp = ipn;
+
+L60:
+ if (stp[ipn] < test1) {
+ itmp = ipn;
+ ipn = nl[ipn];
+ if (ipn > 0)
+ goto L60;
+ /* else */
+ nl[itmp] = *itop;
+ }
+ else if (stp[ipn] > test2) {
+ itmp = ipn;
+ ipn = nr[ipn];
+ if (ipn > 0)
+ goto L60;
+ /* else */
+ nr[itmp] = *itop;
+ }
+ /* Update STP, etc. */
+ npoin[*itop] = npoin[itmp];
+ npoin[itmp] = *itop;
+ stp [*itop] = *pastp;
+ ifrq [*itop] = *ifreq;
+ nl [*itop] = -1;
+ nr [*itop] = -1;
+}
+
+
+Rboolean
+f6xact(int nrow, int *irow, int *kyy, int *key, int *ldkey, int *last, int *ipn)
+{
+/*
+ -----------------------------------------------------------------------
+ Name: F6XACT aka "GET"
+ Purpose: Pop a node off the stack.
+
+ Arguments:
+ NROW - The number of rows in the table. (Input)
+ IROW - Vector of length nrow containing the row sums on
+ output. (Output)
+ KYY - Constant mutlipliers used in forming the hash
+ table key. (Input)
+ KEY - Vector of length LDKEY containing the hash table
+ keys. (In/out)
+ LDKEY - Length of vector KEY. (Input)
+ LAST - Index of the last key popped off the stack. (In/out)
+ IPN - Pointer to the linked list of past path lengths. (Output)
+
+ Return value :
+ TRUE if there are no additional nodes to process. (Output)
+ -----------------------------------------------------------------------
+ */
+ int kval, j;
+
+ --key;
+
+L10:
+ ++(*last);
+ if (*last <= *ldkey) {
+ if (key[*last] < 0)
+ goto L10;
+
+ /* Get KVAL from the stack */
+ kval = key[*last];
+ key[*last] = -9999;
+ for (j = nrow-1; j > 0; j--) {
+ irow[j] = kval / kyy[j];
+ kval -= irow[j] * kyy[j];
+ }
+ irow[0] = kval;
+ *ipn = *last;
+ return FALSE;
+ } else {
+ *last = 0;
+ return TRUE;
+ }
+}
+
+
+void
+f7xact(int nrow, int *imax, int *idif, int *k, int *ks, int *iflag)
+{
+/*
+ -----------------------------------------------------------------------
+ Name: F7XACT
+ Purpose: Generate the new nodes for given marginal totals.
+
+ Arguments:
+ NROW - The number of rows in the table. (Input)
+ IMAX - The row marginal totals. (Input)
+ IDIF - The column counts for the new column. (in/out)
+ K - Indicator for the row to decrement. (in/out)
+ KS - Indicator for the row to increment. (in/out)
+ IFLAG - Status indicator. (Output)
+ If IFLAG is zero, a new table was generated. For
+ IFLAG = 1, no additional tables could be generated.
+ -----------------------------------------------------------------------
+ */
+ int i, m, kk, mm;
+
+ /* Parameter adjustments */
+ --idif;
+ --imax;
+
+ /* Function Body */
+ *iflag = 0;
+ /* Find node which can be incremented, ks */
+ if (*ks == 0)
+ do {
+ ++(*ks);
+ } while (idif[*ks] == imax[*ks]);
+
+ /* Find node to decrement (>ks) */
+ if (idif[*k] > 0 && *k > *ks) {
+ --idif[*k];
+ do {
+ --(*k);
+ } while(imax[*k] == 0);
+
+ m = *k;
+
+ /* Find node to increment (>=ks) */
+ while (idif[m] >= imax[m]) {
+ --m;
+ }
+ ++idif[m];
+ /* Change ks */
+ if (m == *ks && idif[m] == imax[m])
+ *ks = *k;
+ }
+ else {
+ Loop:
+ /* Check for finish */
+ for (kk = *k + 1; kk <= nrow; ++kk) {
+ if (idif[kk] > 0) {
+ goto L70;
+ }
+ }
+ *iflag = 1;
+ return;
+
+ L70:
+ /* Reallocate counts */
+ mm = 1;
+ for (i = 1; i <= *k; ++i) {
+ mm += idif[i];
+ idif[i] = 0;
+ }
+ *k = kk;
+
+ do {
+ --(*k);
+ m = imin2(mm, imax[*k]);
+ idif[*k] = m;
+ mm -= m;
+ } while (mm > 0 && *k != 1);
+
+ /* Check that all counts reallocated */
+ if (mm > 0) {
+ if (kk != nrow) {
+ *k = kk;
+ goto Loop;
+ }
+ *iflag = 1;
+ return;
+ }
+ /* Get ks */
+ --idif[kk];
+ *ks = 0;
+ do {
+ ++(*ks);
+ if (*ks > *k) {
+ return;
+ }
+ } while (idif[*ks] >= imax[*ks]);
+ }
+}
+
+
+void f8xact(int *irow, int is, int i1, int izero, int *new)
+{
+/*
+ -----------------------------------------------------------------------
+ Name: F8XACT
+ Purpose: Routine for reducing a vector when there is a zero
+ element.
+ Arguments:
+ IROW - Vector containing the row counts. (Input)
+ IS - Indicator. (Input)
+ I1 - Indicator. (Input)
+ IZERO - Position of the zero. (Input)
+ NEW - Vector of new row counts. (Output)
+ -----------------------------------------------------------------------
+ */
+
+ int i;
+
+ /* Parameter adjustments */
+ --new;
+ --irow;
+
+ /* Function Body */
+ for (i = 1; i < i1; ++i)
+ new[i] = irow[i];
+
+ for (i = i1; i <= izero - 1; ++i) {
+ if (is >= irow[i + 1])
+ break;
+ new[i] = irow[i + 1];
+ }
+
+ new[i] = is;
+
+ for(;;) {
+ ++i;
+ if (i > izero)
+ return;
+ new[i] = irow[i];
+ }
+}
+
+double f9xact(int n, int ntot, int *ir, double *fact)
+{
+/*
+ -----------------------------------------------------------------------
+ Name: F9XACT
+ Purpose: Computes the log of a multinomial coefficient.
+
+ Arguments:
+ N - Length of IR. (Input)
+ NTOT - Number for factorial in numerator. (Input)
+ IR - Vector of length N containing the numbers for
+ the denominator of the factorial. (Input)
+ FACT - Table of log factorials. (Input)
+ Returns:
+ - The log of the multinomal coefficient. (Output)
+ -----------------------------------------------------------------------
+ */
+ double d;
+ int k;
+
+ d = fact[ntot];
+ for (k = 0; k < n; k++)
+ d -= fact[ir[k]];
+ return d;
+}
+
+
+Rboolean
+f10act(int nrow, int *irow, int ncol, int *icol, double *val,
+ double *fact, int *nd, int *ne, int *m)
+{
+/*
+ -----------------------------------------------------------------------
+ Name: F10ACT
+ Purpose: Computes the shortest path length for special tables.
+
+ Arguments:
+ NROW - The number of rows in the table. (Input)
+ IROW - Vector of length NROW containing the row totals. (Input)
+ NCOL - The number of columns in the table. (Input)
+ ICO - Vector of length NCOL containing the column totals.(Input)
+ VAL - The shortest path. (Input/Output)
+ FACT - Vector containing the logarithms of factorials. (Input)
+ ND - Workspace vector of length NROW. (Input)
+ NE - Workspace vector of length NCOL. (Input)
+ M - Workspace vector of length NCOL. (Input)
+
+ Returns (VAL and):
+ XMIN - Set to true if shortest path obtained. (Output)
+ -----------------------------------------------------------------------
+ */
+ /* Local variables */
+ int i, is, ix;
+
+ /* Function Body */
+ for (i = 0; i < nrow - 1; ++i)
+ nd[i] = 0;
+
+ is = icol[0] / nrow;
+ ix = icol[0] - nrow * is;
+ ne[0] = is;
+ m[0] = ix;
+ if (ix != 0)
+ ++nd[ix-1];
+
+ for (i = 1; i < ncol; ++i) {
+ ix = icol[i] / nrow;
+ ne[i] = ix;
+ is += ix;
+ ix = icol[i] - nrow * ix;
+ m[i] = ix;
+ if (ix != 0)
+ ++nd[ix-1];
+ }
+
+ for (i = nrow - 3; i >= 0; --i)
+ nd[i] += nd[i + 1];
+
+ ix = 0;
+ for (i = nrow; i >= 2; --i) {
+ ix += is + nd[nrow - i] - irow[i-1];
+ if (ix < 0)
+ return FALSE;
+ }
+
+ for (i = 0; i < ncol; ++i) {
+ ix = ne[i];
+ is = m[i];
+ *val += is * fact[ix + 1] + (nrow - is) * fact[ix];
+ }
+ return TRUE;
+}
+
+
+void f11act(int *irow, int i1, int i2, int *new)
+{
+/*
+ -----------------------------------------------------------------------
+ Name: F11ACT
+ Purpose: Routine for revising row totals.
+
+ Arguments:
+ IROW - Vector containing the row totals. (Input)
+ I1 - Indicator. (Input)
+ I2 - Indicator. (Input)
+ NEW - Vector containing the row totals. (Output)
+ -----------------------------------------------------------------------
+ */
+ int i;
+
+ for (i = 0; i < (i1 - 1); ++i) new[i] = irow[i];
+ for (i = i1; i <= i2; ++i) new[i-1] = irow[i];
+
+ return;
+}
+
+
+void NORET prterr(int icode, const char *mes)
+{
+/*
+ -----------------------------------------------------------------------
+ Name: prterr
+ Purpose: Print an error message and stop.
+
+ Arguments:
+ icode - Integer code for the error message. (Input)
+ mes - Character string containing the error message. (Input)
+ -----------------------------------------------------------------------
+ */
+ PROBLEM "FEXACT error %d.\n%s", icode, mes RECOVER(NULL_ENTRY);
+}
+
+int iwork(int iwkmax, int *iwkpt, int number, int itype)
+{
+/*
+ -----------------------------------------------------------------------
+ Name: iwork
+ Purpose: Routine for allocating workspace.
+
+ Arguments:
+ iwkmax - Maximum (int) amount of workspace. (Input)
+ iwkpt - Amount of (int) workspace currently allocated. (in/out)
+ number - Number of elements of workspace desired. (Input)
+ itype - Workspace type. (Input)
+ ITYPE TYPE
+ 2 integer
+ 3 float
+ 4 double
+ iwork(): Index in rwrk, dwrk, or iwrk of the beginning of
+ the first free element in the workspace array. (Output)
+ -----------------------------------------------------------------------
+ */
+ int i;
+
+ i = *iwkpt;
+ if (itype == 2 || itype == 3)
+ *iwkpt += number;
+ else { /* double */
+ if (i % 2 != 0)
+ ++i;
+ *iwkpt += (number << 1);
+ i /= 2;
+ }
+ if (*iwkpt > iwkmax)
+ prterr(40, "Out of workspace.");
+
+ return i;
+}
+
+
+
+#ifndef USING_R
+
+void isort(int *n, int *ix)
+{
+/*
+ -----------------------------------------------------------------------
+ Name: ISORT
+ Purpose: Shell sort for an int vector.
+
+ Arguments:
+ N - Lenth of vector IX. (Input)
+ IX - Vector to be sorted. (in/out)
+ -----------------------------------------------------------------------
+ */
+ static int ikey, i, j, m, il[10], kl, it, iu[10], ku;
+
+ /* Parameter adjustments */
+ --ix;
+
+ /* Function Body */
+ m = 1;
+ i = 1;
+ j = *n;
+
+L10:
+ if (i >= j) {
+ goto L40;
+ }
+ kl = i;
+ ku = j;
+ ikey = i;
+ ++j;
+ /* Find element in first half */
+L20:
+ ++i;
+ if (i < j) {
+ if (ix[ikey] > ix[i]) {
+ goto L20;
+ }
+ }
+ /* Find element in second half */
+L30:
+ --j;
+ if (ix[j] > ix[ikey]) {
+ goto L30;
+ }
+ /* Interchange */
+ if (i < j) {
+ it = ix[i];
+ ix[i] = ix[j];
+ ix[j] = it;
+ goto L20;
+ }
+ it = ix[ikey];
+ ix[ikey] = ix[j];
+ ix[j] = it;
+ /* Save upper and lower subscripts of the array yet to be sorted */
+ if (m < 11) {
+ if (j - kl < ku - j) {
+ il[m - 1] = j + 1;
+ iu[m - 1] = ku;
+ i = kl;
+ --j;
+ } else {
+ il[m - 1] = kl;
+ iu[m - 1] = j - 1;
+ i = j + 1;
+ j = ku;
+ }
+ ++m;
+ goto L10;
+ } else {
+ prterr(20, "This should never occur.");
+ }
+ /* Use another segment */
+L40:
+ --m;
+ if (m == 0) {
+ return;
+ }
+ i = il[m - 1];
+ j = iu[m - 1];
+ goto L10;
+}
+
+double gammds(double *y, double *p, int *ifault)
+{
+/*
+ -----------------------------------------------------------------------
+ Name: GAMMDS
+ Purpose: Cumulative distribution for the gamma distribution.
+ Usage: PGAMMA (Q, ALPHA,IFAULT)
+ Arguments:
+ Q - Value at which the distribution is desired. (Input)
+ ALPHA - Parameter in the gamma distribution. (Input)
+ IFAULT - Error indicator. (Output)
+ IFAULT DEFINITION
+ 0 No error
+ 1 An argument is misspecified.
+ 2 A numerical error has occurred.
+ PGAMMA - The cdf for the gamma distribution with parameter alpha
+ evaluated at Q. (Output)
+ -----------------------------------------------------------------------
+
+ Algorithm AS 147 APPL. Statist. (1980) VOL. 29, P. 113
+
+ Computes the incomplete gamma integral for positive parameters Y, P
+ using and infinite series.
+ */
+
+ static double a, c, f, g;
+ static int ifail;
+
+ /* Checks for the admissibility of arguments and value of F */
+ *ifault = 1;
+ g = 0.;
+ if (*y <= 0. || *p <= 0.) {
+ return g;
+ }
+ *ifault = 2;
+
+ /*
+ ALOGAM is natural log of gamma function no need to test ifail as
+ an error is impossible
+ */
+
+ a = *p + 1.;
+ f = exp(*p * log(*y) - alogam(&a, &ifail) - *y);
+ if (f == 0.) {
+ return g;
+ }
+ *ifault = 0;
+
+ /* Series begins */
+ c = 1.;
+ g = 1.;
+ a = *p;
+L10:
+ do {
+ a += 1.;
+ c *= (*y / a);
+ g += c;
+ } while (c > 1e-6 * g);
+
+ g *= f;
+ return g;
+}
+
+/*
+ -----------------------------------------------------------------------
+ Name: ALOGAM
+ Purpose: Value of the log-gamma function.
+ Usage: ALOGAM (X, IFAULT)
+ Arguments:
+ X - Value at which the log-gamma function is to be evaluated.
+ (Input)
+ IFAULT - Error indicator. (Output)
+ IFAULT DEFINITION
+ 0 No error
+ 1 X < 0
+ ALGAMA - The value of the log-gamma function at XX. (Output)
+ -----------------------------------------------------------------------
+
+ Algorithm ACM 291, Comm. ACM. (1966) Vol. 9, P. 684
+
+ Evaluates natural logarithm of gamma(x) for X greater than zero.
+ */
+
+double alogam(double *x, int *ifault)
+{
+ /* Initialized data */
+
+ static double a1 = .918938533204673;
+ static double a2 = 5.95238095238e-4;
+ static double a3 = 7.93650793651e-4;
+ static double a4 = .002777777777778;
+ static double a5 = .083333333333333;
+
+ /* Local variables */
+ static double f, y, z;
+
+ *ifault = 1;
+ if (*x < 0.) {
+ return(0.);
+ }
+ *ifault = 0;
+ y = *x;
+ f = 0.;
+ if (y >= 7.) {
+ goto L30;
+ }
+ f = y;
+L10:
+ y += 1.;
+ if (y >= 7.) {
+ goto L20;
+ }
+ f *= y;
+ goto L10;
+L20:
+ f = -log(f);
+L30:
+ z = 1. / (y * y);
+ return(f + (y - .5) * log(y) - y + a1 +
+ (((-a2 * z + a3) * z - a4) * z + a5) / y);
+}
+
+#endif /* not USING_R */
+
+#include <Rinternals.h>
+
+SEXP Fexact(SEXP x, SEXP pars, SEXP work, SEXP smult)
+{
+ int nr = nrows(x), nc = ncols(x), ws = asInteger(work),
+ mult = asInteger(smult);
+ pars = PROTECT(coerceVector(pars, REALSXP));
+ double p, prt, *rp = REAL(pars);
+ fexact(&nr, &nc, INTEGER(x), &nr, rp, rp+1, rp+2, &prt, &p, &ws, &mult);
+ UNPROTECT(1);
+ return ScalarReal(p);
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/filter.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/filter.c
new file mode 100644
index 0000000000..47214b341b
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/filter.c
@@ -0,0 +1,156 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+
+ * Copyright (C) 1999-2016 The R Core Team
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/.
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <R.h>
+#include "ts.h"
+
+#ifndef min
+#define min(a, b) ((a < b)?(a):(b))
+#define max(a, b) ((a < b)?(b):(a))
+#endif
+
+// currently ISNAN includes NAs
+#define my_isok(x) (!ISNA(x) & !ISNAN(x))
+
+SEXP cfilter(SEXP sx, SEXP sfilter, SEXP ssides, SEXP scircular)
+{
+ if (TYPEOF(sx) != REALSXP || TYPEOF(sfilter) != REALSXP)
+ error("invalid input");
+ R_xlen_t nx = XLENGTH(sx), nf = XLENGTH(sfilter);
+ int sides = asInteger(ssides), circular = asLogical(scircular);
+ if(sides == NA_INTEGER || circular == NA_LOGICAL) error("invalid input");
+
+ SEXP ans = allocVector(REALSXP, nx);
+
+ R_xlen_t i, j, nshift;
+ double z, tmp, *x = REAL(sx), *filter = REAL(sfilter), *out = REAL(ans);
+
+ if(sides == 2) nshift = nf /2; else nshift = 0;
+ if(!circular) {
+ for(i = 0; i < nx; i++) {
+ z = 0;
+ if(i + nshift - (nf - 1) < 0 || i + nshift >= nx) {
+ out[i] = NA_REAL;
+ continue;
+ }
+ for(j = max(0, nshift + i - nx); j < min(nf, i + nshift + 1) ; j++) {
+ tmp = x[i + nshift - j];
+ if(my_isok(tmp)) z += filter[j] * tmp;
+ else { out[i] = NA_REAL; goto bad; }
+ }
+ out[i] = z;
+ bad:
+ continue;
+ }
+ } else { /* circular */
+ for(i = 0; i < nx; i++)
+ {
+ z = 0;
+ for(j = 0; j < nf; j++) {
+ R_xlen_t ii = i + nshift - j;
+ if(ii < 0) ii += nx;
+ if(ii >= nx) ii -= nx;
+ tmp = x[ii];
+ if(my_isok(tmp)) z += filter[j] * tmp;
+ else { out[i] = NA_REAL; goto bad2; }
+ }
+ out[i] = z;
+ bad2:
+ continue;
+ }
+ }
+ return ans;
+}
+
+/* recursive filtering */
+SEXP rfilter(SEXP x, SEXP filter, SEXP out)
+{
+ if (TYPEOF(x) != REALSXP || TYPEOF(filter) != REALSXP
+ || TYPEOF(out) != REALSXP) error("invalid input");
+ R_xlen_t nx = XLENGTH(x), nf = XLENGTH(filter);
+ double sum, tmp, *r = REAL(out), *rx = REAL(x), *rf = REAL(filter);
+
+ for(R_xlen_t i = 0; i < nx; i++) {
+ sum = rx[i];
+ for (R_xlen_t j = 0; j < nf; j++) {
+ tmp = r[nf + i - j - 1];
+ if(my_isok(tmp)) sum += tmp * rf[j];
+ else { r[nf + i] = NA_REAL; goto bad3; }
+ }
+ r[nf + i] = sum;
+ bad3:
+ continue;
+ }
+ return out;
+}
+
+/* now allows missing values */
+static void
+acf0(double *x, int n, int ns, int nl, Rboolean correlation, double *acf)
+{
+ int d1 = nl+1, d2 = ns*d1;
+
+ for(int u = 0; u < ns; u++)
+ for(int v = 0; v < ns; v++)
+ for(int lag = 0; lag <= nl; lag++) {
+ double sum = 0.0; int nu = 0;
+ for(int i = 0; i < n-lag; i++)
+ if(!ISNAN(x[i + lag + n*u]) && !ISNAN(x[i + n*v])) {
+ nu++;
+ sum += x[i + lag + n*u] * x[i + n*v];
+ }
+ acf[lag + d1*u + d2*v] = (nu > 0) ? sum/(nu + lag) : NA_REAL;
+ }
+ if(correlation) {
+ if(n == 1) {
+ for(int u = 0; u < ns; u++)
+ acf[0 + d1*u + d2*u] = 1.0;
+ } else {
+ double *se = (double *) R_alloc(ns, sizeof(double));
+ for(int u = 0; u < ns; u++)
+ se[u] = sqrt(acf[0 + d1*u + d2*u]);
+ for(int u = 0; u < ns; u++)
+ for(int v = 0; v < ns; v++)
+ for(int lag = 0; lag <= nl; lag++) { // ensure correlations remain in [-1,1] :
+ double a = acf[lag + d1*u + d2*v] / (se[u]*se[v]);
+ acf[lag + d1*u + d2*v] = (a > 1.) ? 1. : ((a < -1.) ? -1. : a);
+ }
+ }
+ }
+}
+
+SEXP acf(SEXP x, SEXP lmax, SEXP sCor)
+{
+ int nx = nrows(x), ns = ncols(x), lagmax = asInteger(lmax),
+ cor = asLogical(sCor);
+ x = PROTECT(coerceVector(x, REALSXP));
+ SEXP ans = PROTECT(allocVector(REALSXP, (lagmax + 1)*ns*ns));
+ acf0(REAL(x), nx, ns, lagmax, cor, REAL(ans));
+ SEXP d = PROTECT(allocVector(INTSXP, 3));
+ INTEGER(d)[0] = lagmax + 1;
+ INTEGER(d)[1] = INTEGER(d)[2] = ns;
+ setAttrib(ans, R_DimSymbol, d);
+ UNPROTECT(3);
+ return ans;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/kendall.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/kendall.c
new file mode 100644
index 0000000000..b80da5a5bb
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/kendall.c
@@ -0,0 +1,110 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 1999-2016 The R Core Team.
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/
+ */
+
+/* Kendall's rank correlation tau and its exact distribution in case of no ties
+*/
+
+#include <string.h>
+#include <R.h>
+#include <math.h> // for floor
+#include <Rmath.h>
+
+/*
+ and the exact distribution of T = (n * (n - 1) * tau + 1) / 4,
+ which is -- if there are no ties -- the number of concordant ordered pairs
+*/
+
+static double
+ckendall(int k, int n, double **w)
+{
+ int i, u;
+ double s;
+
+ u = (n * (n - 1) / 2);
+ if ((k < 0) || (k > u)) return(0);
+ if (w[n] == 0) {
+ w[n] = (double *) R_alloc(u + 1, sizeof(double));
+ memset(w[n], '\0', sizeof(double) * (u+1));
+ for (i = 0; i <= u; i++) w[n][i] = -1;
+ }
+ if (w[n][k] < 0) {
+ if (n == 1)
+ w[n][k] = (k == 0);
+ else {
+ s = 0;
+ for (i = 0; i < n; i++)
+ s += ckendall(k - i, n - 1, w);
+ w[n][k] = s;
+ }
+ }
+ return(w[n][k]);
+}
+
+#if 0
+void
+dkendall(int *len, double *x, int *n)
+{
+ int i;
+ double **w;
+
+ w = (double **) R_alloc(*n + 1, sizeof(double *));
+
+ for (i = 0; i < *len; i++)
+ if (fabs(x[i] - floor(x[i] + 0.5)) > 1e-7) {
+ x[i] = 0;
+ } else {
+ x[i] = ckendall((int)x[i], *n) / gammafn(*n + 1, w);
+ }
+}
+#endif
+
+static void
+pkendall(int len, double *Q, double *P, int n)
+{
+ int i, j;
+ double p, q;
+ double **w;
+
+ w = (double **) R_alloc(n + 1, sizeof(double *));
+ memset(w, '\0', sizeof(double*) * (n+1));
+
+ for (i = 0; i < len; i++) {
+ q = floor(Q[i] + 1e-7);
+ if (q < 0)
+ P[i] = 0;
+ else if (q > (n * (n - 1) / 2))
+ P[i] = 1;
+ else {
+ p = 0;
+ for (j = 0; j <= q; j++) p += ckendall(j, n, w);
+ P[i] = p / gammafn(n + 1);
+ }
+ }
+}
+
+#include <Rinternals.h>
+SEXP pKendall(SEXP q, SEXP sn)
+{
+ q = PROTECT(coerceVector(q, REALSXP));
+ int len = LENGTH(q), n = asInteger(sn);
+ SEXP p = PROTECT(allocVector(REALSXP, len));
+ pkendall(len, REAL(q), REAL(p), n);
+ UNPROTECT(2);
+ return p;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ks.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ks.c
new file mode 100644
index 0000000000..2275fcf4da
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ks.c
@@ -0,0 +1,265 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 1999-2016 The R Core Team.
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/
+ */
+
+/* ks.c
+ Compute the asymptotic distribution of the one- and two-sample
+ two-sided Kolmogorov-Smirnov statistics, and the exact distributions
+ in the two-sided one-sample and two-sample cases.
+*/
+
+#include <math.h>
+#include <R.h>
+#include <Rinternals.h>
+#include <Rmath.h> /* constants */
+
+static double K(int n, double d);
+static void m_multiply(double *A, double *B, double *C, int m);
+static void m_power(double *A, int eA, double *V, int *eV, int m, int n);
+
+/* Two-sample two-sided asymptotic distribution */
+static void
+pkstwo(int n, double *x, double tol)
+{
+/* x[1:n] is input and output
+ *
+ * Compute
+ * \sum_{k=-\infty}^\infty (-1)^k e^{-2 k^2 x^2}
+ * = 1 + 2 \sum_{k=1}^\infty (-1)^k e^{-2 k^2 x^2}
+ * = \frac{\sqrt{2\pi}}{x} \sum_{k=1}^\infty \exp(-(2k-1)^2\pi^2/(8x^2))
+ *
+ * See e.g. J. Durbin (1973), Distribution Theory for Tests Based on the
+ * Sample Distribution Function. SIAM.
+ *
+ * The 'standard' series expansion obviously cannot be used close to 0;
+ * we use the alternative series for x < 1, and a rather crude estimate
+ * of the series remainder term in this case, in particular using that
+ * ue^(-lu^2) \le e^(-lu^2 + u) \le e^(-(l-1)u^2 - u^2+u) \le e^(-(l-1))
+ * provided that u and l are >= 1.
+ *
+ * (But note that for reasonable tolerances, one could simply take 0 as
+ * the value for x < 0.2, and use the standard expansion otherwise.)
+ *
+ */
+ double new, old, s, w, z;
+ int i, k, k_max;
+
+ k_max = (int) sqrt(2 - log(tol));
+
+ for(i = 0; i < n; i++) {
+ if(x[i] < 1) {
+ z = - (M_PI_2 * M_PI_4) / (x[i] * x[i]);
+ w = log(x[i]);
+ s = 0;
+ for(k = 1; k < k_max; k += 2) {
+ s += exp(k * k * z - w);
+ }
+ x[i] = s / M_1_SQRT_2PI;
+ }
+ else {
+ z = -2 * x[i] * x[i];
+ s = -1;
+ k = 1;
+ old = 0;
+ new = 1;
+ while(fabs(old - new) > tol) {
+ old = new;
+ new += 2 * s * exp(z * k * k);
+ s *= -1;
+ k++;
+ }
+ x[i] = new;
+ }
+ }
+}
+
+/* Two-sided two-sample */
+static double psmirnov2x(double *x, int m, int n)
+{
+ double md, nd, q, *u, w;
+ int i, j;
+
+ if(m > n) {
+ i = n; n = m; m = i;
+ }
+ md = (double) m;
+ nd = (double) n;
+ /*
+ q has 0.5/mn added to ensure that rounding error doesn't
+ turn an equality into an inequality, eg abs(1/2-4/5)>3/10
+
+ */
+ q = (0.5 + floor(*x * md * nd - 1e-7)) / (md * nd);
+ u = (double *) R_alloc(n + 1, sizeof(double));
+
+ for(j = 0; j <= n; j++) {
+ u[j] = ((j / nd) > q) ? 0 : 1;
+ }
+ for(i = 1; i <= m; i++) {
+ w = (double)(i) / ((double)(i + n));
+ if((i / md) > q)
+ u[0] = 0;
+ else
+ u[0] = w * u[0];
+ for(j = 1; j <= n; j++) {
+ if(fabs(i / md - j / nd) > q)
+ u[j] = 0;
+ else
+ u[j] = w * u[j] + u[j - 1];
+ }
+ }
+ return u[n];
+}
+
+static double
+K(int n, double d)
+{
+ /* Compute Kolmogorov's distribution.
+ Code published in
+ George Marsaglia and Wai Wan Tsang and Jingbo Wang (2003),
+ "Evaluating Kolmogorov's distribution".
+ Journal of Statistical Software, Volume 8, 2003, Issue 18.
+ URL: http://www.jstatsoft.org/v08/i18/.
+ */
+
+ int k, m, i, j, g, eH, eQ;
+ double h, s, *H, *Q;
+
+ /*
+ The faster right-tail approximation is omitted here.
+ s = d*d*n;
+ if(s > 7.24 || (s > 3.76 && n > 99))
+ return 1-2*exp(-(2.000071+.331/sqrt(n)+1.409/n)*s);
+ */
+ k = (int) (n * d) + 1;
+ m = 2 * k - 1;
+ h = k - n * d;
+ H = (double*) Calloc(m * m, double);
+ Q = (double*) Calloc(m * m, double);
+ for(i = 0; i < m; i++)
+ for(j = 0; j < m; j++)
+ if(i - j + 1 < 0)
+ H[i * m + j] = 0;
+ else
+ H[i * m + j] = 1;
+ for(i = 0; i < m; i++) {
+ H[i * m] -= R_pow_di(h, i + 1);
+ H[(m - 1) * m + i] -= R_pow_di(h, (m - i));
+ }
+ H[(m - 1) * m] += ((2 * h - 1 > 0) ? R_pow_di(2 * h - 1, m) : 0);
+ for(i = 0; i < m; i++)
+ for(j = 0; j < m; j++)
+ if(i - j + 1 > 0)
+ for(g = 1; g <= i - j + 1; g++)
+ H[i * m + j] /= g;
+ eH = 0;
+ m_power(H, eH, Q, &eQ, m, n);
+ s = Q[(k - 1) * m + k - 1];
+ for(i = 1; i <= n; i++) {
+ s = s * i / n;
+ if(s < 1e-140) {
+ s *= 1e140;
+ eQ -= 140;
+ }
+ }
+ s *= R_pow_di(10.0, eQ);
+ Free(H);
+ Free(Q);
+ return(s);
+}
+
+static void
+m_multiply(double *A, double *B, double *C, int m)
+{
+ /* Auxiliary routine used by K().
+ Matrix multiplication.
+ */
+ int i, j, k;
+ double s;
+ for(i = 0; i < m; i++)
+ for(j = 0; j < m; j++) {
+ s = 0.;
+ for(k = 0; k < m; k++)
+ s+= A[i * m + k] * B[k * m + j];
+ C[i * m + j] = s;
+ }
+}
+
+static void
+m_power(double *A, int eA, double *V, int *eV, int m, int n)
+{
+ /* Auxiliary routine used by K().
+ Matrix power.
+ */
+ double *B;
+ int eB , i;
+
+ if(n == 1) {
+ for(i = 0; i < m * m; i++)
+ V[i] = A[i];
+ *eV = eA;
+ return;
+ }
+ m_power(A, eA, V, eV, m, n / 2);
+ B = (double*) Calloc(m * m, double);
+ m_multiply(V, V, B, m);
+ eB = 2 * (*eV);
+ if((n % 2) == 0) {
+ for(i = 0; i < m * m; i++)
+ V[i] = B[i];
+ *eV = eB;
+ }
+ else {
+ m_multiply(A, B, V, m);
+ *eV = eA + eB;
+ }
+ if(V[(m / 2) * m + (m / 2)] > 1e140) {
+ for(i = 0; i < m * m; i++)
+ V[i] = V[i] * 1e-140;
+ *eV += 140;
+ }
+ Free(B);
+}
+
+/* Two-sided two-sample */
+SEXP pSmirnov2x(SEXP statistic, SEXP snx, SEXP sny)
+{
+ int nx = asInteger(snx), ny = asInteger(sny);
+ double st = asReal(statistic);
+ return ScalarReal(psmirnov2x(&st, nx, ny));
+}
+
+/* Two-sample two-sided asymptotic distribution */
+SEXP pKS2(SEXP statistic, SEXP stol)
+{
+ int n = LENGTH(statistic);
+ double tol = asReal(stol);
+ SEXP ans = duplicate(statistic);
+ pkstwo(n, REAL(ans), tol);
+ return ans;
+}
+
+
+/* The two-sided one-sample 'exact' distribution */
+SEXP pKolmogorov2x(SEXP statistic, SEXP sn)
+{
+ int n = asInteger(sn);
+ double st = asReal(statistic), p;
+ p = K(n, st);
+ return ScalarReal(p);
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ksmooth.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ksmooth.c
new file mode 100644
index 0000000000..e832c3d88a
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ksmooth.c
@@ -0,0 +1,109 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 1998-2016 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, a copy is available at
+ * https://www.R-project.org/Licenses/
+ */
+
+#include <math.h>
+#include <R.h> /* for NA_REAL, includes math.h */
+#include <Rinternals.h>
+
+#ifdef ENABLE_NLS
+#include <libintl.h>
+#define _(String) dgettext ("stats", String)
+#else
+#define _(String) (String)
+#endif
+
+static double dokern(double x, int kern)
+{
+ if(kern == 1) return(1.0);
+ if(kern == 2) return(exp(-0.5*x*x));
+ return(0.0); /* -Wall */
+}
+
+static void BDRksmooth(double *x, double *y, R_xlen_t n,
+ double *xp, double *yp, R_xlen_t np,
+ int kern, double bw)
+{
+ R_xlen_t imin = 0;
+ double cutoff = 0.0, num, den, x0, w;
+
+ /* bandwidth is in units of half inter-quartile range. */
+ if(kern == 1) {bw *= 0.5; cutoff = bw;}
+ if(kern == 2) {bw *= 0.3706506; cutoff = 4*bw;}
+ while(x[imin] < xp[0] - cutoff && imin < n) imin++;
+ for(R_xlen_t j = 0; j < np; j++) {
+ num = den = 0.0;
+ x0 = xp[j];
+ for(R_xlen_t i = imin; i < n; i++) {
+ if(x[i] < x0 - cutoff) imin = i;
+ else {
+ if(x[i] > x0 + cutoff) break;
+ w = dokern(fabs(x[i] - x0)/bw, kern);
+ num += w*y[i];
+ den += w;
+ }
+ }
+ if(den > 0) yp[j] = num/den; else yp[j] = NA_REAL;
+ }
+}
+
+
+// called only from spline() in ./ppr.f
+void NORET F77_SUB(bdrsplerr)(void)
+{
+ error(_("only 2500 rows are allowed for sm.method=\"spline\""));
+}
+
+void F77_SUB(splineprt)(double* df, double* gcvpen, int* ismethod,
+ double* lambda, double *edf)
+{
+ Rprintf("spline(df=%5.3g, g.pen=%11.6g, ismeth.=%+2d) -> (lambda, edf) = (%.7g, %5.2f)\n",
+ *df, *gcvpen, *ismethod, *lambda, *edf);
+ return;
+}
+
+// called only from smooth(..., trace=TRUE) in ./ppr.f :
+void F77_SUB(smoothprt)(double* span, int* iper, double* var, double* cvar)
+{
+ Rprintf("smooth(span=%4g, iper=%+2d) -> (var, cvar) = (%g, %g)\n",
+ *span, *iper, *var, *cvar);
+ return;
+}
+
+
+SEXP ksmooth(SEXP x, SEXP y, SEXP xp, SEXP skrn, SEXP sbw)
+{
+ int krn = asInteger(skrn);
+ double bw = asReal(sbw);
+ x = PROTECT(coerceVector(x, REALSXP));
+ y = PROTECT(coerceVector(y, REALSXP));
+ xp = PROTECT(coerceVector(xp, REALSXP));
+ R_xlen_t nx = XLENGTH(x), np = XLENGTH(xp);
+ SEXP yp = PROTECT(allocVector(REALSXP, np));
+
+ BDRksmooth(REAL(x), REAL(y), nx, REAL(xp), REAL(yp), np, krn, bw);
+ SEXP ans = PROTECT(allocVector(VECSXP, 2));
+ SET_VECTOR_ELT(ans, 0, xp);
+ SET_VECTOR_ELT(ans, 1, yp);
+ SEXP nm = allocVector(STRSXP, 2);
+ setAttrib(ans, R_NamesSymbol, nm);
+ SET_STRING_ELT(nm, 0, mkChar("x"));
+ SET_STRING_ELT(nm, 1, mkChar("y"));
+ UNPROTECT(5);
+ return ans;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/line.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/line.c
new file mode 100644
index 0000000000..b912a07824
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/line.c
@@ -0,0 +1,133 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 1997-2016 The R Core Team.
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/
+ */
+
+#include <R_ext/Utils.h> /* R_rsort() */
+#include <math.h>
+
+#include <Rinternals.h>
+#include "statsR.h"
+
+/* Speed up by `inlining' these (as macros) [since R version 1.2] : */
+#if 1
+#define il(n,x) (int)floor((n - 1) * x)
+#define iu(n,x) (int) ceil((n - 1) * x)
+
+#else
+static int il(int n, double x)
+{
+ return (int)floor((n - 1) * x) ;
+}
+
+static int iu(int n, double x)
+{
+ return (int)ceil((n - 1) * x);
+}
+#endif
+
+static void line(double *x, double *y, /* input (x[i],y[i])s */
+ double *z, double *w, /* work and output: resid. & fitted */
+ /* all the above of length */ int n,
+ double coef[2])
+{
+ int i, j, k;
+ double xb, x1, x2, xt, yt, yb, tmp1, tmp2;
+ double slope, yint;
+
+ for(i = 0 ; i < n ; i++) {
+ z[i] = x[i];
+ w[i] = y[i];
+ }
+ R_rsort(z, n);/* z = ordered abscissae */
+
+ tmp1 = z[il(n, 1./6.)];
+ tmp2 = z[iu(n, 1./6.)]; xb = 0.5*(tmp1+tmp2);
+
+ tmp1 = z[il(n, 2./6.)];
+ tmp2 = z[iu(n, 2./6.)]; x1 = 0.5*(tmp1+tmp2);
+
+ tmp1 = z[il(n, 4./6.)];
+ tmp2 = z[iu(n, 4./6.)]; x2 = 0.5*(tmp1+tmp2);
+
+ tmp1 = z[il(n, 5./6.)];
+ tmp2 = z[iu(n, 5./6.)]; xt = 0.5*(tmp1+tmp2);
+
+ slope = 0.;
+
+ for(j = 1 ; j <= 1 ; j++) {
+ /* yb := Median(y[i]; x[i] <= quantile(x, 1/3) */
+ k = 0;
+ for(i = 0 ; i < n ; i++)
+ if(x[i] <= x1)
+ z[k++] = w[i];
+ R_rsort(z, k);
+ yb = 0.5 * (z[il(k, 0.5)] + z[iu(k, 0.5)]);
+
+ /* yt := Median(y[i]; x[i] >= quantile(x, 2/3) */
+ k = 0;
+ for(i = 0 ; i < n ; i++)
+ if(x[i] >= x2)
+ z[k++] = w[i];
+ R_rsort(z,k);
+ yt = 0.5 * (z[il(k, 0.5)] + z[iu(k, 0.5)]);
+
+ slope += (yt - yb)/(xt - xb);
+ for(i = 0 ; i < n ; i++) {
+ z[i] = y[i] - slope*x[i];
+ /* never used: w[i] = z[i]; */
+ }
+ R_rsort(z,n);
+ yint = 0.5 * (z[il(n, 0.5)] + z[iu(n, 0.5)]);
+ }
+ for( i = 0 ; i < n ; i++ ) {
+ w[i] = yint + slope*x[i];
+ z[i] = y[i] - w[i];
+ }
+ coef[0] = yint;
+ coef[1] = slope;
+}
+
+void tukeyline0(double *x, double *y, double *z, double *w, int *n,
+ double *coef)
+{
+ line(x, y, z, w, *n, coef);
+}
+
+SEXP tukeyline(SEXP x, SEXP y, SEXP call)
+{
+ int n = LENGTH(x);
+ if (n < 2) error("insufficient observations");
+ SEXP ans;
+ ans = PROTECT(allocVector(VECSXP, 4));
+ SEXP nm = allocVector(STRSXP, 4);
+ setAttrib(ans, R_NamesSymbol, nm);
+ SET_STRING_ELT(nm, 0, mkChar("call"));
+ SET_STRING_ELT(nm, 1, mkChar("coefficients"));
+ SET_STRING_ELT(nm, 2, mkChar("residuals"));
+ SET_STRING_ELT(nm, 3, mkChar("fitted.values"));
+ SET_VECTOR_ELT(ans, 0, call);
+ SEXP coef = allocVector(REALSXP, 2);
+ SET_VECTOR_ELT(ans, 1, coef);
+ SEXP res = allocVector(REALSXP, n);
+ SET_VECTOR_ELT(ans, 2, res);
+ SEXP fit = allocVector(REALSXP, n);
+ SET_VECTOR_ELT(ans, 3, fit);
+ line(REAL(x), REAL(y), REAL(res), REAL(fit), n, REAL(coef));
+ UNPROTECT(1);
+ return ans;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/loglin.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/loglin.c
new file mode 100644
index 0000000000..dd04cc8cbf
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/loglin.c
@@ -0,0 +1,392 @@
+/* Algorithm AS 51 Appl. Statist. (1972), vol. 21, p. 218
+ original (C) Royal Statistical Society 1972
+
+ Performs an iterative proportional fit of the marginal totals of a
+ contingency table.
+*/
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <math.h>
+
+#include <stdio.h>
+#include <R_ext/Memory.h>
+#include <R_ext/Applic.h>
+
+#undef max
+#undef min
+#undef abs
+#define max(a, b) ((a) < (b) ? (b) : (a))
+#define min(a, b) ((a) > (b) ? (b) : (a))
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+
+static void collap(int nvar, double *x, double *y, int locy,
+ int *dim, int *config);
+static void adjust(int nvar, double *x, double *y, double *z,
+ int *locz, int *dim, int *config, double *d);
+
+/* Table of constant values */
+
+static void
+loglin(int nvar, int *dim, int ncon, int *config, int ntab,
+ double *table, double *fit, int *locmar, int nmar, double *marg,
+ int nu, double *u, double maxdev, int maxit,
+ double *dev, int *nlast, int *ifault)
+{
+ // nvar could be zero (no-segfault test)
+ if (!nvar) error("no variables"); // not translated
+ int i, j, k, n, point, size, check[nvar], icon[nvar];
+ double x, y, xmax;
+
+ /* Parameter adjustments */
+ --dim;
+ --locmar;
+ config -= nvar + 1;
+ --fit;
+ --table;
+ --marg;
+ --u;
+ --dev;
+
+ /* Function body */
+
+ *ifault = 0;
+ *nlast = 0;
+
+ /* Check validity of NVAR, the number of variables, and of maxit,
+ the maximum number of iterations */
+
+ if (nvar > 0 && maxit > 0) goto L10;
+L5:
+ *ifault = 4;
+ return;
+
+ /* Look at table and fit constants */
+
+L10:
+ size = 1;
+ for (j = 1; j <= nvar; j++) {
+ if (dim[j] <= 0) goto L5;
+ size *= dim[j];
+ }
+ if (size <= ntab) goto L40;
+L35:
+ *ifault = 2;
+ return;
+L40:
+ x = 0.;
+ y = 0.;
+ for (i = 1; i <= size; i++) {
+ if (table[i] < 0. || fit[i] < 0.) goto L5;
+ x += table[i];
+ y += fit[i];
+ }
+
+ /* Make a preliminary adjustment to obtain the fit to an empty
+ configuration list */
+
+ if (y == 0.) goto L5;
+ x /= y;
+ for (i = 1; i <= size; i++) fit[i] = x * fit[i];
+ if (ncon <= 0 || config[nvar + 1] == 0) return;
+
+ /* Allocate marginal tables */
+
+ point = 1;
+ for (i = 1; i <= ncon; i++) {
+ /* A zero beginning a configuration indicates that the list is
+ completed */
+ if (config[i * nvar + 1] == 0) goto L160;
+ /* Get marginal table size. While doing this task, see if the
+ configuration list contains duplications or elements out of
+ range. */
+ size = 1;
+ for (j = 0; j < nvar; j++) check[j] = 0;
+ for (j = 1; j <= nvar; j++) {
+ k = config[j + i * nvar];
+ /* A zero indicates the end of the string. */
+ if (k == 0) goto L130;
+ /* See if element is valid. */
+ if (k >= 0 && k <= nvar) goto L100;
+L95:
+ *ifault = 1;
+ return;
+ /* Check for duplication */
+L100:
+ if (check[k - 1]) goto L95;
+ check[k - 1] = 1;
+ /* Get size */
+ size *= dim[k];
+ }
+
+ /* Since U is used to store fitted marginals, size must not
+ exceed NU */
+L130:
+ if (size > nu) goto L35;
+
+ /* LOCMAR points to marginal tables to be placed in MARG */
+ locmar[i] = point;
+ point += size;
+ }
+
+ /* Get N, number of valid configurations */
+
+ i = ncon + 1;
+L160:
+ n = i - 1;
+
+ /* See if MARG can hold all marginal tables */
+
+ if (point > nmar + 1) goto L35;
+
+ /* Obtain marginal tables */
+
+ for (i = 1; i <= n; i++) {
+ for (j = 1; j <= nvar; j++) {
+ icon[j - 1] = config[j + i * nvar];
+ }
+ collap(nvar, &table[1], &marg[1], locmar[i], &dim[1], icon);
+ }
+
+ /* Perform iterations */
+
+ for (k = 1; k <= maxit; k++) {
+ /* XMAX is maximum deviation observed between fitted and true
+ marginal during a cycle */
+ xmax = 0.;
+ for (i = 1; i <= n; i++) {
+ for (j = 1; j <= nvar; j++) icon[j - 1] = config[j + i * nvar];
+ collap(nvar, &fit[1], &u[1], 1, &dim[1], icon);
+ adjust(nvar, &fit[1], &u[1], &marg[1], &locmar[i], &dim[1], icon, &xmax);
+ }
+ /* Test convergence */
+ dev[k] = xmax;
+ if (xmax < maxdev) goto L240;
+ }
+ if (maxit > 1) goto L230;
+ *nlast = 1;
+ return;
+
+ /* No convergence */
+L230:
+ *ifault = 3;
+ *nlast = maxit;
+ return;
+
+ /* Normal termination */
+L240:
+ *nlast = k;
+
+ return;
+}
+
+/* Algorithm AS 51.1 Appl. Statist. (1972), vol. 21, p. 218
+
+ Computes a marginal table from a complete table.
+ All parameters are assumed valid without test.
+
+ The larger table is X and the smaller one is Y.
+*/
+
+void collap(int nvar, double *x, double *y, int locy, int *dim, int *config)
+{
+ int i, j, k, l, n, locu, size[nvar + 1], coord[nvar];
+
+ /* Parameter adjustments */
+ --config;
+ --dim;
+ --x;
+ --y;
+
+ /* Initialize arrays */
+
+ size[0] = 1;
+ for (k = 1; k <= nvar; k++) {
+ l = config[k];
+ if (l == 0) goto L20;
+ size[k] = size[k - 1] * dim[l];
+ }
+
+ /* Find number of variables in configuration */
+
+ k = nvar + 1;
+L20:
+ n = k - 1;
+
+ /* Initialize Y. First cell of marginal table is at Y(LOCY) and
+ table has SIZE(K) elements */
+
+ locu = locy + size[k - 1] - 1;
+ for (j = locy; j <= locu; j++) y[j] = 0.;
+
+ /* Initialize coordinates */
+
+ for (k = 0; k < nvar; k++) coord[k] = 0;
+
+ /* Find locations in tables */
+ i = 1;
+L60:
+ j = locy;
+ for (k = 1; k <= n; k++) {
+ l = config[k];
+ j += coord[l - 1] * size[k - 1];
+ }
+ y[j] += x[i];
+
+ /* Update coordinates */
+
+ i++;
+ for (k = 1; k <= nvar; k++) {
+ coord[k - 1]++;
+ if (coord[k - 1] < dim[k]) goto L60;
+ coord[k - 1] = 0;
+ }
+
+ return;
+}
+
+
+/* Algorithm AS 51.2 Appl. Statist. (1972), vol. 21, p. 218
+
+ Makes proportional adjustment corresponding to CONFIG.
+ All parameters are assumed valid without test.
+ */
+
+void adjust(int nvar, double *x, double *y, double *z, int *locz,
+ int *dim, int *config, double *d)
+{
+ int i, j, k, l, n, size[nvar + 1], coord[nvar];
+ double e;
+
+ /* Parameter adjustments */
+ --config;
+ --dim;
+ --x;
+ --y;
+ --z;
+
+ /* Set size array */
+
+ size[0] = 1;
+ for (k = 1; k <= nvar; k++) {
+ l = config[k];
+ if (l == 0) goto L20;
+ size[k] = size[k - 1] * dim[l];
+ }
+
+ /* Find number of variables in configuration */
+
+ k = nvar + 1;
+L20:
+ n = k - 1;
+
+ /* Test size of deviation */
+
+ l = size[k - 1];
+ j = 1;
+ k = *locz;
+ for (i = 1; i <= l; i++) {
+ e = abs(z[k] - y[j]);
+ if (e > *d) {
+ *d = e;
+ }
+ j++;
+ k++;
+ }
+
+ /* Initialize coordinates */
+
+ for (k = 0; k < nvar; k++) coord[k] = 0;
+ i = 1;
+
+ /* Perform adjustment */
+
+L50:
+ j = 0;
+ for (k = 1; k <= n; k++) {
+ l = config[k];
+ j += coord[l - 1] * size[k - 1];
+ }
+ k = j + *locz;
+ j++;
+
+ /* Note that Y(J) should be non-negative */
+
+ if (y[j] <= 0.) x[i] = 0.;
+ if (y[j] > 0.) x[i] = x[i] * z[k] / y[j];
+
+ /* Update coordinates */
+
+ i++;
+ for (k = 1; k <= nvar; k++) {
+ coord[k - 1]++;
+ if (coord[k - 1] < dim[k]) goto L50;
+ coord[k - 1] = 0;
+ }
+
+ return;
+}
+
+#undef max
+#undef min
+#undef abs
+
+#include <R.h>
+#include <Rinternals.h>
+#include "statsR.h"
+#ifdef ENABLE_NLS
+#include <libintl.h>
+#define _(String) dgettext ("stats", String)
+#else
+#define _(String) (String)
+#endif
+
+SEXP LogLin(SEXP dtab, SEXP conf, SEXP table, SEXP start,
+ SEXP snmar, SEXP eps, SEXP iter)
+{
+ int nvar = length(dtab),
+ ncon = ncols(conf),
+ ntab = length(table),
+ nmar = asInteger(snmar),
+ maxit = asInteger(iter),
+ nlast, ifault;
+ double maxdev = asReal(eps);
+ SEXP fit = PROTECT(TYPEOF(start) == REALSXP ? duplicate(start) :
+ coerceVector(start, REALSXP)),
+ locmar = PROTECT(allocVector(INTSXP, ncon)),
+ marg = PROTECT(allocVector(REALSXP, nmar)),
+ u = PROTECT(allocVector(REALSXP, ntab)),
+ dev = PROTECT(allocVector(REALSXP, maxit));
+ dtab = PROTECT(coerceVector(dtab, INTSXP));
+ conf = PROTECT(coerceVector(conf, INTSXP));
+ table = PROTECT(coerceVector(table, REALSXP));
+ loglin(nvar, INTEGER(dtab), ncon, INTEGER(conf), ntab,
+ REAL(table), REAL(fit), INTEGER(locmar), nmar, REAL(marg),
+ ntab, REAL(u), maxdev, maxit, REAL(dev), &nlast, &ifault);
+ switch(ifault) {
+ case 1:
+ case 2:
+ error(_("this should not happen")); break;
+ case 3:
+ warning(_("algorithm did not converge")); break;
+ case 4:
+ error(_("incorrect specification of 'table' or 'start'")); break;
+ default:
+ break;
+ }
+
+ SEXP ans = PROTECT(allocVector(VECSXP, 3)), nm;
+ SET_VECTOR_ELT(ans, 0, fit);
+ SET_VECTOR_ELT(ans, 1, dev);
+ SET_VECTOR_ELT(ans, 2, ScalarInteger(nlast));
+ nm = allocVector(STRSXP, 3);
+ setAttrib(ans, R_NamesSymbol, nm);
+ SET_STRING_ELT(nm, 0, mkChar("fit"));
+ SET_STRING_ELT(nm, 1, mkChar("dev"));
+ SET_STRING_ELT(nm, 2, mkChar("nlast"));
+ UNPROTECT(9);
+ return ans;
+}
+
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/lowess.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/lowess.c
new file mode 100644
index 0000000000..bbacab7884
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/lowess.c
@@ -0,0 +1,306 @@
+/*
+ * R : A Computer Langage for Statistical Data Analysis
+ * Copyright (C) 1996 Robert Gentleman and Ross Ihaka
+ * Copyright (C) 1999-2016 The R Core Team
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#ifdef ENABLE_NLS
+#include <libintl.h>
+#define _(String) dgettext ("stats", String)
+#else
+#define _(String) (String)
+#endif
+
+#include <math.h>
+#include <Rmath.h> /* fmax2, imin2, imax2 */
+#include <R_ext/Applic.h> /* prototypes for lowess and clowess */
+#include <R_ext/Boolean.h>
+#include <R_ext/Utils.h> /* rPsort() */
+#ifdef DEBUG_lowess
+# include <R_ext/Print.h>
+#endif
+
+static R_INLINE double fsquare(double x)
+{
+ return x * x;
+}
+
+static R_INLINE double fcube(double x)
+{
+ return x * x * x;
+}
+
+static void lowest(double *x, double *y, int n, double *xs, double *ys,
+ int nleft, int nright, double *w,
+ Rboolean userw, double *rw, Rboolean *ok)
+{
+ int nrt, j;
+ double a, b, c, h, h1, h9, r, range;
+
+ x--;
+ y--;
+ w--;
+ rw--;
+
+ range = x[n]-x[1];
+ h = fmax2(*xs-x[nleft], x[nright]-*xs);
+ h9 = 0.999*h;
+ h1 = 0.001*h;
+
+ /* sum of weights */
+
+ a = 0.;
+ j = nleft;
+ while (j <= n) {
+
+ /* compute weights */
+ /* (pick up all ties on right) */
+
+ w[j] = 0.;
+ r = fabs(x[j] - *xs);
+ if (r <= h9) {
+ if (r <= h1)
+ w[j] = 1.;
+ else
+ w[j] = fcube(1.-fcube(r/h));
+ if (userw)
+ w[j] *= rw[j];
+ a += w[j];
+ }
+ else if (x[j] > *xs)
+ break;
+ j = j+1;
+ }
+
+ /* rightmost pt (may be greater */
+ /* than nright because of ties) */
+
+ nrt = j-1;
+ if (a <= 0.)
+ *ok = FALSE;
+ else {
+ *ok = TRUE;
+
+ /* weighted least squares */
+ /* make sum of w[j] == 1 */
+
+ for(j=nleft ; j<=nrt ; j++)
+ w[j] /= a;
+ if (h > 0.) {
+ a = 0.;
+
+ /* use linear fit */
+ /* weighted center of x values */
+
+ for(j=nleft ; j<=nrt ; j++)
+ a += w[j] * x[j];
+ b = *xs - a;
+ c = 0.;
+ for(j=nleft ; j<=nrt ; j++)
+ c += w[j]*fsquare(x[j]-a);
+ if (sqrt(c) > 0.001*range) {
+ b /= c;
+
+ /* points are spread out */
+ /* enough to compute slope */
+
+ for(j=nleft; j <= nrt; j++)
+ w[j] *= (b*(x[j]-a) + 1.);
+ }
+ }
+ *ys = 0.;
+ for(j=nleft; j <= nrt; j++)
+ *ys += w[j] * y[j];
+ }
+}
+
+static
+void clowess(double *x, double *y, int n,
+ double f, int nsteps, double delta,
+ double *ys, double *rw, double *res)
+{
+ int i, iter, j, last, m1, m2, nleft, nright, ns;
+ Rboolean ok;
+ double alpha, c1, c9, cmad, cut, d1, d2, denom, r, sc;
+
+ if (n < 2) {
+ ys[0] = y[0]; return;
+ }
+
+ /* nleft, nright, last, etc. must all be shifted to get rid of these: */
+ x--;
+ y--;
+ ys--;
+
+
+ /* at least two, at most n points */
+ ns = imax2(2, imin2(n, (int)(f*n + 1e-7)));
+#ifdef DEBUG_lowess
+ REprintf("lowess(): ns = %d\n", ns);
+#endif
+
+ /* robustness iterations */
+
+ iter = 1;
+ while (iter <= nsteps+1) {
+ nleft = 1;
+ nright = ns;
+ last = 0; /* index of prev estimated point */
+ i = 1; /* index of current point */
+
+ for(;;) {
+ if (nright < n) {
+
+ /* move nleft, nright to right */
+ /* if radius decreases */
+
+ d1 = x[i] - x[nleft];
+ d2 = x[nright+1] - x[i];
+
+ /* if d1 <= d2 with */
+ /* x[nright+1] == x[nright], */
+ /* lowest fixes */
+
+ if (d1 > d2) {
+
+ /* radius will not */
+ /* decrease by */
+ /* move right */
+
+ nleft++;
+ nright++;
+ continue;
+ }
+ }
+
+ /* fitted value at x[i] */
+
+ lowest(&x[1], &y[1], n, &x[i], &ys[i],
+ nleft, nright, res, iter>1, rw, &ok);
+ if (!ok) ys[i] = y[i];
+
+ /* all weights zero */
+ /* copy over value (all rw==0) */
+
+ if (last < i-1) {
+ denom = x[i]-x[last];
+
+ /* skipped points -- interpolate */
+ /* non-zero - proof? */
+
+ for(j = last+1; j < i; j++) {
+ alpha = (x[j]-x[last])/denom;
+ ys[j] = alpha*ys[i] + (1.-alpha)*ys[last];
+ }
+ }
+
+ /* last point actually estimated */
+ last = i;
+
+ /* x coord of close points */
+ cut = x[last]+delta;
+ for (i = last+1; i <= n; i++) {
+ if (x[i] > cut)
+ break;
+ if (x[i] == x[last]) {
+ ys[i] = ys[last];
+ last = i;
+ }
+ }
+ i = imax2(last+1, i-1);
+ if (last >= n)
+ break;
+ }
+ /* residuals */
+ for(i = 0; i < n; i++)
+ res[i] = y[i+1] - ys[i+1];
+
+ /* overall scale estimate */
+ sc = 0.;
+ for(i = 0; i < n; i++) sc += fabs(res[i]);
+ sc /= n;
+
+ /* compute robustness weights */
+ /* except last time */
+
+ if (iter > nsteps)
+ break;
+ /* Note: The following code, biweight_{6 MAD|Ri|}
+ is also used in stl(), loess and several other places.
+ --> should provide API here (MM) */
+ for(i = 0 ; i < n ; i++)
+ rw[i] = fabs(res[i]);
+
+ /* Compute cmad := 6 * median(rw[], n) ---- */
+ /* FIXME: We need C API in R for Median ! */
+ m1 = n/2;
+ /* partial sort, for m1 & m2 */
+ rPsort(rw, n, m1);
+ if(n % 2 == 0) {
+ m2 = n-m1-1;
+ rPsort(rw, n, m2);
+ cmad = 3.*(rw[m1]+rw[m2]);
+ }
+ else { /* n odd */
+ cmad = 6.*rw[m1];
+ }
+#ifdef DEBUG_lowess
+ REprintf(" cmad = %12g\n", cmad);
+#endif
+ if(cmad < 1e-7 * sc) /* effectively zero */
+ break;
+ c9 = 0.999*cmad;
+ c1 = 0.001*cmad;
+ for(i = 0 ; i < n ; i++) {
+ r = fabs(res[i]);
+ if (r <= c1)
+ rw[i] = 1.;
+ else if (r <= c9)
+ rw[i] = fsquare(1.-fsquare(r/cmad));
+ else
+ rw[i] = 0.;
+ }
+ iter++;
+ }
+}
+
+#include <Rinternals.h>
+SEXP lowess(SEXP x, SEXP y, SEXP sf, SEXP siter, SEXP sdelta)
+{
+ if(TYPEOF(x) != REALSXP || TYPEOF(y) != REALSXP) error("invalid input");
+ int nx = LENGTH(x);
+ if (nx == NA_INTEGER || nx == 0) error("invalid input");
+ double f = asReal(sf);
+ if (!R_FINITE(f) || f <= 0) error(_("'f' must be finite and > 0"));
+ int iter = asInteger(siter);
+ if (iter == NA_INTEGER || iter < 0)
+ error(_("'iter' must be finite and >= 0"));
+ double delta = asReal(sdelta), *rw, *res;
+ if (!R_FINITE(delta) || delta < 0)
+ error(_("'delta' must be finite and > 0"));
+ SEXP ans;
+ PROTECT(ans = allocVector(REALSXP, nx));
+ rw = (double *) R_alloc(nx, sizeof(double));
+ res = (double *) R_alloc(nx, sizeof(double));
+ clowess(REAL(x), REAL(y), nx, f, iter, delta, REAL(ans), rw, res);
+ UNPROTECT(1);
+ return ans;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/mAR.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/mAR.c
new file mode 100644
index 0000000000..a995f8f89a
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/mAR.c
@@ -0,0 +1,994 @@
+/*
+ * Copyright (C) 1999 Martyn Plummer
+ * Copyright (C) 1999-2016 The R Core Team
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/.
+ */
+
+#include <math.h>
+#include <string.h>
+#include <R.h>
+#include <R_ext/Applic.h> /* Fortran routines */
+#include "ts.h"
+#include "stats.h"
+
+
+#define MAX_DIM_LENGTH 4
+
+#define VECTOR(x) (x.vec)
+#define MATRIX(x) (x.mat)
+#define ARRAY1(x) (x.vec)
+#define ARRAY2(x) (x.mat)
+#define ARRAY3(x) (x.arr3)
+#define ARRAY4(x) (x.arr4)
+#define DIM(x) (x.dim)
+#define NROW(x) (x.dim[0])
+#define NCOL(x) (x.dim[1])
+#define DIM_LENGTH(x) (x.ndim)
+
+
+typedef struct array {
+ double *vec;
+ double **mat;
+ double ***arr3;
+ double ****arr4;
+ int dim[MAX_DIM_LENGTH];
+ int ndim;
+} Array;
+
+static Array make_array(double vec[], int dim[], int ndim);
+static Array make_zero_array(int dim[], int ndim);
+static Array make_matrix(double vec[], int nrow, int ncol);
+static Array make_zero_matrix(int nrow, int ncol);
+static Array make_identity_matrix(int n);
+
+static Array subarray(Array a, int index);
+
+static int vector_length(Array a);
+
+static void set_array_to_zero(Array arr);
+static void copy_array (Array orig, Array ans);
+static void array_op(Array arr1, Array arr2, char op, Array ans);
+static void scalar_op(Array arr, double s, char op, Array ans);
+
+static void transpose_matrix(Array mat, Array ans);
+static void matrix_prod(Array mat1, Array mat2, int trans1, int trans2,
+ Array ans);
+
+
+/* Functions for dynamically allocating arrays
+
+ The Array structure contains pointers to arrays which are allocated
+ using the R_alloc function. Although the .C() interface cleans up
+ all memory assigned with R_alloc, judicious use of vmaxget() vmaxset()
+ to free this memory is probably wise. See memory.c in R core.
+
+*/
+
+static void assert(int bool)
+{
+ if(!bool)
+ error(("assert failed in src/library/ts/src/carray.c"));
+}
+
+static Array init_array(void)
+{
+ int i;
+ Array a;
+
+ /* Initialize everything to zero. Useful for debugging */
+ ARRAY1(a) = (double *) '\0';
+ ARRAY2(a) = (double **) '\0';
+ ARRAY3(a) = (double ***) '\0';
+ ARRAY4(a) = (double ****) '\0';
+ for (i = 0; i < MAX_DIM_LENGTH; i++)
+ DIM(a)[i] = 0;
+ DIM_LENGTH(a) = 0;
+
+ return a;
+}
+
+static int vector_length(Array a)
+{
+ int i, len;
+
+ for (i = 0, len = 1; i < DIM_LENGTH(a); i++) {
+ len *= DIM(a)[i];
+ }
+
+ return len;
+}
+
+
+static Array make_array(double vec[], int dim[], int ndim)
+{
+ int d, i, j;
+ int len[MAX_DIM_LENGTH + 1];
+ Array a;
+
+ assert(ndim <= MAX_DIM_LENGTH);
+
+ a = init_array();
+
+ len[ndim] = 1;
+ for (d = ndim; d >= 1; d--) {
+ len[d-1] = len[d] * dim[ndim - d];
+ }
+
+ for (d = 1; d <= ndim; d++) {
+ switch(d) {
+ case 1:
+ VECTOR(a) = vec;
+ break;
+ case 2:
+ ARRAY2(a) = (double**) R_alloc(len[2 - 1],sizeof(double*));
+ for(i = 0, j = 0; i < len[2 - 1]; i++, j+=dim[ndim - 2 + 1]) {
+ ARRAY2(a)[i] = ARRAY1(a) + j;
+ }
+ break;
+ case 3:
+ ARRAY3(a) = (double***) R_alloc(len[3 - 1],sizeof(double**));
+ for(i = 0, j = 0; i < len[3 - 1]; i++, j+=dim[ndim - 3 + 1]) {
+ ARRAY3(a)[i] = ARRAY2(a) + j;
+ }
+ break;
+ case 4:
+ ARRAY4(a) = (double****) R_alloc(len[4 - 1],sizeof(double***));
+ for(i = 0, j = 0; i < len[4 - 1]; i++, j+=dim[ndim - 4 + 1]) {
+ ARRAY4(a)[i] = ARRAY3(a) + j;
+ }
+ break;
+ default:
+ break;
+ }
+ }
+
+ for (i = 0; i < ndim; i++) {
+ DIM(a)[i] = dim[i];
+ }
+ DIM_LENGTH(a) = ndim;
+
+ return a;
+}
+
+static Array make_zero_array(int dim[], int ndim)
+{
+ int i;
+ int len;
+ double *vec;
+
+ for (i = 0, len = 1; i < ndim; i++) {
+ len *= dim[i];
+ }
+
+ vec = (double *) R_alloc(len, sizeof(double));
+ for (i = 0; i < len; i++) {
+ vec[i] = 0.0;
+ }
+
+ return make_array(vec, dim, ndim);
+
+}
+
+static Array make_matrix(double vec[], int nrow, int ncol)
+{
+ int dim[2];
+
+ dim[0] = nrow;
+ dim[1] = ncol;
+ return make_array(vec, dim, 2);
+}
+
+static Array make_zero_matrix(int nrow, int ncol)
+{
+ int dim[2];
+ Array a;
+
+ dim[0] = nrow;
+ dim[1] = ncol;
+ a = make_zero_array(dim, 2);
+ return a;
+}
+
+static Array subarray(Array a, int index)
+/* Return subarray of array a in the form of an Array
+ structure so it can be manipulated by other functions
+ NB The data are not copied, so any changes made to the
+ subarray will affect the original array.
+*/
+{
+ int i, offset;
+ Array b;
+
+ b = init_array();
+
+ /* is index in range? */
+ assert( index >= 0 && index < DIM(a)[0] );
+
+ offset = index;
+ switch(DIM_LENGTH(a)) {
+ /* NB Falling through here */
+ case 4:
+ offset *= DIM(a)[DIM_LENGTH(a) - 4 + 1];
+ ARRAY3(b) = ARRAY3(a) + offset;
+ case 3:
+ offset *= DIM(a)[DIM_LENGTH(a) - 3 + 1];
+ ARRAY2(b) = ARRAY2(a) + offset;
+ case 2:
+ offset *= DIM(a)[DIM_LENGTH(a) - 2 + 1];
+ ARRAY1(b) = ARRAY1(a) + offset;
+ break;
+ default:
+ break;
+ }
+
+
+ DIM_LENGTH(b) = DIM_LENGTH(a) - 1;
+
+ for (i = 0; i < DIM_LENGTH(b); i++)
+ DIM(b)[i] = DIM(a)[i+1];
+
+ return b;
+
+}
+
+static int test_array_conform(Array a1, Array a2)
+{
+ int i, ans = FALSE;
+
+ if (DIM_LENGTH(a1) != DIM_LENGTH(a2))
+ return FALSE;
+ else
+ for (i = 0; i < DIM_LENGTH(a1); i++) {
+ if (DIM(a1)[i] == DIM(a2)[i])
+ ans = TRUE;
+ else
+ return FALSE;
+ }
+
+ return ans;
+}
+
+static void copy_array (Array orig, Array ans)
+/* copy matrix orig to ans */
+{
+ int i;
+
+ assert (test_array_conform(orig, ans));
+
+ for(i = 0; i < vector_length(orig); i++)
+ VECTOR(ans)[i] = VECTOR(orig)[i];
+}
+
+static void transpose_matrix(Array mat, Array ans)
+{
+ int i,j;
+ const void *vmax;
+ Array tmp;
+
+ tmp = init_array();
+
+ assert(DIM_LENGTH(mat) == 2 && DIM_LENGTH(ans) == 2);
+ assert(NCOL(mat) == NROW(ans));
+ assert(NROW(mat) == NCOL(ans));
+
+ vmax = vmaxget();
+
+ tmp = make_zero_matrix(NROW(ans), NCOL(ans));
+ for(i = 0; i < NROW(mat); i++)
+ for(j = 0; j < NCOL(mat); j++)
+ MATRIX(tmp)[j][i] = MATRIX(mat)[i][j];
+ copy_array(tmp, ans);
+
+ vmaxset(vmax);
+}
+
+static void array_op(Array arr1, Array arr2, char op, Array ans)
+/* Element-wise array operations */
+{
+ int i;
+
+ assert (test_array_conform(arr1, arr2));
+ assert (test_array_conform(arr2, ans));
+
+ switch (op) {
+ case '*':
+ for (i = 0; i < vector_length(ans); i++)
+ VECTOR(ans)[i] = VECTOR(arr1)[i] * VECTOR(arr2)[i];
+ break;
+ case '+':
+ for (i = 0; i < vector_length(ans); i++)
+ VECTOR(ans)[i] = VECTOR(arr1)[i] + VECTOR(arr2)[i];
+ break;
+ case '/':
+ for (i = 0; i < vector_length(ans); i++)
+ VECTOR(ans)[i] = VECTOR(arr1)[i] / VECTOR(arr2)[i];
+ break;
+ case '-':
+ for (i = 0; i < vector_length(ans); i++)
+ VECTOR(ans)[i] = VECTOR(arr1)[i] - VECTOR(arr2)[i];
+ break;
+ default:
+ printf("Unknown op in array_op");
+ }
+}
+
+
+static void scalar_op(Array arr, double s, char op, Array ans)
+/* Elementwise scalar operations */
+{
+ int i;
+
+ assert (test_array_conform(arr, ans));
+
+ switch (op) {
+ case '*':
+ for (i = 0; i < vector_length(ans); i++)
+ VECTOR(ans)[i] = VECTOR(arr)[i] * s;
+ break;
+ case '+':
+ for (i = 0; i < vector_length(ans); i++)
+ VECTOR(ans)[i] = VECTOR(arr)[i] + s;
+ break;
+ case '/':
+ for (i = 0; i < vector_length(ans); i++)
+ VECTOR(ans)[i] = VECTOR(arr)[i] / s;
+ break;
+ case '-':
+ for (i = 0; i < vector_length(ans); i++)
+ VECTOR(ans)[i] = VECTOR(arr)[i] - s;
+ break;
+ default:
+ printf("Unknown op in array_op");
+ }
+}
+
+static void matrix_prod(Array mat1, Array mat2, int trans1, int trans2, Array ans)
+/*
+ General matrix product between mat1 and mat2. Put answer in ans.
+ trans1 and trans2 are logical flags which indicate if the matrix is
+ to be transposed. Normal matrix multiplication has trans1 = trans2 = 0.
+*/
+{
+ int i,j,k,K1,K2;
+ const void *vmax;
+ double m1, m2;
+ Array tmp;
+
+ /* Test whether everything is a matrix */
+ assert(DIM_LENGTH(mat1) == 2 &&
+ DIM_LENGTH(mat2) == 2 && DIM_LENGTH(ans) == 2);
+
+ /* Test whether matrices conform. K is the dimension that is
+ lost by multiplication */
+ if (trans1) {
+ assert ( NCOL(mat1) == NROW(ans) );
+ K1 = NROW(mat1);
+ }
+ else {
+ assert ( NROW(mat1) == NROW(ans) );
+ K1 = NCOL(mat1);
+ }
+ if (trans2) {
+ assert ( NROW(mat2) == NCOL(ans) );
+ K2 = NCOL(mat2);
+ }
+ else {
+ assert ( NCOL(mat2) == NCOL(ans) );
+ K2 = NROW(mat2);
+ }
+ assert (K1 == K2);
+
+ tmp = init_array();
+
+ /* In case ans is the same as mat1 or mat2, we create a temporary
+ matrix to hold the answer, then copy it to ans
+ */
+ vmax = vmaxget();
+
+ tmp = make_zero_matrix(NROW(ans), NCOL(ans));
+ for (i = 0; i < NROW(tmp); i++) {
+ for (j = 0; j < NCOL(tmp); j++) {
+ for(k = 0; k < K1; k++) {
+ m1 = (trans1) ? MATRIX(mat1)[k][i] : MATRIX(mat1)[i][k];
+ m2 = (trans2) ? MATRIX(mat2)[j][k] : MATRIX(mat2)[k][j];
+ MATRIX(tmp)[i][j] += m1 * m2;
+ }
+ }
+ }
+ copy_array(tmp, ans);
+
+ vmaxset(vmax);
+}
+
+static void set_array_to_zero(Array arr)
+{
+ int i;
+
+ for (i = 0; i < vector_length(arr); i++)
+ VECTOR(arr)[i] = 0.0;
+}
+
+static Array make_identity_matrix(int n)
+{
+ int i;
+ Array a;
+
+ a = make_zero_matrix(n,n);
+ for(i = 0; i < n; i++)
+ MATRIX(a)[i][i] = 1.0;
+
+ return a;
+}
+
+static void qr_solve(Array x, Array y, Array coef)
+/* Translation of the R function qr.solve into pure C
+ NB We have to transpose the matrices since the ordering of an array is different in Fortran
+ NB2 We have to copy x to avoid it being overwritten.
+*/
+{
+ int i, info = 0, rank, *pivot, n, p;
+ const void *vmax;
+ double tol = 1.0E-7, *qraux, *work;
+ Array xt, yt, coeft;
+
+ assert(NROW(x) == NROW(y));
+ assert(NCOL(coef) == NCOL(y));
+ assert(NCOL(x) == NROW(coef));
+
+ vmax = vmaxget();
+
+ qraux = (double *) R_alloc(NCOL(x), sizeof(double));
+ pivot = (int *) R_alloc(NCOL(x), sizeof(int));
+ work = (double *) R_alloc(2*NCOL(x), sizeof(double));
+
+ for(i = 0; i < NCOL(x); i++)
+ pivot[i] = i+1;
+
+ xt = make_zero_matrix(NCOL(x), NROW(x));
+ transpose_matrix(x,xt);
+
+ n = NROW(x);
+ p = NCOL(x);
+
+ F77_CALL(dqrdc2)(VECTOR(xt), &n, &n, &p, &tol, &rank,
+ qraux, pivot, work);
+
+ if (rank != p)
+ error(_("Singular matrix in qr_solve"));
+
+ yt = make_zero_matrix(NCOL(y), NROW(y));
+ coeft = make_zero_matrix(NCOL(coef), NROW(coef));
+ transpose_matrix(y, yt);
+
+ F77_CALL(dqrcf)(VECTOR(xt), &NROW(x), &rank, qraux,
+ yt.vec, &NCOL(y), coeft.vec, &info);
+
+ transpose_matrix(coeft,coef);
+
+ vmaxset(vmax);
+}
+
+static double ldet(Array x)
+/* Log determinant of square matrix */
+{
+ int i, rank, *pivot, n, p;
+ const void *vmax;
+ double ll, tol = 1.0E-7, *qraux, *work;
+ Array xtmp;
+
+ assert(DIM_LENGTH(x) == 2); /* is x a matrix? */
+ assert(NROW(x) == NCOL(x)); /* is x square? */
+
+ vmax = vmaxget();
+
+ qraux = (double *) R_alloc(NCOL(x), sizeof(double));
+ pivot = (int *) R_alloc(NCOL(x), sizeof(int));
+ work = (double *) R_alloc(2*NCOL(x), sizeof(double));
+
+ xtmp = make_zero_matrix(NROW(x), NCOL(x));
+ copy_array(x, xtmp);
+
+ for(i = 0; i < NCOL(x); i++)
+ pivot[i] = i+1;
+
+ p = n = NROW(x);
+
+ F77_CALL(dqrdc2)(VECTOR(xtmp), &n, &n, &p, &tol, &rank,
+ qraux, pivot, work);
+
+ if (rank != p)
+ error(_("Singular matrix in ldet"));
+
+ for (i = 0, ll=0.0; i < rank; i++) {
+ ll += log(fabs(MATRIX(xtmp)[i][i]));
+ }
+
+ vmaxset(vmax);
+
+ return ll;
+}
+
+
+
+/* Burg's algorithm for autoregression estimation
+
+ multi_burg is the interface to R. It also handles model selection
+ using AIC
+
+ burg implements the main part of the algorithm
+
+ burg2 estimates the partial correlation coefficient. This
+ requires iteration in the multivariate case.
+
+ Notation
+
+ resid residuals (forward and backward)
+ A Estimates of autocorrelation coefficients
+ V Prediction Variance
+ K Partial correlation coefficient
+*/
+
+
+#define BURG_MAX_ITER 20
+#define BURG_TOL 1.0E-8
+
+void multi_burg(int *pn, double *x, int *pomax, int *pnser, double *coef,
+ double *pacf, double *var, double *aic, int *porder, int *useaic,
+ int *vmethod);
+static void burg0(int omax, Array resid_f, Array resid_b, Array *A, Array *B,
+ Array P, Array V, int vmethod);
+static void burg2(Array ss_ff, Array ss_bb, Array ss_fb, Array E,
+ Array KA, Array KB);
+
+void multi_burg(int *pn, double *x, int *pomax, int *pnser, double *coef,
+ double *pacf, double *var, double *aic, int *porder, int *useaic,
+ int *vmethod)
+{
+ int i, j, m, omax = *pomax, n = *pn, nser=*pnser, order=*porder;
+ int dim1[3];
+ double aicmin;
+ Array xarr, resid_f, resid_b, resid_f_tmp;
+ Array *A, *B, P, V;
+
+ dim1[0] = omax+1; dim1[1] = dim1[2] = nser;
+ A = (Array *) R_alloc(omax+1, sizeof(Array));
+ B = (Array *) R_alloc(omax+1, sizeof(Array));
+ for (i = 0; i <= omax; i++) {
+ A[i] = make_zero_array(dim1, 3);
+ B[i] = make_zero_array(dim1, 3);
+ }
+ P = make_array(pacf, dim1, 3);
+ V = make_array(var, dim1, 3);
+
+ xarr = make_matrix(x, nser, n);
+ resid_f = make_zero_matrix(nser, n);
+ resid_b = make_zero_matrix(nser, n);
+ set_array_to_zero(resid_b);
+ copy_array(xarr, resid_f);
+ copy_array(xarr, resid_b);
+ resid_f_tmp = make_zero_matrix(nser, n);
+
+ burg0(omax, resid_f, resid_b, A, B, P, V, *vmethod);
+
+ /* Model order selection */
+
+ for (i = 0; i <= omax; i++) {
+ aic[i] = n * ldet(subarray(V,i)) + 2 * i * nser * nser;
+ }
+ if (*useaic) {
+ order = 0;
+ aicmin = aic[0];
+ for (i = 1; i <= omax; i++) {
+ if (aic[i] < aicmin) {
+ aicmin = aic[i];
+ order = i;
+ }
+ }
+ }
+ else order = omax;
+ *porder = order;
+
+ for(i = 0; i < vector_length(A[order]); i++)
+ coef[i] = VECTOR(A[order])[i];
+
+ if (*useaic) {
+ /* Recalculate residuals for chosen model */
+ set_array_to_zero(resid_f);
+ set_array_to_zero(resid_f_tmp);
+ for (m = 0; m <= order; m++) {
+ for (i = 0; i < NROW(resid_f_tmp); i++) {
+ for (j = 0; j < NCOL(resid_f_tmp) - order; j++) {
+ MATRIX(resid_f_tmp)[i][j + order] = MATRIX(xarr)[i][j + order - m];
+ }
+ }
+ matrix_prod(subarray(A[order],m), resid_f_tmp, 0, 0, resid_f_tmp);
+ array_op(resid_f_tmp, resid_f, '+', resid_f);
+ }
+ }
+ copy_array(resid_f, xarr);
+
+}
+
+
+static void burg0(int omax, Array resid_f, Array resid_b, Array *A, Array *B,
+ Array P, Array V, int vmethod)
+{
+ int i, j, m, n = NCOL(resid_f), nser=NROW(resid_f);
+ Array ss_ff, ss_bb, ss_fb;
+ Array resid_f_tmp, resid_b_tmp;
+ Array KA, KB, E;
+ Array id, tmp;
+
+ ss_ff = make_zero_matrix(nser, nser);
+ ss_fb = make_zero_matrix(nser, nser);
+ ss_bb = make_zero_matrix(nser, nser);
+
+ resid_f_tmp = make_zero_matrix(nser, n);
+ resid_b_tmp = make_zero_matrix(nser, n);
+
+ id = make_identity_matrix(nser);
+
+ tmp = make_zero_matrix(nser, nser);
+
+ E = make_zero_matrix(nser, nser);
+ KA = make_zero_matrix(nser, nser);
+ KB = make_zero_matrix(nser, nser);
+
+ set_array_to_zero(A[0]);
+ set_array_to_zero(B[0]);
+ copy_array(id, subarray(A[0],0));
+ copy_array(id, subarray(B[0],0));
+
+ matrix_prod(resid_f, resid_f, 0, 1, E);
+ scalar_op(E, n, '/', E);
+ copy_array(E, subarray(V,0));
+
+ for (m = 0; m < omax; m++) {
+
+ for(i = 0; i < nser; i++) {
+ for (j = n - 1; j > m; j--) {
+ MATRIX(resid_b)[i][j] = MATRIX(resid_b)[i][j-1];
+ }
+ MATRIX(resid_f)[i][m] = 0.0;
+ MATRIX(resid_b)[i][m] = 0.0;
+ }
+ matrix_prod(resid_f, resid_f, 0, 1, ss_ff);
+ matrix_prod(resid_b, resid_b, 0, 1, ss_bb);
+ matrix_prod(resid_f, resid_b, 0, 1, ss_fb);
+
+ burg2(ss_ff, ss_bb, ss_fb, E, KA, KB); /* Update K */
+
+ for (i = 0; i <= m + 1; i++) {
+
+ matrix_prod(KA, subarray(B[m], m + 1 - i), 0, 0, tmp);
+ array_op(subarray(A[m], i), tmp, '-', subarray(A[m+1], i));
+
+ matrix_prod(KB, subarray(A[m], m + 1 - i), 0, 0, tmp);
+ array_op(subarray(B[m], i), tmp, '-', subarray(B[m+1], i));
+
+ }
+
+ matrix_prod(KA, resid_b, 0, 0, resid_f_tmp);
+ matrix_prod(KB, resid_f, 0, 0, resid_b_tmp);
+ array_op(resid_f, resid_f_tmp, '-', resid_f);
+ array_op(resid_b, resid_b_tmp, '-', resid_b);
+
+ if (vmethod == 1) {
+ matrix_prod(KA, KB, 0, 0, tmp);
+ array_op(id, tmp, '-', tmp);
+ matrix_prod(tmp, E, 0, 0, E);
+ }
+ else if (vmethod == 2) {
+ matrix_prod(resid_f, resid_f, 0, 1, E);
+ matrix_prod(resid_b, resid_b, 0, 1, tmp);
+ array_op(E, tmp, '+', E);
+ scalar_op(E, 2.0*(n - m - 1), '/', E);
+ }
+ else error(_("Invalid vmethod"));
+
+ copy_array(E, subarray(V,m+1));
+ copy_array(KA, subarray(P,m+1));
+ }
+}
+
+
+static void burg2(Array ss_ff, Array ss_bb, Array ss_fb, Array E,
+ Array KA, Array KB)
+/*
+ Estimate partial correlation by minimizing (1/2)*log(det(s)) where
+ "s" is the the sum of the forward and backward prediction errors.
+
+ In the multivariate case, the forward (KA) and backward (KB) partial
+ correlation coefficients are related by
+
+ KA = solve(E) %*% t(KB) %*% E
+
+ where E is the prediction variance.
+
+*/
+{
+ int i, j, k, l, nser = NROW(ss_ff);
+ int iter;
+ Array ss_bf;
+ Array s, tmp, d1;
+ Array D1, D2, THETA, THETAOLD, THETADIFF, TMP;
+ Array obj;
+ Array e, f, g, h, sg, sh;
+ Array theta;
+
+ ss_bf = make_zero_matrix(nser,nser);
+ transpose_matrix(ss_fb, ss_bf);
+ s = make_zero_matrix(nser, nser);
+ tmp = make_zero_matrix(nser, nser);
+ d1 = make_zero_matrix(nser, nser);
+
+ e = make_zero_matrix(nser, nser);
+ f = make_zero_matrix(nser, nser);
+ g = make_zero_matrix(nser, nser);
+ h = make_zero_matrix(nser, nser);
+ sg = make_zero_matrix(nser, nser);
+ sh = make_zero_matrix(nser, nser);
+
+ theta = make_zero_matrix(nser, nser);
+
+ D1 = make_zero_matrix(nser*nser, 1);
+ D2 = make_zero_matrix(nser*nser, nser*nser);
+ THETA = make_zero_matrix(nser*nser, 1); /* theta in vector form */
+ THETAOLD = make_zero_matrix(nser*nser, 1);
+ THETADIFF = make_zero_matrix(nser*nser, 1);
+ TMP = make_zero_matrix(nser*nser, 1);
+
+ obj = make_zero_matrix(1,1);
+
+ /* utility matrices e,f,g,h */
+ qr_solve(E, ss_bf, e);
+ qr_solve(E, ss_fb, f);
+ qr_solve(E, ss_bb, tmp);
+ transpose_matrix(tmp, tmp);
+ qr_solve(E, tmp, g);
+ qr_solve(E, ss_ff, tmp);
+ transpose_matrix(tmp, tmp);
+ qr_solve(E, tmp, h);
+
+ for(iter = 0; iter < BURG_MAX_ITER; iter++)
+ {
+ /* Forward and backward partial correlation coefficients */
+ transpose_matrix(theta, tmp);
+ qr_solve(E, tmp, tmp);
+ transpose_matrix(tmp, KA);
+
+ qr_solve(E, theta, tmp);
+ transpose_matrix(tmp, KB);
+
+ /* Sum of forward and backward prediction errors ... */
+ set_array_to_zero(s);
+
+ /* Forward */
+ array_op(s, ss_ff, '+', s);
+ matrix_prod(KA, ss_bf, 0, 0, tmp);
+ array_op(s, tmp, '-', s);
+ transpose_matrix(tmp, tmp);
+ array_op(s, tmp, '-', s);
+ matrix_prod(ss_bb, KA, 0, 1, tmp);
+ matrix_prod(KA, tmp, 0, 0, tmp);
+ array_op(s, tmp, '+', s);
+
+ /* Backward */
+ array_op(s, ss_bb, '+', s);
+ matrix_prod(KB, ss_fb, 0, 0, tmp);
+ array_op(s, tmp, '-', s);
+ transpose_matrix(tmp, tmp);
+ array_op(s, tmp, '-', s);
+ matrix_prod(ss_ff, KB, 0, 1, tmp);
+ matrix_prod(KB, tmp, 0, 0, tmp);
+ array_op(s, tmp, '+', s);
+
+ matrix_prod(s, f, 0, 0, d1);
+ matrix_prod(e, s, 1, 0, tmp);
+ array_op(d1, tmp, '+', d1);
+
+ /*matrix_prod(g,s,0,0,sg);*/
+ matrix_prod(s,g,0,0,sg);
+ matrix_prod(s,h,0,0,sh);
+
+ for (i = 0; i < nser; i++) {
+ for (j = 0; j < nser; j++) {
+ MATRIX(D1)[nser*i+j][0] = MATRIX(d1)[i][j];
+ for (k = 0; k < nser; k++)
+ for (l = 0; l < nser; l++) {
+ MATRIX(D2)[nser*i+j][nser*k+l] =
+ (i == k) * MATRIX(sg)[j][l] +
+ MATRIX(sh)[i][k] * (j == l);
+ }
+ }
+ }
+
+ copy_array(THETA, THETAOLD);
+ qr_solve(D2, D1, THETA);
+
+ for (i = 0; i < vector_length(theta); i++)
+ VECTOR(theta)[i] = VECTOR(THETA)[i];
+
+ matrix_prod(D2, THETA, 0, 0, TMP);
+
+ array_op(THETAOLD, THETA, '-', THETADIFF);
+ matrix_prod(D2, THETADIFF, 0, 0, TMP);
+ matrix_prod(THETADIFF, TMP, 1, 0, obj);
+ if (VECTOR(obj)[0] < BURG_TOL)
+ break;
+
+ }
+
+ if (iter == BURG_MAX_ITER)
+ error(_("Burg's algorithm failed to find partial correlation"));
+}
+
+/* Whittle's algorithm for autoregression estimation
+
+ multi_yw is the interface to R. It also handles model selection using AIC
+
+ whittle,whittle2 implement Whittle's recursion for solving the multivariate
+ Yule-Walker equations.
+
+ Notation
+
+ resid residuals (forward and backward)
+ A Estimates of forward autocorrelation coefficients
+ B Estimates of backward autocorrelation coefficients
+ EA,EB Prediction Variance
+ KA,KB Partial correlation coefficient
+*/
+
+void multi_yw(double *acf, int *pn, int *pomax, int *pnser, double *coef,
+ double *pacf, double *var, double *aic, int *porder,
+ int *puseaic);
+static void whittle(Array acf, int nlag, Array *A, Array *B, Array p_forward,
+ Array v_forward, Array p_back, Array v_back);
+static void whittle2 (Array acf, Array Aold, Array Bold, int lag,
+ char *direction, Array A, Array K, Array E);
+
+
+void multi_yw(double *acf, int *pn, int *pomax, int *pnser, double *coef,
+ double *pacf, double *var, double *aic, int *porder, int *useaic)
+{
+ int i, m;
+ int omax = *pomax, n = *pn, nser=*pnser, order=*porder;
+ double aicmin;
+ Array acf_array, p_forward, p_back, v_forward, v_back;
+ Array *A, *B;
+ int dim[3];
+
+ dim[0] = omax+1; dim[1] = dim[2] = nser;
+ acf_array = make_array(acf, dim, 3);
+ p_forward = make_array(pacf, dim, 3);
+ v_forward = make_array(var, dim, 3);
+
+ /* Backward equations (discarded) */
+ p_back= make_zero_array(dim, 3);
+ v_back= make_zero_array(dim, 3);
+
+ A = (Array *) R_alloc(omax+2, sizeof(Array));
+ B = (Array *) R_alloc(omax+2, sizeof(Array));
+ for (i = 0; i <= omax; i++) {
+ A[i] = make_zero_array(dim, 3);
+ B[i] = make_zero_array(dim, 3);
+ }
+ whittle(acf_array, omax, A, B, p_forward, v_forward, p_back, v_back);
+
+ /* Model order selection */
+
+ for (m = 0; m <= omax; m++) {
+ aic[m] = n * ldet(subarray(v_forward,m)) + 2 * m * nser * nser;
+ }
+ if (*useaic) {
+ order = 0;
+ aicmin = aic[0];
+ for (m = 0; m <= omax; m++) {
+ if (aic[m] < aicmin) {
+ aicmin = aic[m];
+ order = m;
+ }
+ }
+ }
+ else order = omax;
+ *porder = order;
+
+ for(i = 0; i < vector_length(A[order]); i++)
+ coef[i] = VECTOR(A[order])[i];
+}
+
+static void whittle(Array acf, int nlag, Array *A, Array *B, Array p_forward,
+ Array v_forward, Array p_back, Array v_back)
+{
+
+ int lag, nser = DIM(acf)[1];
+ const void *vmax;
+ Array EA, EB; /* prediction variance */
+ Array KA, KB; /* partial correlation coefficient */
+ Array id, tmp;
+
+ vmax = vmaxget();
+
+ KA = make_zero_matrix(nser, nser);
+ EA = make_zero_matrix(nser, nser);
+
+ KB = make_zero_matrix(nser, nser);
+ EB = make_zero_matrix(nser, nser);
+
+ id = make_identity_matrix(nser);
+
+ copy_array(id, subarray(A[0],0));
+ copy_array(id, subarray(B[0],0));
+ copy_array(id, subarray(p_forward,0));
+ copy_array(id, subarray(p_back,0));
+
+ for (lag = 1; lag <= nlag; lag++) {
+
+ whittle2(acf, A[lag-1], B[lag-1], lag, "forward", A[lag], KA, EB);
+ whittle2(acf, B[lag-1], A[lag-1], lag, "back", B[lag], KB, EA);
+
+ copy_array(EA, subarray(v_forward,lag-1));
+ copy_array(EB, subarray(v_back,lag-1));
+
+ copy_array(KA, subarray(p_forward,lag));
+ copy_array(KB, subarray(p_back,lag));
+
+ }
+
+ tmp = make_zero_matrix(nser,nser);
+
+ matrix_prod(KB,KA, 1, 1, tmp);
+ array_op(id, tmp, '-', tmp);
+ matrix_prod(EA, tmp, 0, 0, subarray(v_forward, nlag));
+
+ vmaxset(vmax);
+
+}
+
+static void whittle2 (Array acf, Array Aold, Array Bold, int lag,
+ char *direction, Array A, Array K, Array E)
+{
+
+ int d, i, nser=DIM(acf)[1];
+ const void *vmax;
+ Array beta, tmp, id;
+
+ d = strcmp(direction, "forward") == 0;
+
+ vmax = vmaxget();
+
+ beta = make_zero_matrix(nser,nser);
+ tmp = make_zero_matrix(nser, nser);
+ id = make_identity_matrix(nser);
+
+ set_array_to_zero(E);
+ copy_array(id, subarray(A,0));
+
+ for(i = 0; i < lag; i++) {
+ matrix_prod(subarray(acf,lag - i), subarray(Aold,i), d, 1, tmp);
+ array_op(beta, tmp, '+', beta);
+ matrix_prod(subarray(acf,i), subarray(Bold,i), d, 1, tmp);
+ array_op(E, tmp, '+', E);
+ }
+ qr_solve(E, beta, K);
+ transpose_matrix(K,K);
+ for (i = 1; i <= lag; i++) {
+ matrix_prod(K, subarray(Bold,lag - i), 0, 0, tmp);
+ array_op(subarray(Aold,i), tmp, '-', subarray(A,i));
+ }
+
+ vmaxset(vmax);
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/pacf.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/pacf.c
new file mode 100644
index 0000000000..6189fdc3b9
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/pacf.c
@@ -0,0 +1,477 @@
+/* R : A Computer Language for Statistical Data Analysis
+ *
+ * Copyright (C) 1999-2016 The R Core Team
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/.
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <R.h>
+#include "ts.h"
+
+#ifndef max
+#define max(a,b) ((a < b)?(b):(a))
+#endif
+#ifndef min
+#define min(a,b) ((a > b)?(b):(a))
+#endif
+
+
+/* Internal */
+static void partrans(int np, double *raw, double *new);
+static void dotrans(Starma G, double *raw, double *new, int trans);
+
+
+/* cor is the autocorrelations starting from 0 lag*/
+static void uni_pacf(double *cor, double *p, int nlag)
+{
+ double a, b, c, *v, *w;
+
+ v = (double*) R_alloc(nlag, sizeof(double));
+ w = (double*) R_alloc(nlag, sizeof(double));
+ w[0] = p[0] = cor[1];
+ for(int ll = 1; ll < nlag; ll++) {
+ a = cor[ll+1];
+ b = 1.0;
+ for(int i = 0; i < ll; i++) {
+ a -= w[i] * cor[ll - i];
+ b -= w[i] * cor[i + 1];
+ }
+ p[ll] = c = a/b;
+ if(ll+1 == nlag) break;
+ w[ll] = c;
+ for(int i = 0; i < ll; i++)
+ v[ll-i-1] = w[i];
+ for(int i = 0; i < ll; i++)
+ w[i] -= c*v[i];
+ }
+}
+
+SEXP pacf1(SEXP acf, SEXP lmax)
+{
+ int lagmax = asInteger(lmax);
+ acf = PROTECT(coerceVector(acf, REALSXP));
+ SEXP ans = PROTECT(allocVector(REALSXP, lagmax));
+ uni_pacf(REAL(acf), REAL(ans), lagmax);
+ SEXP d = PROTECT(allocVector(INTSXP, 3));
+ INTEGER(d)[0] = lagmax;
+ INTEGER(d)[1] = INTEGER(d)[2] = 1;
+ setAttrib(ans, R_DimSymbol, d);
+ UNPROTECT(3);
+ return ans;
+}
+
+
+/* Use an external reference to store the structure we keep allocated
+ memory in */
+static SEXP Starma_tag;
+
+#define GET_STARMA \
+ Starma G; \
+ if (TYPEOF(pG) != EXTPTRSXP || R_ExternalPtrTag(pG) != Starma_tag) \
+ error(_("bad Starma struct"));\
+ G = (Starma) R_ExternalPtrAddr(pG)
+
+SEXP setup_starma(SEXP na, SEXP x, SEXP pn, SEXP xreg, SEXP pm,
+ SEXP dt, SEXP ptrans, SEXP sncond)
+{
+ Starma G;
+ int i, n, m, ip, iq, ir, np;
+ SEXP res;
+ double *rx = REAL(x), *rxreg = REAL(xreg);
+
+ G = Calloc(1, starma_struct);
+ G->mp = INTEGER(na)[0];
+ G->mq = INTEGER(na)[1];
+ G->msp = INTEGER(na)[2];
+ G->msq = INTEGER(na)[3];
+ G->ns = INTEGER(na)[4];
+ G->n = n = asInteger(pn);
+ G->ncond = asInteger(sncond);
+ G->m = m = asInteger(pm);
+ G->params = Calloc(G->mp + G->mq + G->msp + G->msq + G->m, double);
+ G->p = ip = G->ns*G->msp + G->mp;
+ G->q = iq = G->ns*G->msq + G->mq;
+ G->r = ir = max(ip, iq + 1);
+ G->np = np = (ir*(ir + 1))/2;
+ G->nrbar = max(1, np*(np - 1)/2);
+ G->trans = asInteger(ptrans);
+ G->a = Calloc(ir, double);
+ G->P = Calloc(np, double);
+ G->V = Calloc(np, double);
+ G->thetab = Calloc(np, double);
+ G->xnext = Calloc(np, double);
+ G->xrow = Calloc(np, double);
+ G->rbar = Calloc(G->nrbar, double);
+ G->w = Calloc(n, double);
+ G->wkeep = Calloc(n, double);
+ G->resid = Calloc(n, double);
+ G->phi = Calloc(ir, double);
+ G->theta = Calloc(ir, double);
+ G->reg = Calloc(1 + n*m, double); /* AIX can't calloc 0 items */
+ G->delta = asReal(dt);
+ for(i = 0; i < n; i++) G->w[i] = G->wkeep[i] = rx[i];
+ for(i = 0; i < n*m; i++) G->reg[i] = rxreg[i];
+ Starma_tag = install("STARMA_TAG");
+ res = R_MakeExternalPtr(G, Starma_tag, R_NilValue);
+ return res;
+}
+
+SEXP free_starma(SEXP pG)
+{
+ GET_STARMA;
+
+ Free(G->params); Free(G->a); Free(G->P); Free(G->V); Free(G->thetab);
+ Free(G->xnext); Free(G->xrow); Free(G->rbar);
+ Free(G->w); Free(G->wkeep); Free(G->resid); Free(G->phi); Free(G->theta);
+ Free(G->reg); Free(G);
+ return R_NilValue;
+}
+
+SEXP Starma_method(SEXP pG, SEXP method)
+{
+ GET_STARMA;
+
+ G->method = asInteger(method);
+ return R_NilValue;
+}
+
+SEXP Dotrans(SEXP pG, SEXP x)
+{
+ SEXP y = allocVector(REALSXP, LENGTH(x));
+ GET_STARMA;
+
+ dotrans(G, REAL(x), REAL(y), 1);
+ return y;
+}
+
+SEXP set_trans(SEXP pG, SEXP ptrans)
+{
+ GET_STARMA;
+
+ G->trans = asInteger(ptrans);
+ return R_NilValue;
+}
+
+SEXP arma0fa(SEXP pG, SEXP inparams)
+{
+ int i, j, ifault = 0, it, streg;
+ double sumlog, ssq, tmp, ans;
+
+ GET_STARMA;
+ dotrans(G, REAL(inparams), G->params, G->trans);
+
+ if(G->ns > 0) {
+ /* expand out seasonal ARMA models */
+ for(i = 0; i < G->mp; i++) G->phi[i] = G->params[i];
+ for(i = 0; i < G->mq; i++) G->theta[i] = G->params[i + G->mp];
+ for(i = G->mp; i < G->p; i++) G->phi[i] = 0.0;
+ for(i = G->mq; i < G->q; i++) G->theta[i] = 0.0;
+ for(j = 0; j < G->msp; j++) {
+ G->phi[(j + 1)*G->ns - 1] += G->params[j + G->mp + G->mq];
+ for(i = 0; i < G->mp; i++)
+ G->phi[(j + 1)*G->ns + i] -= G->params[i]*
+ G->params[j + G->mp + G->mq];
+ }
+ for(j = 0; j < G->msq; j++) {
+ G->theta[(j + 1)*G->ns - 1] +=
+ G->params[j + G->mp + G->mq + G->msp];
+ for(i = 0; i < G->mq; i++)
+ G->theta[(j + 1)*G->ns + i] += G->params[i + G->mp]*
+ G->params[j + G->mp + G->mq + G->msp];
+ }
+ } else {
+ for(i = 0; i < G->mp; i++) G->phi[i] = G->params[i];
+ for(i = 0; i < G->mq; i++) G->theta[i] = G->params[i + G->mp];
+ }
+
+ streg = G->mp + G->mq + G->msp + G->msq;
+ if(G->m > 0) {
+ for(i = 0; i < G->n; i++) {
+ tmp = G->wkeep[i];
+ for(j = 0; j < G->m; j++)
+ tmp -= G->reg[i + G->n*j] * G->params[streg + j];
+ G->w[i] = tmp;
+ }
+ }
+
+ if(G->method == 1) {
+ int p = G->mp + G->ns * G->msp, q = G->mq + G->ns * G->msq, nu = 0;
+ ssq = 0.0;
+ for(i = 0; i < G->ncond; i++) G->resid[i] = 0.0;
+ for(i = G->ncond; i < G->n; i++) {
+ tmp = G->w[i];
+ for(j = 0; j < min(i - G->ncond, p); j++)
+ tmp -= G->phi[j] * G->w[i - j - 1];
+ for(j = 0; j < min(i - G->ncond, q); j++)
+ tmp -= G->theta[j] * G->resid[i - j - 1];
+ G->resid[i] = tmp;
+ if(!ISNAN(tmp)) {
+ nu++;
+ ssq += tmp * tmp;
+ }
+ }
+ G->s2 = ssq/(double)(nu);
+ ans = 0.5 * log(G->s2);
+ } else {
+ starma(G, &ifault);
+ if(ifault) error(_("starma error code %d"), ifault);
+ sumlog = 0.0;
+ ssq = 0.0;
+ it = 0;
+ karma(G, &sumlog, &ssq, 1, &it);
+ G->s2 = ssq/(double)G->nused;
+ ans = 0.5*(log(ssq/(double)G->nused) + sumlog/(double)G->nused);
+ }
+ return ScalarReal(ans);
+}
+
+SEXP get_s2(SEXP pG)
+{
+ GET_STARMA;
+ return ScalarReal(G->s2);
+}
+
+SEXP get_resid(SEXP pG)
+{
+ SEXP res;
+ int i;
+ double *rres;
+ GET_STARMA;
+
+ res = allocVector(REALSXP, G->n);
+ rres = REAL(res);
+ for(i = 0; i < G->n; i++) rres[i] = G->resid[i];
+ return res;
+}
+
+SEXP arma0_kfore(SEXP pG, SEXP pd, SEXP psd, SEXP nahead)
+{
+ int dd = asInteger(pd);
+ int d, il = asInteger(nahead), ifault = 0, i, j;
+ double *del, *del2;
+ SEXP res, x, var;
+ GET_STARMA;
+
+ PROTECT(res = allocVector(VECSXP, 2));
+ SET_VECTOR_ELT(res, 0, x = allocVector(REALSXP, il));
+ SET_VECTOR_ELT(res, 1, var = allocVector(REALSXP, il));
+
+ d = dd + G->ns * asInteger(psd);
+
+ del = (double *) R_alloc(d + 1, sizeof(double));
+ del2 = (double *) R_alloc(d + 1, sizeof(double));
+ del[0] = 1;
+ for(i = 1; i <= d; i++) del[i] = 0;
+ for (j = 0; j < dd; j++) {
+ for(i = 0; i <= d; i++) del2[i] = del[i];
+ for(i = 0; i <= d - 1; i++) del[i+1] -= del2[i];
+ }
+ for (j = 0; j < asInteger(psd); j++) {
+ for(i = 0; i <= d; i++) del2[i] = del[i];
+ for(i = 0; i <= d - G->ns; i++) del[i + G->ns] -= del2[i];
+ }
+ for(i = 1; i <= d; i++) del[i] *= -1;
+
+
+ forkal(G, d, il, del + 1, REAL(x), REAL(var), &ifault);
+ if(ifault) error(_("forkal error code %d"), ifault);
+ UNPROTECT(1);
+ return res;
+}
+
+static void artoma(int p, double *phi, double *psi, int npsi)
+{
+ int i, j;
+
+ for(i = 0; i < p; i++) psi[i] = phi[i];
+ for(i = p; i < npsi; i++) psi[i] = 0.0;
+ for(i = 0; i < npsi - p - 1; i++)
+ for(j = 0; j < p; j++) psi[i + j + 1] += phi[j]*psi[i];
+}
+
+SEXP ar2ma(SEXP ar, SEXP npsi)
+{
+ ar = PROTECT(coerceVector(ar, REALSXP));
+ int p = LENGTH(ar), ns = asInteger(npsi), ns1 = ns + p + 1;
+ SEXP psi = PROTECT(allocVector(REALSXP, ns1));
+ artoma(p, REAL(ar), REAL(psi), ns1);
+ SEXP ans = lengthgets(psi, ns);
+ UNPROTECT(2);
+ return ans;
+}
+
+static void partrans(int p, double *raw, double *new)
+{
+ int j, k;
+ double a, work[100];
+
+ if(p > 100) error(_("can only transform 100 pars in arima0"));
+
+ /* Step one: map (-Inf, Inf) to (-1, 1) via tanh
+ The parameters are now the pacf phi_{kk} */
+ for(j = 0; j < p; j++) work[j] = new[j] = tanh(raw[j]);
+ /* Step two: run the Durbin-Levinson recursions to find phi_{j.},
+ j = 2, ..., p and phi_{p.} are the autoregression coefficients */
+ for(j = 1; j < p; j++) {
+ a = new[j];
+ for(k = 0; k < j; k++)
+ work[k] -= a * new[j - k - 1];
+ for(k = 0; k < j; k++) new[k] = work[k];
+ }
+}
+
+static void dotrans(Starma G, double *raw, double *new, int trans)
+{
+ int i, v, n = G->mp + G->mq + G->msp + G->msq + G->m;
+
+ for(i = 0; i < n; i++) new[i] = raw[i];
+ if(trans) {
+ partrans(G->mp, raw, new);
+ v = G->mp;
+ partrans(G->mq, raw + v, new + v);
+ v += G->mq;
+ partrans(G->msp, raw + v, new + v);
+ v += G->msp;
+ partrans(G->msq, raw + v, new + v);
+ }
+}
+
+#if !defined(atanh) && defined(HAVE_DECL_ATANH) && !HAVE_DECL_ATANH
+extern double atanh(double x);
+#endif
+static void invpartrans(int p, double *phi, double *new)
+{
+ int j, k;
+ double a, work[100];
+
+ if(p > 100) error(_("can only transform 100 pars in arima0"));
+
+ for(j = 0; j < p; j++) work[j] = new[j] = phi[j];
+ /* Run the Durbin-Levinson recursions backwards
+ to find the PACF phi_{j.} from the autoregression coefficients */
+ for(j = p - 1; j > 0; j--) {
+ a = new[j];
+ for(k = 0; k < j; k++)
+ work[k] = (new[k] + a * new[j - k - 1]) / (1 - a * a);
+ for(k = 0; k < j; k++) new[k] = work[k];
+ }
+ for(j = 0; j < p; j++) new[j] = atanh(new[j]);
+}
+
+SEXP Invtrans(SEXP pG, SEXP x)
+{
+ SEXP y = allocVector(REALSXP, LENGTH(x));
+ int i, v, n;
+ double *raw = REAL(x), *new = REAL(y);
+ GET_STARMA;
+
+ n = G->mp + G->mq + G->msp + G->msq;
+
+ v = 0;
+ invpartrans(G->mp, raw + v, new + v);
+ v += G->mp;
+ invpartrans(G->mq, raw + v, new + v);
+ v += G->mq;
+ invpartrans(G->msp, raw + v, new + v);
+ v += G->msp;
+ invpartrans(G->msq, raw + v, new + v);
+ for(i = n; i < n + G->m; i++) new[i] = raw[i];
+ return y;
+}
+
+#define eps 1e-3
+SEXP Gradtrans(SEXP pG, SEXP x)
+{
+ SEXP y = allocMatrix(REALSXP, LENGTH(x), LENGTH(x));
+ int i, j, v, n;
+ double *raw = REAL(x), *A = REAL(y), w1[100], w2[100], w3[100];
+ GET_STARMA;
+
+ n = G->mp + G->mq + G->msp + G->msq + G->m;
+ for(i = 0; i < n; i++)
+ for(j = 0; j < n; j++)
+ A[i + j*n] = (i == j);
+ if(G->mp > 0) {
+ for(i = 0; i < G->mp; i++) w1[i] = raw[i];
+ partrans(G->mp, w1, w2);
+ for(i = 0; i < G->mp; i++) {
+ w1[i] += eps;
+ partrans(G->mp, w1, w3);
+ for(j = 0; j < G->mp; j++) A[i + j*n] = (w3[j] - w2[j])/eps;
+ w1[i] -= eps;
+ }
+ }
+ if(G->mq > 0) {
+ v = G->mp;
+ for(i = 0; i < G->mq; i++) w1[i] = raw[i + v];
+ partrans(G->mq, w1, w2);
+ for(i = 0; i < G->mq; i++) {
+ w1[i] += eps;
+ partrans(G->mq, w1, w3);
+ for(j = 0; j < G->mq; j++) A[i + v + j*n] = (w3[j] - w2[j])/eps;
+ w1[i] -= eps;
+ }
+ }
+ if(G->msp > 0) {
+ v = G->mp + G->mq;
+ for(i = 0; i < G->msp; i++) w1[i] = raw[i + v];
+ partrans(G->msp, w1, w2);
+ for(i = 0; i < G->msp; i++) {
+ w1[i] += eps;
+ partrans(G->msp, w1, w3);
+ for(j = 0; j < G->msp; j++)
+ A[i + v + (j+v)*n] = (w3[j] - w2[j])/eps;
+ w1[i] -= eps;
+ }
+ }
+ if(G->msq > 0) {
+ v = G->mp + G->mq + G->msp;
+ for(i = 0; i < G->msq; i++) w1[i] = raw[i + v];
+ partrans(G->msq, w1, w2);
+ for(i = 0; i < G->msq; i++) {
+ w1[i] += eps;
+ partrans(G->msq, w1, w3);
+ for(j = 0; j < G->msq; j++)
+ A[i + v + (j+v)*n] = (w3[j] - w2[j])/eps;
+ w1[i] -= eps;
+ }
+ }
+ return y;
+}
+
+SEXP
+ARMAtoMA(SEXP ar, SEXP ma, SEXP lag_max)
+{
+ int i, j, p = LENGTH(ar), q = LENGTH(ma), m = asInteger(lag_max);
+ double *phi = REAL(ar), *theta = REAL(ma), *psi, tmp;
+ SEXP res;
+
+ if(m <= 0 || m == NA_INTEGER)
+ error(_("invalid value of lag.max"));
+ PROTECT(res = allocVector(REALSXP, m));
+ psi = REAL(res);
+ for(i = 0; i < m; i++) {
+ tmp = (i < q) ? theta[i] : 0.0;
+ for(j = 0; j < min(i+1, p); j++)
+ tmp += phi[j] * ((i-j-1 >= 0) ? psi[i-j-1] : 1.0);
+ psi[i] = tmp;
+ }
+ UNPROTECT(1);
+ return res;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/portsrc.f b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/portsrc.f
new file mode 100644
index 0000000000..46838e5553
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/portsrc.f
@@ -0,0 +1,12378 @@
+ SUBROUTINE DRN2G(D, DR, IV, LIV, LV, N, ND, N1, N2, P, R,
+ 1 RD, V, X)
+C
+C *** REVISED ITERATION DRIVER FOR NL2SOL (VERSION 2.3) ***
+C
+ INTEGER LIV, LV, N, ND, N1, N2, P
+ INTEGER IV(LIV)
+ DOUBLE PRECISION D(P), DR(ND,P), R(ND), RD(ND), V(LV), X(P)
+C
+C-------------------------- PARAMETER USAGE --------------------------
+C
+C D........ SCALE VECTOR.
+C DR....... DERIVATIVES OF R AT X.
+C IV....... INTEGER VALUES ARRAY.
+C LIV...... LENGTH OF IV... LIV MUST BE AT LEAST P + 82.
+C LV....... LENGTH OF V... LV MUST BE AT LEAST 105 + P*(2*P+16).
+C N........ TOTAL NUMBER OF RESIDUALS.
+C ND....... MAX. NO. OF RESIDUALS PASSED ON ONE CALL.
+C N1....... LOWEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME.
+C N2....... HIGHEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME.
+C P........ NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED.
+C R........ RESIDUALS.
+C RD....... RD(I) = SQRT(G(I)**T * H(I)**-1 * G(I)) ON OUTPUT WHEN
+C IV(RDREQ) IS NONZERO. DRN2G SETS IV(REGD) = 1 IF RD
+C IS SUCCESSFULLY COMPUTED, TO 0 IF NO ATTEMPT WAS MADE
+C TO COMPUTE IT, AND TO -1 IF H (THE FINITE-DIFFERENCE HESSIAN)
+C WAS INDEFINITE. IF ND .GE. N, THEN RD IS ALSO USED AS
+C TEMPORARY STORAGE.
+C V........ FLOATING-POINT VALUES ARRAY.
+C X........ PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS,
+C OUTPUT = BEST VALUE FOUND).
+C
+C *** DISCUSSION ***
+C
+C NOTE... NL2SOL AND NL2ITR (MENTIONED BELOW) ARE DESCRIBED IN
+C ACM TRANS. MATH. SOFTWARE, VOL. 7, PP. 369-383 (AN ADAPTIVE
+C NONLINEAR LEAST-SQUARES ALGORITHM, BY J.E. DENNIS, D.M. GAY,
+C AND R.E. WELSCH).
+C
+C THIS ROUTINE CARRIES OUT ITERATIONS FOR SOLVING NONLINEAR
+C LEAST SQUARES PROBLEMS. WHEN ND = N, IT IS SIMILAR TO NL2ITR
+C (WITH J = DR), EXCEPT THAT R(X) AND DR(X) NEED NOT BE INITIALIZED
+C WHEN DRN2G IS CALLED WITH IV(1) = 0 OR 12. DRN2G ALSO ALLOWS
+C R AND DR TO BE SUPPLIED ROW-WISE -- JUST SET ND = 1 AND CALL
+C DRN2G ONCE FOR EACH ROW WHEN PROVIDING RESIDUALS AND JACOBIANS.
+C ANOTHER NEW FEATURE IS THAT CALLING DRN2G WITH IV(1) = 13
+C CAUSES STORAGE ALLOCATION ONLY TO BE PERFORMED -- ON RETURN, SUCH
+C COMPONENTS AS IV(G) (THE FIRST SUBSCRIPT IN G OF THE GRADIENT)
+C AND IV(S) (THE FIRST SUBSCRIPT IN V OF THE S LOWER TRIANGLE OF
+C THE S MATRIX) WILL HAVE BEEN SET (UNLESS LIV OR LV IS TOO SMALL),
+C AND IV(1) WILL HAVE BEEN SET TO 14. CALLING DRN2G WITH IV(1) = 14
+C CAUSES EXECUTION OF THE ALGORITHM TO BEGIN UNDER THE ASSUMPTION
+C THAT STORAGE HAS BEEN ALLOCATED.
+C
+C *** SUPPLYING R AND DR ***
+C
+C DRN2G USES IV AND V IN THE SAME WAY AS NL2SOL, WITH A SMALL
+C NUMBER OF OBVIOUS CHANGES. ONE DIFFERENCE BETWEEN DRN2G AND
+C NL2ITR IS THAT INITIAL FUNCTION AND GRADIENT INFORMATION NEED NOT
+C BE SUPPLIED IN THE VERY FIRST CALL ON DRN2G, THE ONE WITH
+C IV(1) = 0 OR 12. ANOTHER DIFFERENCE IS THAT DRN2G RETURNS WITH
+C IV(1) = -2 WHEN IT WANTS ANOTHER LOOK AT THE OLD JACOBIAN MATRIX
+C AND THE CURRENT RESIDUAL -- THE ONE CORRESPONDING TO X AND
+C IV(NFGCAL). IT THEN RETURNS WITH IV(1) = -3 WHEN IT WANTS TO SEE
+C BOTH THE NEW RESIDUAL AND THE NEW JACOBIAN MATRIX AT ONCE. NOTE
+C THAT IV(NFGCAL) = IV(7) CONTAINS THE VALUE THAT IV(NFCALL) = IV(6)
+C HAD WHEN THE CURRENT RESIDUAL WAS EVALUATED. ALSO NOTE THAT THE
+C VALUE OF X CORRESPONDING TO THE OLD JACOBIAN MATRIX IS STORED IN
+C V, STARTING AT V(IV(X0)) = V(IV(43)).
+C ANOTHER NEW RETURN... DRN2G IV(1) = -1 WHEN IT WANTS BOTH THE
+C RESIDUAL AND THE JACOBIAN TO BE EVALUATED AT X.
+C A NEW RESIDUAL VECTOR MUST BE SUPPLIED WHEN DRN2G RETURNS WITH
+C IV(1) = 1 OR -1. THIS TAKES THE FORM OF VALUES OF R(I,X) PASSED
+C IN R(I-N1+1), I = N1(1)N2. YOU MAY PASS ALL THESE VALUES AT ONCE
+C (I.E., N1 = 1 AND N2 = N) OR IN PIECES BY MAKING SEVERAL CALLS ON
+C DRN2G. EACH TIME DRN2G RETURNS WITH IV(1) = 1, N1 WILL HAVE
+C BEEN SET TO THE INDEX OF THE NEXT RESIDUAL THAT DRN2G EXPECTS TO
+C SEE, AND N2 WILL BE SET TO THE INDEX OF THE HIGHEST RESIDUAL THAT
+C COULD BE GIVEN ON THE NEXT CALL, I.E., N2 = N1 + ND - 1. (THUS
+C WHEN DRN2G FIRST RETURNS WITH IV(1) = 1 FOR A NEW X, IT WILL
+C HAVE SET N1 TO 1 AND N2 TO MIN(ND,N).) THE CALLER MAY PROVIDE
+C FEWER THAN N2-N1+1 RESIDUALS ON THE NEXT CALL BY SETTING N2 TO
+C A SMALLER VALUE. DRN2G ASSUMES IT HAS SEEN ALL THE RESIDUALS
+C FOR THE CURRENT X WHEN IT IS CALLED WITH N2 .GE. N.
+C EXAMPLE... SUPPOSE N = 80 AND THAT R IS TO BE PASSED IN 8
+C BLOCKS OF SIZE 10. THE FOLLOWING CODE WOULD DO THE JOB.
+C
+C N = 80
+C ND = 10
+C ...
+C DO 10 K = 1, 8
+C *** COMPUTE R(I,X) FOR I = 10*K-9 TO 10*K ***
+C *** AND STORE THEM IN R(1),...,R(10) ***
+C CALL DRN2G(..., R, ...)
+C 10 CONTINUE
+C
+C THE SITUATION IS SIMILAR WHEN GRADIENT INFORMATION IS
+C REQUIRED, I.E., WHEN DRN2G RETURNS WITH IV(1) = 2, -1, OR -2.
+C NOTE THAT DRN2G OVERWRITES R, BUT THAT IN THE SPECIAL CASE OF
+C N1 = 1 AND N2 = N ON PREVIOUS CALLS, DRN2G NEVER RETURNS WITH
+C IV(1) = -2. IT SHOULD BE CLEAR THAT THE PARTIAL DERIVATIVE OF
+C R(I,X) WITH RESPECT TO X(L) IS TO BE STORED IN DR(I-N1+1,L),
+C L = 1(1)P, I = N1(1)N2. IT IS ESSENTIAL THAT R(I) AND DR(I,L)
+C ALL CORRESPOND TO THE SAME RESIDUALS WHEN IV(1) = -1 OR -2.
+C
+C *** COVARIANCE MATRIX ***
+C
+C IV(RDREQ) = IV(57) TELLS WHETHER TO COMPUTE A COVARIANCE
+C MATRIX AND/OR REGRESSION DIAGNOSTICS... 0 MEANS NEITHER,
+C 1 MEANS COVARIANCE MATRIX ONLY, 2 MEANS REG. DIAGNOSTICS ONLY,
+C 3 MEANS BOTH. AS WITH NL2SOL, IV(COVREQ) = IV(15) TELLS WHAT
+C HESSIAN APPROXIMATION TO USE IN THIS COMPUTING.
+C
+C *** REGRESSION DIAGNOSTICS ***
+C
+C SEE THE COMMENTS IN SUBROUTINE DN2G.
+C
+C *** GENERAL ***
+C
+C CODED BY DAVID M. GAY.
+C
+C+++++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++
+C
+C *** INTRINSIC FUNCTIONS ***
+C/+
+ INTEGER IABS, MOD
+C/
+C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
+C
+ DOUBLE PRECISION DD7TPR, DV2NRM
+ EXTERNAL DC7VFN,DIVSET, DD7TPR,DD7UPD,DG7LIT,DITSUM,DL7VML,
+ 1 DN2CVP, DN2LRD, DQ7APL,DQ7RAD,DV7CPY, DV7SCP, DV2NRM
+C
+C DC7VFN... FINISHES COVARIANCE COMPUTATION.
+C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
+C DD7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS.
+C DD7UPD... UPDATES SCALE VECTOR D.
+C DG7LIT.... PERFORMS BASIC MINIMIZATION ALGORITHM.
+C DITSUM.... PRINTS ITERATION SUMMARY, INFO ABOUT INITIAL AND FINAL X.
+C DL7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
+C DN2CVP... PRINTS COVARIANCE MATRIX.
+C DN2LRD... COMPUTES REGRESSION DIAGNOSTICS.
+C DQ7APL... APPLIES QR TRANSFORMATIONS STORED BY DQ7RAD.
+C DQ7RAD.... ADDS A NEW BLOCK OF ROWS TO QR DECOMPOSITION.
+C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
+C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER G1, GI, I, IV1, IVMODE, JTOL1, K, L, LH, NN, QTR1,
+ 1 RMAT1, YI, Y1
+ DOUBLE PRECISION T
+C
+ DOUBLE PRECISION HALF, ZERO
+C
+C *** SUBSCRIPTS FOR IV AND V ***
+C
+ INTEGER CNVCOD, COVMAT, COVREQ, DINIT, DTYPE, DTINIT, D0INIT, F,
+ 1 FDH, G, H, IPIVOT, IVNEED, JCN, JTOL, LMAT, MODE,
+ 2 NEXTIV, NEXTV, NF0, NF00, NF1, NFCALL, NFCOV, NFGCAL,
+ 3 NGCALL, NGCOV, QTR, RDREQ, REGD, RESTOR, RLIMIT, RMAT,
+ 4 TOOBIG, VNEED, Y
+C
+ PARAMETER (HALF=0.5D+0, ZERO=0.D+0)
+C
+C *** IV SUBSCRIPT VALUES ***
+C
+ PARAMETER (CNVCOD=55, COVMAT=26, COVREQ=15, DTYPE=16, FDH=74,
+ 1 G=28, H=56, IPIVOT=76, IVNEED=3, JCN=66, JTOL=59,
+ 2 LMAT=42, MODE=35, NEXTIV=46, NEXTV=47, NFCALL=6,
+ 3 NFCOV=52, NF0=68, NF00=81, NF1=69, NFGCAL=7, NGCALL=30,
+ 4 NGCOV=53, QTR=77, RESTOR=9, RMAT=78, RDREQ=57, REGD=67,
+ 5 TOOBIG=2, VNEED=4, Y=48)
+C
+C *** V SUBSCRIPT VALUES ***
+C
+ PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RLIMIT=46)
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ LH = P * (P+1) / 2
+ IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
+ IV1 = IV(1)
+ IF (IV1 .GT. 2) GO TO 10
+ NN = N2 - N1 + 1
+ IV(RESTOR) = 0
+ I = IV1 + 4
+ IF (IV(TOOBIG) .EQ. 0) GO TO (150, 130, 150, 120, 120, 150), I
+ IF (I .NE. 5) IV(1) = 2
+ GO TO 40
+C
+C *** FRESH START OR RESTART -- CHECK INPUT INTEGERS ***
+C
+ 10 IF (ND .LE. 0) GO TO 210
+ IF (P .LE. 0) GO TO 210
+ IF (N .LE. 0) GO TO 210
+ IF (IV1 .EQ. 14) GO TO 30
+ IF (IV1 .GT. 16) GO TO 300
+ IF (IV1 .LT. 12) GO TO 40
+ IF (IV1 .EQ. 12) IV(1) = 13
+ IF (IV(1) .NE. 13) GO TO 20
+ IV(IVNEED) = IV(IVNEED) + P
+ IV(VNEED) = IV(VNEED) + P*(P+13)/2
+ 20 CALL DG7LIT(D, X, IV, LIV, LV, P, P, V, X, X)
+ IF (IV(1) .NE. 14) GO TO 999
+C
+C *** STORAGE ALLOCATION ***
+C
+ IV(IPIVOT) = IV(NEXTIV)
+ IV(NEXTIV) = IV(IPIVOT) + P
+ IV(Y) = IV(NEXTV)
+ IV(G) = IV(Y) + P
+ IV(JCN) = IV(G) + P
+ IV(RMAT) = IV(JCN) + P
+ IV(QTR) = IV(RMAT) + LH
+ IV(JTOL) = IV(QTR) + P
+ IV(NEXTV) = IV(JTOL) + 2*P
+ IF (IV1 .EQ. 13) GO TO 999
+C
+ 30 JTOL1 = IV(JTOL)
+ IF (V(DINIT) .GE. ZERO) CALL DV7SCP(P, D, V(DINIT))
+ IF (V(DTINIT) .GT. ZERO) CALL DV7SCP(P, V(JTOL1), V(DTINIT))
+ I = JTOL1 + P
+ IF (V(D0INIT) .GT. ZERO) CALL DV7SCP(P, V(I), V(D0INIT))
+ IV(NF0) = 0
+ IV(NF1) = 0
+ IF (ND .GE. N) GO TO 40
+C
+C *** SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT EVALUATION
+C *** -- ASK FOR BOTH RESIDUAL AND JACOBIAN AT ONCE
+C
+ G1 = IV(G)
+ Y1 = IV(Y)
+ CALL DG7LIT(D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
+ IF (IV(1) .NE. 1) GO TO 220
+ V(F) = ZERO
+ CALL DV7SCP(P, V(G1), ZERO)
+ IV(1) = -1
+ QTR1 = IV(QTR)
+ CALL DV7SCP(P, V(QTR1), ZERO)
+ IV(REGD) = 0
+ RMAT1 = IV(RMAT)
+ GO TO 100
+C
+ 40 G1 = IV(G)
+ Y1 = IV(Y)
+ CALL DG7LIT(D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
+ IF (IV(1) .EQ. 2) GO TO 60
+ IF (IV(1) .GT. 2) GO TO 220
+C
+ V(F) = ZERO
+ IF (IV(NF1) .EQ. 0) GO TO 260
+ IF (IV(RESTOR) .NE. 2) GO TO 260
+ IV(NF0) = IV(NF1)
+ CALL DV7CPY(N, RD, R)
+ IV(REGD) = 0
+ GO TO 260
+C
+ 60 CALL DV7SCP(P, V(G1), ZERO)
+ IF (IV(MODE) .GT. 0) GO TO 230
+ RMAT1 = IV(RMAT)
+ QTR1 = IV(QTR)
+ CALL DV7SCP(P, V(QTR1), ZERO)
+ IV(REGD) = 0
+ IF (ND .LT. N) GO TO 90
+ IF (N1 .NE. 1) GO TO 90
+ IF (IV(MODE) .LT. 0) GO TO 100
+ IF (IV(NF1) .EQ. IV(NFGCAL)) GO TO 70
+ IF (IV(NF0) .NE. IV(NFGCAL)) GO TO 90
+ CALL DV7CPY(N, R, RD)
+ GO TO 80
+ 70 CALL DV7CPY(N, RD, R)
+ 80 CALL DQ7APL(ND, N, P, DR, RD, 0)
+ CALL DL7VML(P, V(Y1), V(RMAT1), RD)
+ GO TO 110
+C
+ 90 IV(1) = -2
+ IF (IV(MODE) .LT. 0) IV(1) = -1
+ 100 CALL DV7SCP(P, V(Y1), ZERO)
+ 110 CALL DV7SCP(LH, V(RMAT1), ZERO)
+ GO TO 260
+C
+C *** COMPUTE F(X) ***
+C
+ 120 T = DV2NRM(NN, R)
+ IF (T .GT. V(RLIMIT)) GO TO 200
+ V(F) = V(F) + HALF * T**2
+ IF (N2 .LT. N) GO TO 270
+ IF (N1 .EQ. 1) IV(NF1) = IV(NFCALL)
+ GO TO 40
+C
+C *** COMPUTE Y ***
+C
+ 130 Y1 = IV(Y)
+ YI = Y1
+ DO 140 L = 1, P
+ V(YI) = V(YI) + DD7TPR(NN, DR(1,L), R)
+ YI = YI + 1
+ 140 CONTINUE
+ IF (N2 .LT. N) GO TO 270
+ IV(1) = 2
+ IF (N1 .GT. 1) IV(1) = -3
+ GO TO 260
+C
+C *** COMPUTE GRADIENT INFORMATION ***
+C
+ 150 IF (IV(MODE) .GT. P) GO TO 240
+ G1 = IV(G)
+ IVMODE = IV(MODE)
+ IF (IVMODE .LT. 0) GO TO 170
+ IF (IVMODE .EQ. 0) GO TO 180
+ IV(1) = 2
+C
+C *** COMPUTE GRADIENT ONLY (FOR USE IN COVARIANCE COMPUTATION) ***
+C
+ GI = G1
+ DO 160 L = 1, P
+ V(GI) = V(GI) + DD7TPR(NN, R, DR(1,L))
+ GI = GI + 1
+ 160 CONTINUE
+ GO TO 190
+C
+C *** COMPUTE INITIAL FUNCTION VALUE WHEN ND .LT. N ***
+C
+ 170 IF (N .LE. ND) GO TO 180
+ T = DV2NRM(NN, R)
+ IF (T .GT. V(RLIMIT)) GO TO 200
+ V(F) = V(F) + HALF * T**2
+C
+C *** UPDATE D IF DESIRED ***
+C
+ 180 IF (IV(DTYPE) .GT. 0)
+ 1 CALL DD7UPD(D, DR, IV, LIV, LV, N, ND, NN, N2, P, V)
+C
+C *** COMPUTE RMAT AND QTR ***
+C
+ QTR1 = IV(QTR)
+ RMAT1 = IV(RMAT)
+ CALL DQ7RAD(NN, ND, P, V(QTR1), .TRUE., V(RMAT1), DR, R)
+ IV(NF1) = 0
+C
+ 190 IF (N2 .LT. N) GO TO 270
+ IF (IVMODE .GT. 0) GO TO 40
+ IV(NF00) = IV(NFGCAL)
+C
+C *** COMPUTE G FROM RMAT AND QTR ***
+C
+ CALL DL7VML(P, V(G1), V(RMAT1), V(QTR1))
+ IV(1) = 2
+ IF (IVMODE .EQ. 0) GO TO 40
+ IF (N .LE. ND) GO TO 40
+C
+C *** FINISH SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT
+C
+ Y1 = IV(Y)
+ IV(1) = 1
+ CALL DG7LIT(D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
+ IF (IV(1) .NE. 2) GO TO 220
+ GO TO 40
+C
+C *** MISC. DETAILS ***
+C
+C *** X IS OUT OF RANGE (OVERSIZE STEP) ***
+C
+ 200 IV(TOOBIG) = 1
+ GO TO 40
+C
+C *** BAD N, ND, OR P ***
+C
+ 210 IV(1) = 66
+ GO TO 300
+C
+C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE ***
+C
+ 220 IF (IV(COVMAT) .NE. 0) GO TO 290
+ IF (IV(REGD) .NE. 0) GO TO 290
+C
+C *** SEE IF CHOLESKY FACTOR OF HESSIAN IS AVAILABLE ***
+C
+ K = IV(FDH)
+ IF (K .LE. 0) GO TO 280
+ IF (IV(RDREQ) .LE. 0) GO TO 290
+C
+C *** COMPUTE REGRESSION DIAGNOSTICS AND DEFAULT COVARIANCE IF
+C DESIRED ***
+C
+ I = 0
+ IF (MOD(IV(RDREQ),4) .GE. 2) I = 1
+ IF (MOD(IV(RDREQ),2) .EQ. 1 .AND. IABS(IV(COVREQ)) .LE. 1) I = I+2
+ IF (I .EQ. 0) GO TO 250
+ IV(MODE) = P + I
+ IV(NGCALL) = IV(NGCALL) + 1
+ IV(NGCOV) = IV(NGCOV) + 1
+ IV(CNVCOD) = IV(1)
+ IF (I .LT. 2) GO TO 230
+ L = IABS(IV(H))
+ CALL DV7SCP(LH, V(L), ZERO)
+ 230 IV(NFCOV) = IV(NFCOV) + 1
+ IV(NFCALL) = IV(NFCALL) + 1
+ IV(NFGCAL) = IV(NFCALL)
+ IV(1) = -1
+ GO TO 260
+C
+ 240 L = IV(LMAT)
+ CALL DN2LRD(DR, IV, V(L), LH, LIV, LV, ND, NN, P, R, RD, V)
+ IF (N2 .LT. N) GO TO 270
+ IF (N1 .GT. 1) GO TO 250
+C
+C *** ENSURE WE CAN RESTART -- AND MAKE RETURN STATE OF DR
+C *** INDEPENDENT OF WHETHER REGRESSION DIAGNOSTICS ARE COMPUTED.
+C *** USE STEP VECTOR (ALLOCATED BY DG7LIT) FOR SCRATCH.
+C
+ RMAT1 = IV(RMAT)
+ CALL DV7SCP(LH, V(RMAT1), ZERO)
+ CALL DQ7RAD(NN, ND, P, R, .FALSE., V(RMAT1), DR, R)
+ IV(NF1) = 0
+C
+C *** FINISH COMPUTING COVARIANCE ***
+C
+ 250 L = IV(LMAT)
+ CALL DC7VFN(IV, V(L), LH, LIV, LV, N, P, V)
+ GO TO 290
+C
+C *** RETURN FOR MORE FUNCTION OR GRADIENT INFORMATION ***
+C
+ 260 N2 = 0
+ 270 N1 = N2 + 1
+ N2 = N2 + ND
+ IF (N2 .GT. N) N2 = N
+ GO TO 999
+C
+C *** COME HERE FOR INDEFINITE FINITE-DIFFERENCE HESSIAN ***
+C
+ 280 IV(COVMAT) = K
+ IV(REGD) = K
+C
+C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
+C
+ 290 G1 = IV(G)
+ 300 CALL DITSUM(D, V(G1), IV, LIV, LV, P, V, X)
+ IF (IV(1) .LE. 6 .AND. IV(RDREQ) .GT. 0)
+ 1 CALL DN2CVP(IV, LIV, LV, P, V)
+C
+ 999 RETURN
+C *** LAST LINE OF DRN2G FOLLOWS ***
+ END
+ SUBROUTINE DL7SQR(N, A, L)
+C
+C *** COMPUTE A = LOWER TRIANGLE OF L*(L**T), WITH BOTH
+C *** L AND A STORED COMPACTLY BY ROWS. (BOTH MAY OCCUPY THE
+C *** SAME STORAGE.
+C
+C *** PARAMETERS ***
+C
+ INTEGER N
+ DOUBLE PRECISION A(*), L(*)
+C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2)
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER I, II, IJ, IK, IP1, I0, J, JJ, JK, J0, K, NP1
+ DOUBLE PRECISION T
+C
+ NP1 = N + 1
+ I0 = N*(N+1)/2
+ DO 30 II = 1, N
+ I = NP1 - II
+ IP1 = I + 1
+ I0 = I0 - I
+ J0 = I*(I+1)/2
+ DO 20 JJ = 1, I
+ J = IP1 - JJ
+ J0 = J0 - J
+ T = 0.0D0
+ DO 10 K = 1, J
+ IK = I0 + K
+ JK = J0 + K
+ T = T + L(IK)*L(JK)
+ 10 CONTINUE
+ IJ = I0 + J
+ A(IJ) = T
+ 20 CONTINUE
+ 30 CONTINUE
+ RETURN
+ END
+ SUBROUTINE DRMNHB(B, D, FX, G, H, IV, LH, LIV, LV, N, V, X)
+C
+C *** CARRY OUT DMNHB (SIMPLY BOUNDED MINIMIZATION) ITERATIONS,
+C *** USING HESSIAN MATRIX PROVIDED BY THE CALLER.
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER LH, LIV, LV, N
+ INTEGER IV(LIV)
+ DOUBLE PRECISION B(2,N), D(N), FX, G(N), H(LH), V(LV), X(N)
+C
+C-------------------------- PARAMETER USAGE --------------------------
+C
+C D.... SCALE VECTOR.
+C FX... FUNCTION VALUE.
+C G.... GRADIENT VECTOR.
+C H.... LOWER TRIANGLE OF THE HESSIAN, STORED ROWWISE.
+C IV... INTEGER VALUE ARRAY.
+C LH... LENGTH OF H = P*(P+1)/2.
+C LIV.. LENGTH OF IV (AT LEAST 59 + 3*N).
+C LV... LENGTH OF V (AT LEAST 78 + N*(N+27)/2).
+C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G).
+C V.... FLOATING-POINT VALUE ARRAY.
+C X.... PARAMETER VECTOR.
+C
+C *** DISCUSSION ***
+C
+C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING
+C ONES TO DMNHB (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE
+C THE PART OF V THAT DMNHB USES FOR STORING G AND H IS NOT NEEDED).
+C MOREOVER, COMPARED WITH DMNHB, IV(1) MAY HAVE THE TWO ADDITIONAL
+C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE
+C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN
+C OUTPUT VALUE FROM DMNHB, IS NOT REFERENCED BY DRMNHB OR THE
+C SUBROUTINES IT CALLS.
+C
+C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE
+C AT X, AND CALL DRMNHB AGAIN, HAVING CHANGED NONE OF THE
+C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE
+C COMPUTED (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN
+C BECAUSE OF AN OVERSIZED STEP. IN THIS CASE THE CALLER
+C SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE
+C DRMNHB TO IGNORE FX AND TRY A SMALLER STEP. THE PARA-
+C METER NF THAT DMNH PASSES TO CALCF (FOR POSSIBLE USE BY
+C CALCGH) IS A COPY OF IV(NFCALL) = IV(6).
+C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT
+C X, AND H TO THE LOWER TRIANGLE OF H(X), THE HESSIAN OF F
+C AT X, AND CALL DRMNHB AGAIN, HAVING CHANGED NONE OF THE
+C OTHER PARAMETERS EXCEPT PERHAPS THE SCALE VECTOR D.
+C THE PARAMETER NF THAT DMNHB PASSES TO CALCG IS
+C IV(NFGCAL) = IV(7). IF G(X) AND H(X) CANNOT BE EVALUATED,
+C THEN THE CALLER MAY SET IV(NFGCAL) TO 0, IN WHICH CASE
+C DRMNHB WILL RETURN WITH IV(1) = 65.
+C NOTE -- DRMNHB OVERWRITES H WITH THE LOWER TRIANGLE
+C OF DIAG(D)**-1 * H(X) * DIAG(D)**-1.
+C.
+C *** GENERAL ***
+C
+C CODED BY DAVID M. GAY (WINTER, SPRING 1983).
+C
+C (SEE DMNG AND DMNH FOR REFERENCES.)
+C
+C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER DG1, DUMMY, I, IPI, IPIV2, IPN, J, K, L, LSTGST, NN1O2,
+ 1 RSTRST, STEP0, STEP1, TD1, TEMP0, TEMP1, TG1, W1, X01, X11
+ DOUBLE PRECISION GI, T, XI
+C
+C *** CONSTANTS ***
+C
+ DOUBLE PRECISION NEGONE, ONE, ONEP2, ZERO
+C
+C *** NO INTRINSIC FUNCTIONS ***
+C
+C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
+C
+ LOGICAL STOPX
+ DOUBLE PRECISION DD7TPR, DRLDST, DV2NRM
+ EXTERNAL DA7SST,DIVSET, DD7TPR,DD7DUP, DG7QSB, I7PNVR,DITSUM,
+ 1 DPARCK, DRLDST, DS7IPR, DS7LVM, STOPX, DV2NRM,DV2AXY,
+ 2 DV7CPY, DV7IPR, DV7SCP, DV7VMP
+C
+C DA7SST.... ASSESSES CANDIDATE STEP.
+C DIVSET.... PROVIDES DEFAULT IV AND V INPUT VALUES.
+C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
+C DD7DUP.... UPDATES SCALE VECTOR D.
+C DG7QSB... COMPUTES APPROXIMATE OPTIMAL BOUNDED STEP.
+C I7PNVR... INVERTS PERMUTATION ARRAY.
+C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
+C DPARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES.
+C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
+C DS7IPR... APPLIES PERMUTATION TO LOWER TRIANG. OF SYM. MATRIX.
+C DS7LVM... MULTIPLIES SYMMETRIC MATRIX TIMES VECTOR, GIVEN THE LOWER
+C TRIANGLE OF THE MATRIX.
+C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
+C DV2NRM... RETURNS THE 2-NORM OF A VECTOR.
+C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
+C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
+C DV7IPR... APPLIES PERMUTATION TO VECTOR.
+C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
+C DV7VMP... MULTIPLIES (OR DIVIDES) TWO VECTORS COMPONENTWISE.
+C
+C *** SUBSCRIPTS FOR IV AND V ***
+C
+ INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, DTINIT, DTOL, DTYPE,
+ 1 D0INIT, F, F0, FDIF, GTSTEP, INCFAC, IVNEED, IRC, KAGQT,
+ 2 LMAT, LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, N0, NC,
+ 3 NEXTIV, NEXTV, NFCALL, NFGCAL, NGCALL, NITER, PERM,
+ 4 PHMXFC, PREDUC, RADFAC, RADINC, RADIUS, RAD0, RELDX,
+ 5 RESTOR, STEP, STGLIM, STPPAR, TOOBIG, TUNER4, TUNER5,
+ 6 VNEED, W, XIRC, X0
+C
+C *** IV SUBSCRIPT VALUES ***
+C
+C *** (NOTE THAT NC AND N0 ARE STORED IN IV(G0) AND IV(STLSTG) RESP.)
+C
+ PARAMETER (CNVCOD=55, DG=37, DTOL=59, DTYPE=16, IRC=29, IVNEED=3,
+ 1 KAGQT=33, LMAT=42, MODE=35, MODEL=5, MXFCAL=17,
+ 2 MXITER=18, N0=41, NC=48, NEXTIV=46, NEXTV=47, NFCALL=6,
+ 3 NFGCAL=7, NGCALL=30, NITER=31, PERM=58, RADINC=8,
+ 4 RESTOR=9, STEP=40, STGLIM=11, TOOBIG=2, VNEED=4, W=34,
+ 5 XIRC=13, X0=43)
+C
+C *** V SUBSCRIPT VALUES ***
+C
+ PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, DTINIT=39, D0INIT=40,
+ 1 F=10, F0=13, FDIF=11, GTSTEP=4, INCFAC=23, LMAX0=35,
+ 2 LMAXS=36, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8,
+ 3 RAD0=9, RELDX=17, STPPAR=5, TUNER4=29, TUNER5=30)
+C
+ PARAMETER (NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0, ZERO=0.D+0)
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ I = IV(1)
+ IF (I .EQ. 1) GO TO 50
+ IF (I .EQ. 2) GO TO 60
+C
+C *** CHECK VALIDITY OF IV AND V INPUT VALUES ***
+C
+ IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
+ IF (IV(1) .LT. 12) GO TO 10
+ IF (IV(1) .GT. 13) GO TO 10
+ IV(VNEED) = IV(VNEED) + N*(N+27)/2 + 7
+ IV(IVNEED) = IV(IVNEED) + 3*N
+ 10 CALL DPARCK(2, D, IV, LIV, LV, N, V)
+ I = IV(1) - 2
+ IF (I .GT. 12) GO TO 999
+ NN1O2 = N * (N + 1) / 2
+ IF (LH .GE. NN1O2) GO TO (250,250,250,250,250,250,190,150,190,
+ 1 20,20,30), I
+ IV(1) = 81
+ GO TO 440
+C
+C *** STORAGE ALLOCATION ***
+C
+ 20 IV(DTOL) = IV(LMAT) + NN1O2
+ IV(X0) = IV(DTOL) + 2*N
+ IV(STEP) = IV(X0) + 2*N
+ IV(DG) = IV(STEP) + 3*N
+ IV(W) = IV(DG) + 2*N
+ IV(NEXTV) = IV(W) + 4*N + 7
+ IV(NEXTIV) = IV(PERM) + 3*N
+ IF (IV(1) .NE. 13) GO TO 30
+ IV(1) = 14
+ GO TO 999
+C
+C *** INITIALIZATION ***
+C
+ 30 IV(NITER) = 0
+ IV(NFCALL) = 1
+ IV(NGCALL) = 1
+ IV(NFGCAL) = 1
+ IV(MODE) = -1
+ IV(MODEL) = 1
+ IV(STGLIM) = 1
+ IV(TOOBIG) = 0
+ IV(CNVCOD) = 0
+ IV(RADINC) = 0
+ IV(NC) = N
+ V(RAD0) = ZERO
+ V(STPPAR) = ZERO
+ IF (V(DINIT) .GE. ZERO) CALL DV7SCP(N, D, V(DINIT))
+ K = IV(DTOL)
+ IF (V(DTINIT) .GT. ZERO) CALL DV7SCP(N, V(K), V(DTINIT))
+ K = K + N
+ IF (V(D0INIT) .GT. ZERO) CALL DV7SCP(N, V(K), V(D0INIT))
+C
+C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY ***
+C
+ IPI = IV(PERM)
+ DO 40 I = 1, N
+ IV(IPI) = I
+ IPI = IPI + 1
+ IF (B(1,I) .GT. B(2,I)) GO TO 420
+ 40 CONTINUE
+C
+C *** GET INITIAL FUNCTION VALUE ***
+C
+ IV(1) = 1
+ GO TO 450
+C
+ 50 V(F) = FX
+ IF (IV(MODE) .GE. 0) GO TO 250
+ V(F0) = FX
+ IV(1) = 2
+ IF (IV(TOOBIG) .EQ. 0) GO TO 999
+ IV(1) = 63
+ GO TO 440
+C
+C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
+C
+ 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70
+ IV(1) = 65
+ GO TO 440
+C
+C *** UPDATE THE SCALE VECTOR D ***
+C
+ 70 DG1 = IV(DG)
+ IF (IV(DTYPE) .LE. 0) GO TO 90
+ K = DG1
+ J = 0
+ DO 80 I = 1, N
+ J = J + I
+ V(K) = H(J)
+ K = K + 1
+ 80 CONTINUE
+ CALL DD7DUP(D, V(DG1), IV, LIV, LV, N, V)
+C
+C *** COMPUTE SCALED GRADIENT AND ITS NORM ***
+C
+ 90 DG1 = IV(DG)
+ CALL DV7VMP(N, V(DG1), G, D, -1)
+C
+C *** COMPUTE SCALED HESSIAN ***
+C
+ K = 1
+ DO 110 I = 1, N
+ T = ONE / D(I)
+ DO 100 J = 1, I
+ H(K) = T * H(K) / D(J)
+ K = K + 1
+ 100 CONTINUE
+ 110 CONTINUE
+C
+C *** CHOOSE INITIAL PERMUTATION ***
+C
+ IPI = IV(PERM)
+ IPN = IPI + N
+ IPIV2 = IPN - 1
+C *** INVERT OLD PERMUTATION ARRAY ***
+ CALL I7PNVR(N, IV(IPN), IV(IPI))
+ K = IV(NC)
+ DO 130 I = 1, N
+ IF (B(1,I) .GE. B(2,I)) GO TO 120
+ XI = X(I)
+ GI = G(I)
+ IF (XI .LE. B(1,I) .AND. GI .GT. ZERO) GO TO 120
+ IF (XI .GE. B(2,I) .AND. GI .LT. ZERO) GO TO 120
+ IV(IPI) = I
+ IPI = IPI + 1
+ J = IPIV2 + I
+C *** DISALLOW CONVERGENCE IF X(I) HAS JUST BEEN FREED ***
+ IF (IV(J) .GT. K) IV(CNVCOD) = 0
+ GO TO 130
+ 120 IPN = IPN - 1
+ IV(IPN) = I
+ 130 CONTINUE
+ IV(NC) = IPN - IV(PERM)
+C
+C *** PERMUTE SCALED GRADIENT AND HESSIAN ACCORDINGLY ***
+C
+ IPI = IV(PERM)
+ CALL DS7IPR(N, IV(IPI), H)
+ CALL DV7IPR(N, IV(IPI), V(DG1))
+ V(DGNORM) = ZERO
+ IF (IV(NC) .GT. 0) V(DGNORM) = DV2NRM(IV(NC), V(DG1))
+C
+ IF (IV(CNVCOD) .NE. 0) GO TO 430
+ IF (IV(MODE) .EQ. 0) GO TO 380
+C
+C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) ***
+C
+ V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC))
+C
+ IV(MODE) = 0
+C
+C
+C----------------------------- MAIN LOOP -----------------------------
+C
+C
+C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
+C
+ 140 CALL DITSUM(D, G, IV, LIV, LV, N, V, X)
+ 150 K = IV(NITER)
+ IF (K .LT. IV(MXITER)) GO TO 160
+ IV(1) = 10
+ GO TO 440
+C
+ 160 IV(NITER) = K + 1
+C
+C *** INITIALIZE FOR START OF NEXT ITERATION ***
+C
+ X01 = IV(X0)
+ V(F0) = V(F)
+ IV(IRC) = 4
+ IV(KAGQT) = -1
+C
+C *** COPY X TO X0 ***
+C
+ CALL DV7CPY(N, V(X01), X)
+C
+C *** UPDATE RADIUS ***
+C
+ IF (K .EQ. 0) GO TO 180
+ STEP1 = IV(STEP)
+ K = STEP1
+ DO 170 I = 1, N
+ V(K) = D(I) * V(K)
+ K = K + 1
+ 170 CONTINUE
+ T = V(RADFAC) * DV2NRM(N, V(STEP1))
+ IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T
+C
+C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
+C
+ 180 IF (.NOT. STOPX(DUMMY)) GO TO 200
+ IV(1) = 11
+ GO TO 210
+C
+C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
+C
+ 190 IF (V(F) .GE. V(F0)) GO TO 200
+ V(RADFAC) = ONE
+ K = IV(NITER)
+ GO TO 160
+C
+ 200 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 220
+ IV(1) = 9
+ 210 IF (V(F) .GE. V(F0)) GO TO 440
+C
+C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
+C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
+C
+ IV(CNVCOD) = IV(1)
+ GO TO 370
+C
+C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
+C
+ 220 STEP1 = IV(STEP)
+ L = IV(LMAT)
+ W1 = IV(W)
+ IPI = IV(PERM)
+ IPN = IPI + N
+ IPIV2 = IPN + N
+ TG1 = IV(DG)
+ TD1 = TG1 + N
+ X01 = IV(X0)
+ X11 = X01 + N
+ CALL DG7QSB(B, D, H, G, IV(IPI), IV(IPN), IV(IPIV2), IV(KAGQT),
+ 1 V(L), LV, N, IV(N0), IV(NC), V(STEP1), V(TD1), V(TG1),
+ 2 V, V(W1), V(X11), V(X01))
+ IF (IV(IRC) .NE. 6) GO TO 230
+ IF (IV(RESTOR) .NE. 2) GO TO 250
+ RSTRST = 2
+ GO TO 260
+C
+C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
+C
+ 230 IV(TOOBIG) = 0
+ IF (V(DSTNRM) .LE. ZERO) GO TO 250
+ IF (IV(IRC) .NE. 5) GO TO 240
+ IF (V(RADFAC) .LE. ONE) GO TO 240
+ IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 240
+ IF (IV(RESTOR) .NE. 2) GO TO 250
+ RSTRST = 0
+ GO TO 260
+C
+C *** COMPUTE F(X0 + STEP) ***
+C
+ 240 CALL DV2AXY(N, X, ONE, V(STEP1), V(X01))
+ IV(NFCALL) = IV(NFCALL) + 1
+ IV(1) = 1
+ GO TO 450
+C
+C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
+C
+ 250 RSTRST = 3
+ 260 X01 = IV(X0)
+ V(RELDX) = DRLDST(N, D, X, V(X01))
+ CALL DA7SST(IV, LIV, LV, V)
+ STEP1 = IV(STEP)
+ LSTGST = STEP1 + 2*N
+ I = IV(RESTOR) + 1
+ GO TO (300, 270, 280, 290), I
+ 270 CALL DV7CPY(N, X, V(X01))
+ GO TO 300
+ 280 CALL DV7CPY(N, V(LSTGST), X)
+ GO TO 300
+ 290 CALL DV7CPY(N, X, V(LSTGST))
+ CALL DV2AXY(N, V(STEP1), NEGONE, V(X01), X)
+ V(RELDX) = DRLDST(N, D, X, V(X01))
+ IV(RESTOR) = RSTRST
+C
+ 300 K = IV(IRC)
+ GO TO (310,340,340,340,310,320,330,330,330,330,330,330,410,380), K
+C
+C *** RECOMPUTE STEP WITH NEW RADIUS ***
+C
+ 310 V(RADIUS) = V(RADFAC) * V(DSTNRM)
+ GO TO 180
+C
+C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST.
+C
+ 320 V(RADIUS) = V(LMAXS)
+ GO TO 220
+C
+C *** CONVERGENCE OR FALSE CONVERGENCE ***
+C
+ 330 IV(CNVCOD) = K - 4
+ IF (V(F) .GE. V(F0)) GO TO 430
+ IF (IV(XIRC) .EQ. 14) GO TO 430
+ IV(XIRC) = 14
+C
+C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
+C
+ 340 IF (IV(IRC) .NE. 3) GO TO 370
+ TEMP1 = LSTGST
+C
+C *** PREPARE FOR GRADIENT TESTS ***
+C *** SET TEMP1 = HESSIAN * STEP + G(X0)
+C *** = DIAG(D) * (H * STEP + G(X0))
+C
+ K = TEMP1
+ STEP0 = STEP1 - 1
+ IPI = IV(PERM)
+ DO 350 I = 1, N
+ J = IV(IPI)
+ IPI = IPI + 1
+ STEP1 = STEP0 + J
+ V(K) = D(J) * V(STEP1)
+ K = K + 1
+ 350 CONTINUE
+C USE X0 VECTOR AS TEMPORARY.
+ CALL DS7LVM(N, V(X01), H, V(TEMP1))
+ TEMP0 = TEMP1 - 1
+ IPI = IV(PERM)
+ DO 360 I = 1, N
+ J = IV(IPI)
+ IPI = IPI + 1
+ TEMP1 = TEMP0 + J
+ V(TEMP1) = D(J) * V(X01) + G(J)
+ X01 = X01 + 1
+ 360 CONTINUE
+C
+C *** COMPUTE GRADIENT AND HESSIAN ***
+C
+ 370 IV(NGCALL) = IV(NGCALL) + 1
+ IV(TOOBIG) = 0
+ IV(1) = 2
+ GO TO 450
+C
+ 380 IV(1) = 2
+ IF (IV(IRC) .NE. 3) GO TO 140
+C
+C *** SET V(RADFAC) BY GRADIENT TESTS ***
+C
+ STEP1 = IV(STEP)
+C *** TEMP1 = STLSTG ***
+ TEMP1 = STEP1 + 2*N
+C
+C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) ***
+C
+ K = TEMP1
+ DO 390 I = 1, N
+ V(K) = (V(K) - G(I)) / D(I)
+ K = K + 1
+ 390 CONTINUE
+C
+C *** DO GRADIENT TESTS ***
+C
+ IF (DV2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 400
+ IF (DD7TPR(N, G, V(STEP1))
+ 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 140
+ 400 V(RADFAC) = V(INCFAC)
+ GO TO 140
+C
+C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
+C
+C *** BAD PARAMETERS TO ASSESS ***
+C
+ 410 IV(1) = 64
+ GO TO 440
+C
+C *** INCONSISTENT B ***
+C
+ 420 IV(1) = 82
+ GO TO 440
+C
+C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
+C
+ 430 IV(1) = IV(CNVCOD)
+ IV(CNVCOD) = 0
+ 440 CALL DITSUM(D, G, IV, LIV, LV, N, V, X)
+ GO TO 999
+C
+C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) ***
+C
+ 450 DO 460 I = 1, N
+ IF (X(I) .LT. B(1,I)) X(I) = B(1,I)
+ IF (X(I) .GT. B(2,I)) X(I) = B(2,I)
+ 460 CONTINUE
+C
+ 999 RETURN
+C
+C *** LAST CARD OF DRMNHB FOLLOWS ***
+ END
+ SUBROUTINE DRMNH(D, FX, G, H, IV, LH, LIV, LV, N, V, X)
+C
+C *** CARRY OUT DMNH (UNCONSTRAINED MINIMIZATION) ITERATIONS, USING
+C *** HESSIAN MATRIX PROVIDED BY THE CALLER.
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER LH, LIV, LV, N
+ INTEGER IV(LIV)
+ DOUBLE PRECISION D(N), FX, G(N), H(LH), V(LV), X(N)
+C
+C-------------------------- PARAMETER USAGE --------------------------
+C
+C D.... SCALE VECTOR.
+C FX... FUNCTION VALUE.
+C G.... GRADIENT VECTOR.
+C H.... LOWER TRIANGLE OF THE HESSIAN, STORED ROWWISE.
+C IV... INTEGER VALUE ARRAY.
+C LH... LENGTH OF H = P*(P+1)/2.
+C LIV.. LENGTH OF IV (AT LEAST 60).
+C LV... LENGTH OF V (AT LEAST 78 + N*(N+21)/2).
+C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G).
+C V.... FLOATING-POINT VALUE ARRAY.
+C X.... PARAMETER VECTOR.
+C
+C *** DISCUSSION ***
+C
+C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING
+C ONES TO DMNH (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE
+C THE PART OF V THAT DMNH USES FOR STORING G AND H IS NOT NEEDED).
+C MOREOVER, COMPARED WITH DMNH, IV(1) MAY HAVE THE TWO ADDITIONAL
+C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE
+C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN
+C OUTPUT VALUE FROM DMNH, IS NOT REFERENCED BY DRMNH OR THE
+C SUBROUTINES IT CALLS.
+C
+C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE
+C AT X, AND CALL DRMNH AGAIN, HAVING CHANGED NONE OF THE
+C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE
+C COMPUTED (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN
+C BECAUSE OF AN OVERSIZED STEP. IN THIS CASE THE CALLER
+C SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE
+C DRMNH TO IGNORE FX AND TRY A SMALLER STEP. THE PARA-
+C METER NF THAT DMNH PASSES TO CALCF (FOR POSSIBLE USE BY
+C CALCGH) IS A COPY OF IV(NFCALL) = IV(6).
+C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT
+C X, AND H TO THE LOWER TRIANGLE OF H(X), THE HESSIAN OF F
+C AT X, AND CALL DRMNH AGAIN, HAVING CHANGED NONE OF THE
+C OTHER PARAMETERS EXCEPT PERHAPS THE SCALE VECTOR D.
+C THE PARAMETER NF THAT DMNH PASSES TO CALCG IS
+C IV(NFGCAL) = IV(7). IF G(X) AND H(X) CANNOT BE EVALUATED,
+C THEN THE CALLER MAY SET IV(TOOBIG) TO 0, IN WHICH CASE
+C DRMNH WILL RETURN WITH IV(1) = 65.
+C NOTE -- DRMNH OVERWRITES H WITH THE LOWER TRIANGLE
+C OF DIAG(D)**-1 * H(X) * DIAG(D)**-1.
+C.
+C *** GENERAL ***
+C
+C CODED BY DAVID M. GAY (WINTER 1980). REVISED SEPT. 1982.
+C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
+C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
+C MCS-7600324 AND MCS-7906671.
+C
+C (SEE DMNG AND DMNH FOR REFERENCES.)
+C
+C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER DG1, DUMMY, I, J, K, L, LSTGST, NN1O2, RSTRST, STEP1,
+ 1 TEMP1, W1, X01
+ DOUBLE PRECISION T
+C
+C *** CONSTANTS ***
+C
+ DOUBLE PRECISION ONE, ONEP2, ZERO
+C
+C *** NO INTRINSIC FUNCTIONS ***
+C
+C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
+C
+ LOGICAL STOPX
+ DOUBLE PRECISION DD7TPR, DRLDST, DV2NRM
+ EXTERNAL DA7SST,DIVSET, DD7TPR,DD7DUP,DG7QTS,DITSUM,DPARCK,
+ 1 DRLDST, DS7LVM, STOPX,DV2AXY,DV7CPY, DV7SCP, DV2NRM
+C
+C DA7SST.... ASSESSES CANDIDATE STEP.
+C DIVSET.... PROVIDES DEFAULT IV AND V INPUT VALUES.
+C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
+C DD7DUP.... UPDATES SCALE VECTOR D.
+C DG7QTS.... COMPUTES OPTIMALLY LOCALLY CONSTRAINED STEP.
+C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
+C DPARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES.
+C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
+C DS7LVM... MULTIPLIES SYMMETRIC MATRIX TIMES VECTOR, GIVEN THE LOWER
+C TRIANGLE OF THE MATRIX.
+C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
+C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
+C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
+C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
+C DV2NRM... RETURNS THE 2-NORM OF A VECTOR.
+C
+C *** SUBSCRIPTS FOR IV AND V ***
+C
+ INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, DTINIT, DTOL,
+ 1 DTYPE, D0INIT, F, F0, FDIF, GTSTEP, INCFAC, IRC, KAGQT,
+ 2 LMAT, LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTV,
+ 3 NFCALL, NFGCAL, NGCALL, NITER, PHMXFC, PREDUC, RADFAC,
+ 4 RADINC, RADIUS, RAD0, RELDX, RESTOR, STEP, STGLIM, STLSTG,
+ 5 STPPAR, TOOBIG, TUNER4, TUNER5, VNEED, W, XIRC, X0
+C
+C *** IV SUBSCRIPT VALUES ***
+C
+ PARAMETER (CNVCOD=55, DG=37, DTOL=59, DTYPE=16, IRC=29, KAGQT=33,
+ 1 LMAT=42, MODE=35, MODEL=5, MXFCAL=17, MXITER=18,
+ 2 NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30, NITER=31,
+ 3 RADINC=8, RESTOR=9, STEP=40, STGLIM=11, STLSTG=41,
+ 4 TOOBIG=2, VNEED=4, W=34, XIRC=13, X0=43)
+C
+C *** V SUBSCRIPT VALUES ***
+C
+ PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, DTINIT=39, D0INIT=40,
+ 1 F=10, F0=13, FDIF=11, GTSTEP=4, INCFAC=23, LMAX0=35,
+ 2 LMAXS=36, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8,
+ 3 RAD0=9, RELDX=17, STPPAR=5, TUNER4=29, TUNER5=30)
+C
+ PARAMETER (ONE=1.D+0, ONEP2=1.2D+0, ZERO=0.D+0)
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ I = IV(1)
+ IF (I .EQ. 1) GO TO 30
+ IF (I .EQ. 2) GO TO 40
+C
+C *** CHECK VALIDITY OF IV AND V INPUT VALUES ***
+C
+ IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
+ IF (IV(1) .EQ. 12 .OR. IV(1) .EQ. 13)
+ 1 IV(VNEED) = IV(VNEED) + N*(N+21)/2 + 7
+ CALL DPARCK(2, D, IV, LIV, LV, N, V)
+ I = IV(1) - 2
+ IF (I .GT. 12) GO TO 999
+ NN1O2 = N * (N + 1) / 2
+ IF (LH .GE. NN1O2) GO TO (220,220,220,220,220,220,160,120,160,
+ 1 10,10,20), I
+ IV(1) = 66
+ GO TO 400
+C
+C *** STORAGE ALLOCATION ***
+C
+ 10 IV(DTOL) = IV(LMAT) + NN1O2
+ IV(X0) = IV(DTOL) + 2*N
+ IV(STEP) = IV(X0) + N
+ IV(STLSTG) = IV(STEP) + N
+ IV(DG) = IV(STLSTG) + N
+ IV(W) = IV(DG) + N
+ IV(NEXTV) = IV(W) + 4*N + 7
+ IF (IV(1) .NE. 13) GO TO 20
+ IV(1) = 14
+ GO TO 999
+C
+C *** INITIALIZATION ***
+C
+ 20 IV(NITER) = 0
+ IV(NFCALL) = 1
+ IV(NGCALL) = 1
+ IV(NFGCAL) = 1
+ IV(MODE) = -1
+ IV(MODEL) = 1
+ IV(STGLIM) = 1
+ IV(TOOBIG) = 0
+ IV(CNVCOD) = 0
+ IV(RADINC) = 0
+ V(RAD0) = ZERO
+ V(STPPAR) = ZERO
+ IF (V(DINIT) .GE. ZERO) CALL DV7SCP(N, D, V(DINIT))
+ K = IV(DTOL)
+ IF (V(DTINIT) .GT. ZERO) CALL DV7SCP(N, V(K), V(DTINIT))
+ K = K + N
+ IF (V(D0INIT) .GT. ZERO) CALL DV7SCP(N, V(K), V(D0INIT))
+ IV(1) = 1
+ GO TO 999
+C
+ 30 V(F) = FX
+ IF (IV(MODE) .GE. 0) GO TO 220
+ V(F0) = FX
+ IV(1) = 2
+ IF (IV(TOOBIG) .EQ. 0) GO TO 999
+ IV(1) = 63
+ GO TO 400
+C
+C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
+C
+ 40 IF (IV(TOOBIG) .EQ. 0) GO TO 50
+ IV(1) = 65
+ GO TO 400
+C
+C *** UPDATE THE SCALE VECTOR D ***
+C
+ 50 DG1 = IV(DG)
+ IF (IV(DTYPE) .LE. 0) GO TO 70
+ K = DG1
+ J = 0
+ DO 60 I = 1, N
+ J = J + I
+ V(K) = H(J)
+ K = K + 1
+ 60 CONTINUE
+ CALL DD7DUP(D, V(DG1), IV, LIV, LV, N, V)
+C
+C *** COMPUTE SCALED GRADIENT AND ITS NORM ***
+C
+ 70 DG1 = IV(DG)
+ K = DG1
+ DO 80 I = 1, N
+ V(K) = G(I) / D(I)
+ K = K + 1
+ 80 CONTINUE
+ V(DGNORM) = DV2NRM(N, V(DG1))
+C
+C *** COMPUTE SCALED HESSIAN ***
+C
+ K = 1
+ DO 100 I = 1, N
+ T = ONE / D(I)
+ DO 90 J = 1, I
+ H(K) = T * H(K) / D(J)
+ K = K + 1
+ 90 CONTINUE
+ 100 CONTINUE
+C
+ IF (IV(CNVCOD) .NE. 0) GO TO 390
+ IF (IV(MODE) .EQ. 0) GO TO 350
+C
+C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) ***
+C
+ V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC))
+C
+ IV(MODE) = 0
+C
+C
+C----------------------------- MAIN LOOP -----------------------------
+C
+C
+C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
+C
+ 110 CALL DITSUM(D, G, IV, LIV, LV, N, V, X)
+ 120 K = IV(NITER)
+ IF (K .LT. IV(MXITER)) GO TO 130
+ IV(1) = 10
+ GO TO 400
+C
+ 130 IV(NITER) = K + 1
+C
+C *** INITIALIZE FOR START OF NEXT ITERATION ***
+C
+ DG1 = IV(DG)
+ X01 = IV(X0)
+ V(F0) = V(F)
+ IV(IRC) = 4
+ IV(KAGQT) = -1
+C
+C *** COPY X TO X0 ***
+C
+ CALL DV7CPY(N, V(X01), X)
+C
+C *** UPDATE RADIUS ***
+C
+ IF (K .EQ. 0) GO TO 150
+ STEP1 = IV(STEP)
+ K = STEP1
+ DO 140 I = 1, N
+ V(K) = D(I) * V(K)
+ K = K + 1
+ 140 CONTINUE
+ V(RADIUS) = V(RADFAC) * DV2NRM(N, V(STEP1))
+C
+C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
+C
+ 150 IF (.NOT. STOPX(DUMMY)) GO TO 170
+ IV(1) = 11
+ GO TO 180
+C
+C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
+C
+ 160 IF (V(F) .GE. V(F0)) GO TO 170
+ V(RADFAC) = ONE
+ K = IV(NITER)
+ GO TO 130
+C
+ 170 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 190
+ IV(1) = 9
+ 180 IF (V(F) .GE. V(F0)) GO TO 400
+C
+C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
+C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
+C
+ IV(CNVCOD) = IV(1)
+ GO TO 340
+C
+C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
+C
+ 190 STEP1 = IV(STEP)
+ DG1 = IV(DG)
+ L = IV(LMAT)
+ W1 = IV(W)
+ CALL DG7QTS(D, V(DG1), H, IV(KAGQT), V(L), N, V(STEP1), V, V(W1))
+ IF (IV(IRC) .NE. 6) GO TO 200
+ IF (IV(RESTOR) .NE. 2) GO TO 220
+ RSTRST = 2
+ GO TO 230
+C
+C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
+C
+ 200 IV(TOOBIG) = 0
+ IF (V(DSTNRM) .LE. ZERO) GO TO 220
+ IF (IV(IRC) .NE. 5) GO TO 210
+ IF (V(RADFAC) .LE. ONE) GO TO 210
+ IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 210
+ IF (IV(RESTOR) .NE. 2) GO TO 220
+ RSTRST = 0
+ GO TO 230
+C
+C *** COMPUTE F(X0 + STEP) ***
+C
+ 210 X01 = IV(X0)
+ STEP1 = IV(STEP)
+ CALL DV2AXY(N, X, ONE, V(STEP1), V(X01))
+ IV(NFCALL) = IV(NFCALL) + 1
+ IV(1) = 1
+ GO TO 999
+C
+C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
+C
+ 220 RSTRST = 3
+ 230 X01 = IV(X0)
+ V(RELDX) = DRLDST(N, D, X, V(X01))
+ CALL DA7SST(IV, LIV, LV, V)
+ STEP1 = IV(STEP)
+ LSTGST = IV(STLSTG)
+ I = IV(RESTOR) + 1
+ GO TO (270, 240, 250, 260), I
+ 240 CALL DV7CPY(N, X, V(X01))
+ GO TO 270
+ 250 CALL DV7CPY(N, V(LSTGST), V(STEP1))
+ GO TO 270
+ 260 CALL DV7CPY(N, V(STEP1), V(LSTGST))
+ CALL DV2AXY(N, X, ONE, V(STEP1), V(X01))
+ V(RELDX) = DRLDST(N, D, X, V(X01))
+ IV(RESTOR) = RSTRST
+C
+ 270 K = IV(IRC)
+ GO TO (280,310,310,310,280,290,300,300,300,300,300,300,380,350), K
+C
+C *** RECOMPUTE STEP WITH NEW RADIUS ***
+C
+ 280 V(RADIUS) = V(RADFAC) * V(DSTNRM)
+ GO TO 150
+C
+C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST.
+C
+ 290 V(RADIUS) = V(LMAXS)
+ GO TO 190
+C
+C *** CONVERGENCE OR FALSE CONVERGENCE ***
+C
+ 300 IV(CNVCOD) = K - 4
+ IF (V(F) .GE. V(F0)) GO TO 390
+ IF (IV(XIRC) .EQ. 14) GO TO 390
+ IV(XIRC) = 14
+C
+C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
+C
+ 310 IF (IV(IRC) .NE. 3) GO TO 340
+ TEMP1 = LSTGST
+C
+C *** PREPARE FOR GRADIENT TESTS ***
+C *** SET TEMP1 = HESSIAN * STEP + G(X0)
+C *** = DIAG(D) * (H * STEP + G(X0))
+C
+C USE X0 VECTOR AS TEMPORARY.
+ K = X01
+ DO 320 I = 1, N
+ V(K) = D(I) * V(STEP1)
+ K = K + 1
+ STEP1 = STEP1 + 1
+ 320 CONTINUE
+ CALL DS7LVM(N, V(TEMP1), H, V(X01))
+ DO 330 I = 1, N
+ V(TEMP1) = D(I) * V(TEMP1) + G(I)
+ TEMP1 = TEMP1 + 1
+ 330 CONTINUE
+C
+C *** COMPUTE GRADIENT AND HESSIAN ***
+C
+ 340 IV(NGCALL) = IV(NGCALL) + 1
+ IV(TOOBIG) = 0
+ IV(1) = 2
+ GO TO 999
+C
+ 350 IV(1) = 2
+ IF (IV(IRC) .NE. 3) GO TO 110
+C
+C *** SET V(RADFAC) BY GRADIENT TESTS ***
+C
+ TEMP1 = IV(STLSTG)
+ STEP1 = IV(STEP)
+C
+C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) ***
+C
+ K = TEMP1
+ DO 360 I = 1, N
+ V(K) = (V(K) - G(I)) / D(I)
+ K = K + 1
+ 360 CONTINUE
+C
+C *** DO GRADIENT TESTS ***
+C
+ IF (DV2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 370
+ IF (DD7TPR(N, G, V(STEP1))
+ 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 110
+ 370 V(RADFAC) = V(INCFAC)
+ GO TO 110
+C
+C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
+C
+C *** BAD PARAMETERS TO ASSESS ***
+C
+ 380 IV(1) = 64
+ GO TO 400
+C
+C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
+C
+ 390 IV(1) = IV(CNVCOD)
+ IV(CNVCOD) = 0
+ 400 CALL DITSUM(D, G, IV, LIV, LV, N, V, X)
+C
+ 999 RETURN
+C
+C *** LAST CARD OF DRMNH FOLLOWS ***
+ END
+ SUBROUTINE DQ7RSH(K, P, HAVQTR, QTR, R, W)
+C
+C *** PERMUTE COLUMN K OF R TO COLUMN P, MODIFY QTR ACCORDINGLY ***
+C
+ LOGICAL HAVQTR
+ INTEGER K, P
+ DOUBLE PRECISION QTR(P), R(*), W(P)
+C DIMENSION R(P*(P+1)/2)
+C
+ DOUBLE PRECISION DH2RFG
+ EXTERNAL DH2RFA, DH2RFG,DV7CPY
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER I, I1, J, JM1, JP1, J1, KM1, K1, PM1
+ DOUBLE PRECISION A, B, T, WJ, X, Y, Z, ZERO
+C
+ DATA ZERO/0.0D+0/
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ IF (K .GE. P) GO TO 999
+ KM1 = K - 1
+ K1 = K * KM1 / 2
+ CALL DV7CPY(K, W, R(K1+1))
+ WJ = W(K)
+ PM1 = P - 1
+ J1 = K1 + KM1
+ DO 50 J = K, PM1
+ JM1 = J - 1
+ JP1 = J + 1
+ IF (JM1 .GT. 0) CALL DV7CPY(JM1, R(K1+1), R(J1+2))
+ J1 = J1 + JP1
+ K1 = K1 + J
+ A = R(J1)
+ B = R(J1+1)
+ IF (B .NE. ZERO) GO TO 10
+ R(K1) = A
+ X = ZERO
+ Z = ZERO
+ GO TO 40
+ 10 R(K1) = DH2RFG(A, B, X, Y, Z)
+ IF (J .EQ. PM1) GO TO 30
+ I1 = J1
+ DO 20 I = JP1, PM1
+ I1 = I1 + I
+ CALL DH2RFA(1, R(I1), R(I1+1), X, Y, Z)
+ 20 CONTINUE
+ 30 IF (HAVQTR) CALL DH2RFA(1, QTR(J), QTR(JP1), X, Y, Z)
+ 40 T = X * WJ
+ W(J) = WJ + T
+ WJ = T * Z
+ 50 CONTINUE
+ W(P) = WJ
+ CALL DV7CPY(P, R(K1+1), W)
+ 999 RETURN
+ END
+ SUBROUTINE DRMNF(D, FX, IV, LIV, LV, N, V, X)
+C
+C *** ITERATION DRIVER FOR DMNF...
+C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING
+C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS.
+C
+ INTEGER LIV, LV, N
+ INTEGER IV(LIV)
+ DOUBLE PRECISION D(N), FX, X(N), V(LV)
+C DIMENSION V(77 + N*(N+17)/2)
+C
+C *** PURPOSE ***
+C
+C THIS ROUTINE INTERACTS WITH SUBROUTINE DRMNG IN AN ATTEMPT
+C TO FIND AN N-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED)
+C OBJECTIVE FUNCTION FX = F(X) COMPUTED BY THE CALLER. (OFTEN
+C THE X* FOUND IS A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.)
+C
+C *** PARAMETERS ***
+C
+C THE PARAMETERS FOR DRMNF ARE THE SAME AS THOSE FOR DMNG
+C (WHICH SEE), EXCEPT THAT CALCF, CALCG, UIPARM, URPARM, AND UFPARM
+C ARE OMITTED, AND A PARAMETER FX FOR THE OBJECTIVE FUNCTION
+C VALUE AT X IS ADDED. INSTEAD OF CALLING CALCG TO OBTAIN THE
+C GRADIENT OF THE OBJECTIVE FUNCTION AT X, DRMNF CALLS DS7GRD,
+C WHICH COMPUTES AN APPROXIMATION TO THE GRADIENT BY FINITE
+C (FORWARD AND CENTRAL) DIFFERENCES USING THE METHOD OF REF. 1.
+C THE FOLLOWING INPUT COMPONENT IS OF INTEREST IN THIS REGARD
+C (AND IS NOT DESCRIBED IN DMNG).
+C
+C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE
+C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF...
+C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E),
+C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3,
+C WHERE MACHEP IS THE UNIT ROUNDOFF.
+C
+C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT
+C MEANINGS FOR DMNF THAN FOR DMNG...
+C
+C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E.,
+C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR
+C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A
+C LIMIT ON IV(NFCALL).
+C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY
+C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION
+C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL).
+C
+C *** REFERENCES ***
+C
+C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
+C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
+C J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
+C.
+C *** GENERAL ***
+C
+C CODED BY DAVID M. GAY (AUGUST 1982).
+C
+C---------------------------- DECLARATIONS ---------------------------
+C
+ DOUBLE PRECISION DD7TPR
+ EXTERNAL DIVSET, DD7TPR, DS7GRD, DRMNG, DV7SCP
+C
+C DIVSET.... SUPPLIES DEFAULT PARAMETER VALUES.
+C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
+C DS7GRD... COMPUTES FINITE-DIFFERENCE GRADIENT APPROXIMATION.
+C DRMNG.... REVERSE-COMMUNICATION ROUTINE THAT DOES DMNG ALGORITHM.
+C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
+C
+ INTEGER ALPHA, G1, I, IV1, J, K, W
+ DOUBLE PRECISION ZERO
+C
+C *** SUBSCRIPTS FOR IV ***
+C
+ INTEGER ETA0, F, G, LMAT, NEXTV, NGCALL, NITER, SGIRC, TOOBIG,
+ 1 VNEED
+C
+ PARAMETER (ETA0=42, F=10, G=28, LMAT=42, NEXTV=47, NGCALL=30,
+ 1 NITER=31, SGIRC=57, TOOBIG=2, VNEED=4)
+ PARAMETER (ZERO=0.D+0)
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ IV1 = IV(1)
+ IF (IV1 .EQ. 1) GO TO 10
+ IF (IV1 .EQ. 2) GO TO 50
+ IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
+ IV1 = IV(1)
+ IF (IV1 .EQ. 12 .OR. IV1 .EQ. 13) IV(VNEED) = IV(VNEED) + 2*N + 6
+ IF (IV1 .EQ. 14) GO TO 10
+ IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
+ G1 = 1
+ IF (IV1 .EQ. 12) IV(1) = 13
+ GO TO 20
+C
+ 10 G1 = IV(G)
+C
+ 20 CALL DRMNG(D, FX, V(G1), IV, LIV, LV, N, V, X)
+ IF (IV(1) .LT. 2) GO TO 999
+ IF (IV(1) .GT. 2) GO TO 70
+C
+C *** COMPUTE GRADIENT ***
+C
+ IF (IV(NITER) .EQ. 0) CALL DV7SCP(N, V(G1), ZERO)
+ J = IV(LMAT)
+ K = G1 - N
+ DO 40 I = 1, N
+ V(K) = DD7TPR(I, V(J), V(J))
+ K = K + 1
+ J = J + I
+ 40 CONTINUE
+C *** UNDO INCREMENT OF IV(NGCALL) DONE BY DRMNG ***
+ IV(NGCALL) = IV(NGCALL) - 1
+C *** STORE RETURN CODE FROM DS7GRD IN IV(SGIRC) ***
+ IV(SGIRC) = 0
+C *** X MAY HAVE BEEN RESTORED, SO COPY BACK FX... ***
+ FX = V(F)
+ GO TO 60
+C
+C *** GRADIENT LOOP ***
+C
+ 50 IF (IV(TOOBIG) .NE. 0) GO TO 10
+C
+ 60 G1 = IV(G)
+ ALPHA = G1 - N
+ W = ALPHA - 6
+ CALL DS7GRD(V(ALPHA), D, V(ETA0), FX, V(G1), IV(SGIRC), N, V(W),X)
+ IF (IV(SGIRC) .EQ. 0) GO TO 10
+ IV(NGCALL) = IV(NGCALL) + 1
+ GO TO 999
+C
+ 70 IF (IV(1) .NE. 14) GO TO 999
+C
+C *** STORAGE ALLOCATION ***
+C
+ IV(G) = IV(NEXTV) + N + 6
+ IV(NEXTV) = IV(G) + N
+ IF (IV1 .NE. 13) GO TO 10
+C
+ 999 RETURN
+C *** LAST CARD OF DRMNF FOLLOWS ***
+ END
+ SUBROUTINE DL7VML(N, X, L, Y)
+C
+C *** COMPUTE X = L*Y, WHERE L IS AN N X N LOWER TRIANGULAR
+C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME
+C *** STORAGE. ***
+C
+ INTEGER N
+ DOUBLE PRECISION X(N), L(*), Y(N)
+C DIMENSION L(N*(N+1)/2)
+ INTEGER I, II, IJ, I0, J, NP1
+ DOUBLE PRECISION T, ZERO
+ PARAMETER (ZERO=0.D+0)
+C
+ NP1 = N + 1
+ I0 = N*(N+1)/2
+ DO 20 II = 1, N
+ I = NP1 - II
+ I0 = I0 - I
+ T = ZERO
+ DO 10 J = 1, I
+ IJ = I0 + J
+ T = T + L(IJ)*Y(J)
+ 10 CONTINUE
+ X(I) = T
+ 20 CONTINUE
+ RETURN
+C *** LAST CARD OF DL7VML FOLLOWS ***
+ END
+ SUBROUTINE DA7SST(IV, LIV, LV, V)
+C
+C *** ASSESS CANDIDATE STEP (***SOL VERSION 2.3) ***
+C
+ INTEGER LIV, LV
+ INTEGER IV(LIV)
+ DOUBLE PRECISION V(LV)
+C
+C *** PURPOSE ***
+C
+C THIS SUBROUTINE IS CALLED BY AN UNCONSTRAINED MINIMIZATION
+C ROUTINE TO ASSESS THE NEXT CANDIDATE STEP. IT MAY RECOMMEND ONE
+C OF SEVERAL COURSES OF ACTION, SUCH AS ACCEPTING THE STEP, RECOM-
+C PUTING IT USING THE SAME OR A NEW QUADRATIC MODEL, OR HALTING DUE
+C TO CONVERGENCE OR FALSE CONVERGENCE. SEE THE RETURN CODE LISTING
+C BELOW.
+C
+C-------------------------- PARAMETER USAGE --------------------------
+C
+C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION
+C BELOW OF IV VALUES REFERENCED.
+C LIV (IN) LENGTH OF IV ARRAY.
+C LV (IN) LENGTH OF V ARRAY.
+C V (I/O) REAL PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION
+C BELOW OF V VALUES REFERENCED.
+C
+C *** IV VALUES REFERENCED ***
+C
+C IV(IRC) (I/O) ON INPUT FOR THE FIRST STEP TRIED IN A NEW ITERATION,
+C IV(IRC) SHOULD BE SET TO 3 OR 4 (THE VALUE TO WHICH IT IS
+C SET WHEN STEP IS DEFINITELY TO BE ACCEPTED). ON INPUT
+C AFTER STEP HAS BEEN RECOMPUTED, IV(IRC) SHOULD BE
+C UNCHANGED SINCE THE PREVIOUS RETURN OF DA7SST.
+C ON OUTPUT, IV(IRC) IS A RETURN CODE HAVING ONE OF THE
+C FOLLOWING VALUES...
+C 1 = SWITCH MODELS OR TRY SMALLER STEP.
+C 2 = SWITCH MODELS OR ACCEPT STEP.
+C 3 = ACCEPT STEP AND DETERMINE V(RADFAC) BY GRADIENT
+C TESTS.
+C 4 = ACCEPT STEP, V(RADFAC) HAS BEEN DETERMINED.
+C 5 = RECOMPUTE STEP (USING THE SAME MODEL).
+C 6 = RECOMPUTE STEP WITH RADIUS = V(LMAXS) BUT DO NOT
+C EVALUATE THE OBJECTIVE FUNCTION.
+C 7 = X-CONVERGENCE (SEE V(XCTOL)).
+C 8 = RELATIVE FUNCTION CONVERGENCE (SEE V(RFCTOL)).
+C 9 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE.
+C 10 = ABSOLUTE FUNCTION CONVERGENCE (SEE V(AFCTOL)).
+C 11 = SINGULAR CONVERGENCE (SEE V(LMAXS)).
+C 12 = FALSE CONVERGENCE (SEE V(XFTOL)).
+C 13 = IV(IRC) WAS OUT OF RANGE ON INPUT.
+C RETURN CODE I HAS PRECEDENCE OVER I+1 FOR I = 9, 10, 11.
+C IV(MLSTGD) (I/O) SAVED VALUE OF IV(MODEL).
+C IV(MODEL) (I/O) ON INPUT, IV(MODEL) SHOULD BE AN INTEGER IDENTIFYING
+C THE CURRENT QUADRATIC MODEL OF THE OBJECTIVE FUNCTION.
+C IF A PREVIOUS STEP YIELDED A BETTER FUNCTION REDUCTION,
+C THEN IV(MODEL) WILL BE SET TO IV(MLSTGD) ON OUTPUT.
+C IV(NFCALL) (IN) INVOCATION COUNT FOR THE OBJECTIVE FUNCTION.
+C IV(NFGCAL) (I/O) VALUE OF IV(NFCALL) AT STEP THAT GAVE THE BIGGEST
+C FUNCTION REDUCTION THIS ITERATION. IV(NFGCAL) REMAINS
+C UNCHANGED UNTIL A FUNCTION REDUCTION IS OBTAINED.
+C IV(RADINC) (I/O) THE NUMBER OF RADIUS INCREASES (OR MINUS THE NUMBER
+C OF DECREASES) SO FAR THIS ITERATION.
+C IV(RESTOR) (OUT) SET TO 1 IF V(F) HAS BEEN RESTORED AND X SHOULD BE
+C RESTORED TO ITS INITIAL VALUE, TO 2 IF X SHOULD BE SAVED,
+C TO 3 IF X SHOULD BE RESTORED FROM THE SAVED VALUE, AND TO
+C 0 OTHERWISE.
+C IV(STAGE) (I/O) COUNT OF THE NUMBER OF MODELS TRIED SO FAR IN THE
+C CURRENT ITERATION.
+C IV(STGLIM) (IN) MAXIMUM NUMBER OF MODELS TO CONSIDER.
+C IV(SWITCH) (OUT) SET TO 0 UNLESS A NEW MODEL IS BEING TRIED AND IT
+C GIVES A SMALLER FUNCTION VALUE THAN THE PREVIOUS MODEL,
+C IN WHICH CASE DA7SST SETS IV(SWITCH) = 1.
+C IV(TOOBIG) (I/O) IS NONZERO ON INPUT IF STEP WAS TOO BIG (E.G., IF
+C IT WOULD CAUSE OVERFLOW). IT IS SET TO 0 ON RETURN.
+C IV(XIRC) (I/O) VALUE THAT IV(IRC) WOULD HAVE IN THE ABSENCE OF
+C CONVERGENCE, FALSE CONVERGENCE, AND OVERSIZED STEPS.
+C
+C *** V VALUES REFERENCED ***
+C
+C V(AFCTOL) (IN) ABSOLUTE FUNCTION CONVERGENCE TOLERANCE. IF THE
+C ABSOLUTE VALUE OF THE CURRENT FUNCTION VALUE V(F) IS LESS
+C THAN V(AFCTOL) AND DA7SST DOES NOT RETURN WITH
+C IV(IRC) = 11, THEN DA7SST RETURNS WITH IV(IRC) = 10.
+C V(DECFAC) (IN) FACTOR BY WHICH TO DECREASE RADIUS WHEN IV(TOOBIG) IS
+C NONZERO.
+C V(DSTNRM) (IN) THE 2-NORM OF D*STEP.
+C V(DSTSAV) (I/O) VALUE OF V(DSTNRM) ON SAVED STEP.
+C V(DST0) (IN) THE 2-NORM OF D TIMES THE NEWTON STEP (WHEN DEFINED,
+C I.E., FOR V(NREDUC) .GE. 0).
+C V(F) (I/O) ON BOTH INPUT AND OUTPUT, V(F) IS THE OBJECTIVE FUNC-
+C TION VALUE AT X. IF X IS RESTORED TO A PREVIOUS VALUE,
+C THEN V(F) IS RESTORED TO THE CORRESPONDING VALUE.
+C V(FDIF) (OUT) THE FUNCTION REDUCTION V(F0) - V(F) (FOR THE OUTPUT
+C VALUE OF V(F) IF AN EARLIER STEP GAVE A BIGGER FUNCTION
+C DECREASE, AND FOR THE INPUT VALUE OF V(F) OTHERWISE).
+C V(FLSTGD) (I/O) SAVED VALUE OF V(F).
+C V(F0) (IN) OBJECTIVE FUNCTION VALUE AT START OF ITERATION.
+C V(GTSLST) (I/O) VALUE OF V(GTSTEP) ON SAVED STEP.
+C V(GTSTEP) (IN) INNER PRODUCT BETWEEN STEP AND GRADIENT.
+C V(INCFAC) (IN) MINIMUM FACTOR BY WHICH TO INCREASE RADIUS.
+C V(LMAXS) (IN) MAXIMUM REASONABLE STEP SIZE (AND INITIAL STEP BOUND).
+C IF THE ACTUAL FUNCTION DECREASE IS NO MORE THAN TWICE
+C WHAT WAS PREDICTED, IF A RETURN WITH IV(IRC) = 7, 8, OR 9
+C DOES NOT OCCUR, IF V(DSTNRM) .GT. V(LMAXS) OR THE CURRENT
+C STEP IS A NEWTON STEP, AND IF
+C V(PREDUC) .LE. V(SCTOL) * ABS(V(F0)), THEN DA7SST RETURNS
+C WITH IV(IRC) = 11. IF SO DOING APPEARS WORTHWHILE, THEN
+C DA7SST REPEATS THIS TEST (DISALLOWING A FULL NEWTON STEP)
+C WITH V(PREDUC) COMPUTED FOR A STEP OF LENGTH V(LMAXS)
+C (BY A RETURN WITH IV(IRC) = 6).
+C V(NREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR
+C NEWTON STEP. IF DA7SST IS CALLED WITH IV(IRC) = 6, I.E.,
+C IF V(PREDUC) HAS BEEN COMPUTED WITH RADIUS = V(LMAXS) FOR
+C USE IN THE SINGULAR CONVERGENCE TEST, THEN V(NREDUC) IS
+C SET TO -V(PREDUC) BEFORE THE LATTER IS RESTORED.
+C V(PLSTGD) (I/O) VALUE OF V(PREDUC) ON SAVED STEP.
+C V(PREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR
+C CURRENT STEP.
+C V(RADFAC) (OUT) FACTOR TO BE USED IN DETERMINING THE NEW RADIUS,
+C WHICH SHOULD BE V(RADFAC)*DST, WHERE DST IS EITHER THE
+C OUTPUT VALUE OF V(DSTNRM) OR THE 2-NORM OF
+C DIAG(NEWD)*STEP FOR THE OUTPUT VALUE OF STEP AND THE
+C UPDATED VERSION, NEWD, OF THE SCALE VECTOR D. FOR
+C IV(IRC) = 3, V(RADFAC) = 1.0 IS RETURNED.
+C V(RDFCMN) (IN) MINIMUM VALUE FOR V(RADFAC) IN TERMS OF THE INPUT
+C VALUE OF V(DSTNRM) -- SUGGESTED VALUE = 0.1.
+C V(RDFCMX) (IN) MAXIMUM VALUE FOR V(RADFAC) -- SUGGESTED VALUE = 4.0.
+C V(RELDX) (IN) SCALED RELATIVE CHANGE IN X CAUSED BY STEP, COMPUTED
+C (E.G.) BY FUNCTION DRLDST AS
+C MAX (D(I)*ABS(X(I)-X0(I)), 1 .LE. I .LE. P) /
+C MAX (D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P).
+C V(RFCTOL) (IN) RELATIVE FUNCTION CONVERGENCE TOLERANCE. IF THE
+C ACTUAL FUNCTION REDUCTION IS AT MOST TWICE WHAT WAS PRE-
+C DICTED AND V(NREDUC) .LE. V(RFCTOL)*ABS(V(F0)), THEN
+C DA7SST RETURNS WITH IV(IRC) = 8 OR 9.
+C V(SCTOL) (IN) SINGULAR CONVERGENCE TOLERANCE -- SEE V(LMAXS).
+C V(STPPAR) (IN) MARQUARDT PARAMETER -- 0 MEANS FULL NEWTON STEP.
+C V(TUNER1) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION
+C REDUCTION WAS MUCH LESS THAN EXPECTED. SUGGESTED
+C VALUE = 0.1.
+C V(TUNER2) (IN) TUNING CONSTANT USED TO DECIDE IF THE FUNCTION
+C REDUCTION WAS LARGE ENOUGH TO ACCEPT STEP. SUGGESTED
+C VALUE = 10**-4.
+C V(TUNER3) (IN) TUNING CONSTANT USED TO DECIDE IF THE RADIUS
+C SHOULD BE INCREASED. SUGGESTED VALUE = 0.75.
+C V(XCTOL) (IN) X-CONVERGENCE CRITERION. IF STEP IS A NEWTON STEP
+C (V(STPPAR) = 0) HAVING V(RELDX) .LE. V(XCTOL) AND GIVING
+C AT MOST TWICE THE PREDICTED FUNCTION DECREASE, THEN
+C DA7SST RETURNS IV(IRC) = 7 OR 9.
+C V(XFTOL) (IN) FALSE CONVERGENCE TOLERANCE. IF STEP GAVE NO OR ONLY
+C A SMALL FUNCTION DECREASE AND V(RELDX) .LE. V(XFTOL),
+C THEN DA7SST RETURNS WITH IV(IRC) = 12.
+C
+C------------------------------- NOTES -------------------------------
+C
+C *** APPLICATION AND USAGE RESTRICTIONS ***
+C
+C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR
+C LEAST-SQUARES) PACKAGE. IT MAY BE USED IN ANY UNCONSTRAINED
+C MINIMIZATION SOLVER THAT USES DOGLEG, GOLDFELD-QUANDT-TROTTER,
+C OR LEVENBERG-MARQUARDT STEPS.
+C
+C *** ALGORITHM NOTES ***
+C
+C SEE (1) FOR FURTHER DISCUSSION OF THE ASSESSING AND MODEL
+C SWITCHING STRATEGIES. WHILE NL2SOL CONSIDERS ONLY TWO MODELS,
+C DA7SST IS DESIGNED TO HANDLE ANY NUMBER OF MODELS.
+C
+C *** USAGE NOTES ***
+C
+C ON THE FIRST CALL OF AN ITERATION, ONLY THE I/O VARIABLES
+C STEP, X, IV(IRC), IV(MODEL), V(F), V(DSTNRM), V(GTSTEP), AND
+C V(PREDUC) NEED HAVE BEEN INITIALIZED. BETWEEN CALLS, NO I/O
+C VALUES EXCEPT STEP, X, IV(MODEL), V(F) AND THE STOPPING TOLER-
+C ANCES SHOULD BE CHANGED.
+C AFTER A RETURN FOR CONVERGENCE OR FALSE CONVERGENCE, ONE CAN
+C CHANGE THE STOPPING TOLERANCES AND CALL DA7SST AGAIN, IN WHICH
+C CASE THE STOPPING TESTS WILL BE REPEATED.
+C
+C *** REFERENCES ***
+C
+C (1) DENNIS, J.E., JR., GAY, D.M., AND WELSCH, R.E. (1981),
+C AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM,
+C ACM TRANS. MATH. SOFTWARE, VOL. 7, NO. 3.
+C
+C (2) POWELL, M.J.D. (1970) A FORTRAN SUBROUTINE FOR SOLVING
+C SYSTEMS OF NONLINEAR ALGEBRAIC EQUATIONS, IN NUMERICAL
+C METHODS FOR NONLINEAR ALGEBRAIC EQUATIONS, EDITED BY
+C P. RABINOWITZ, GORDON AND BREACH, LONDON.
+C
+C *** HISTORY ***
+C
+C JOHN DENNIS DESIGNED MUCH OF THIS ROUTINE, STARTING WITH
+C IDEAS IN (2). ROY WELSCH SUGGESTED THE MODEL SWITCHING STRATEGY.
+C DAVID GAY AND STEPHEN PETERS CAST THIS SUBROUTINE INTO A MORE
+C PORTABLE FORM (WINTER 1977), AND DAVID GAY CAST IT INTO ITS
+C PRESENT FORM (FALL 1978), WITH MINOR CHANGES TO THE SINGULAR
+C CONVERGENCE TEST IN MAY, 1984 (TO DEAL WITH FULL NEWTON STEPS).
+C
+C *** GENERAL ***
+C
+C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
+C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
+C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
+C MCS-7906671.
+C
+C------------------------ EXTERNAL QUANTITIES ------------------------
+C
+C *** NO EXTERNAL FUNCTIONS AND SUBROUTINES ***
+C
+C-------------------------- LOCAL VARIABLES --------------------------
+C
+ LOGICAL GOODX
+ INTEGER I, NFC
+ DOUBLE PRECISION EMAX, EMAXS, GTS, RFAC1, XMAX
+ DOUBLE PRECISION HALF, ONE, ONEP2, TWO, ZERO
+C
+C *** SUBSCRIPTS FOR IV AND V ***
+C
+ INTEGER AFCTOL, DECFAC, DSTNRM, DSTSAV, DST0, F, FDIF, FLSTGD, F0,
+ 1 GTSLST, GTSTEP, INCFAC, IRC, LMAXS, MLSTGD, MODEL, NFCALL,
+ 2 NFGCAL, NREDUC, PLSTGD, PREDUC, RADFAC, RADINC, RDFCMN,
+ 3 RDFCMX, RELDX, RESTOR, RFCTOL, SCTOL, STAGE, STGLIM,
+ 4 STPPAR, SWITCH, TOOBIG, TUNER1, TUNER2, TUNER3, XCTOL,
+ 5 XFTOL, XIRC
+C
+C *** DATA INITIALIZATIONS ***
+C
+ PARAMETER (HALF=0.5D+0, ONE=1.D+0, ONEP2=1.2D+0, TWO=2.D+0,
+ 1 ZERO=0.D+0)
+C
+ PARAMETER (IRC=29, MLSTGD=32, MODEL=5, NFCALL=6, NFGCAL=7,
+ 1 RADINC=8, RESTOR=9, STAGE=10, STGLIM=11, SWITCH=12,
+ 2 TOOBIG=2, XIRC=13)
+ PARAMETER (AFCTOL=31, DECFAC=22, DSTNRM=2, DST0=3, DSTSAV=18,
+ 1 F=10, FDIF=11, FLSTGD=12, F0=13, GTSLST=14, GTSTEP=4,
+ 2 INCFAC=23, LMAXS=36, NREDUC=6, PLSTGD=15, PREDUC=7,
+ 3 RADFAC=16, RDFCMN=24, RDFCMX=25, RELDX=17, RFCTOL=32,
+ 4 SCTOL=37, STPPAR=5, TUNER1=26, TUNER2=27, TUNER3=28,
+ 5 XCTOL=33, XFTOL=34)
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ NFC = IV(NFCALL)
+ IV(SWITCH) = 0
+ IV(RESTOR) = 0
+ RFAC1 = ONE
+ GOODX = .TRUE.
+ I = IV(IRC)
+ IF (I .GE. 1 .AND. I .LE. 12)
+ 1 GO TO (20,30,10,10,40,280,220,220,220,220,220,170), I
+ IV(IRC) = 13
+ GO TO 999
+C
+C *** INITIALIZE FOR NEW ITERATION ***
+C
+ 10 IV(STAGE) = 1
+ IV(RADINC) = 0
+ V(FLSTGD) = V(F0)
+ IF (IV(TOOBIG) .EQ. 0) GO TO 110
+ IV(STAGE) = -1
+ IV(XIRC) = I
+ GO TO 60
+C
+C *** STEP WAS RECOMPUTED WITH NEW MODEL OR SMALLER RADIUS ***
+C *** FIRST DECIDE WHICH ***
+C
+ 20 IF (IV(MODEL) .NE. IV(MLSTGD)) GO TO 30
+C *** OLD MODEL RETAINED, SMALLER RADIUS TRIED ***
+C *** DO NOT CONSIDER ANY MORE NEW MODELS THIS ITERATION ***
+ IV(STAGE) = IV(STGLIM)
+ IV(RADINC) = -1
+ GO TO 110
+C
+C *** A NEW MODEL IS BEING TRIED. DECIDE WHETHER TO KEEP IT. ***
+C
+ 30 IV(STAGE) = IV(STAGE) + 1
+C
+C *** NOW WE ADD THE POSSIBILITY THAT STEP WAS RECOMPUTED WITH ***
+C *** THE SAME MODEL, PERHAPS BECAUSE OF AN OVERSIZED STEP. ***
+C
+ 40 IF (IV(STAGE) .GT. 0) GO TO 50
+C
+C *** STEP WAS RECOMPUTED BECAUSE IT WAS TOO BIG. ***
+C
+ IF (IV(TOOBIG) .NE. 0) GO TO 60
+C
+C *** RESTORE IV(STAGE) AND PICK UP WHERE WE LEFT OFF. ***
+C
+ IV(STAGE) = -IV(STAGE)
+ I = IV(XIRC)
+ GO TO (20, 30, 110, 110, 70), I
+C
+ 50 IF (IV(TOOBIG) .EQ. 0) GO TO 70
+C
+C *** HANDLE OVERSIZE STEP ***
+C
+ IV(TOOBIG) = 0
+ IF (IV(RADINC) .GT. 0) GO TO 80
+ IV(STAGE) = -IV(STAGE)
+ IV(XIRC) = IV(IRC)
+C
+ 60 IV(TOOBIG) = 0
+ V(RADFAC) = V(DECFAC)
+ IV(RADINC) = IV(RADINC) - 1
+ IV(IRC) = 5
+ IV(RESTOR) = 1
+ V(F) = V(FLSTGD)
+ GO TO 999
+C
+ 70 IF (V(F) .LT. V(FLSTGD)) GO TO 110
+C
+C *** THE NEW STEP IS A LOSER. RESTORE OLD MODEL. ***
+C
+ IF (IV(MODEL) .EQ. IV(MLSTGD)) GO TO 80
+ IV(MODEL) = IV(MLSTGD)
+ IV(SWITCH) = 1
+C
+C *** RESTORE STEP, ETC. ONLY IF A PREVIOUS STEP DECREASED V(F).
+C
+ 80 IF (V(FLSTGD) .GE. V(F0)) GO TO 110
+ IF (IV(STAGE) .LT. IV(STGLIM)) THEN
+ GOODX = .FALSE.
+ ELSE IF (NFC .LT. IV(NFGCAL) + IV(STGLIM) + 2) THEN
+ GOODX = .FALSE.
+ ELSE IF (IV(SWITCH) .NE. 0) THEN
+ GOODX = .FALSE.
+ ENDIF
+ IV(RESTOR) = 3
+ V(F) = V(FLSTGD)
+ V(PREDUC) = V(PLSTGD)
+ V(GTSTEP) = V(GTSLST)
+ IF (IV(SWITCH) .EQ. 0) RFAC1 = V(DSTNRM) / V(DSTSAV)
+ V(DSTNRM) = V(DSTSAV)
+ IF (GOODX) THEN
+C
+C *** ACCEPT PREVIOUS SLIGHTLY REDUCING STEP ***
+C
+ V(FDIF) = V(F0) - V(F)
+ IV(IRC) = 4
+ V(RADFAC) = RFAC1
+ GO TO 999
+ ENDIF
+ NFC = IV(NFGCAL)
+C
+ 110 V(FDIF) = V(F0) - V(F)
+ IF (V(FDIF) .GT. V(TUNER2) * V(PREDUC)) GO TO 140
+ IF (IV(RADINC) .GT. 0) GO TO 140
+C
+C *** NO (OR ONLY A TRIVIAL) FUNCTION DECREASE
+C *** -- SO TRY NEW MODEL OR SMALLER RADIUS
+C
+ IF (V(F) .LT. V(F0)) GO TO 120
+ IV(MLSTGD) = IV(MODEL)
+ V(FLSTGD) = V(F)
+ V(F) = V(F0)
+ IV(RESTOR) = 1
+ GO TO 130
+ 120 IV(NFGCAL) = NFC
+ 130 IV(IRC) = 1
+ IF (IV(STAGE) .LT. IV(STGLIM)) GO TO 160
+ IV(IRC) = 5
+ IV(RADINC) = IV(RADINC) - 1
+ GO TO 160
+C
+C *** NONTRIVIAL FUNCTION DECREASE ACHIEVED ***
+C
+ 140 IV(NFGCAL) = NFC
+ RFAC1 = ONE
+ V(DSTSAV) = V(DSTNRM)
+ IF (V(FDIF) .GT. V(PREDUC)*V(TUNER1)) GO TO 190
+C
+C *** DECREASE WAS MUCH LESS THAN PREDICTED -- EITHER CHANGE MODELS
+C *** OR ACCEPT STEP WITH DECREASED RADIUS.
+C
+ IF (IV(STAGE) .GE. IV(STGLIM)) GO TO 150
+C *** CONSIDER SWITCHING MODELS ***
+ IV(IRC) = 2
+ GO TO 160
+C
+C *** ACCEPT STEP WITH DECREASED RADIUS ***
+C
+ 150 IV(IRC) = 4
+C
+C *** SET V(RADFAC) TO FLETCHER*S DECREASE FACTOR ***
+C
+ 160 IV(XIRC) = IV(IRC)
+ EMAX = V(GTSTEP) + V(FDIF)
+ V(RADFAC) = HALF * RFAC1
+ IF (EMAX .LT. V(GTSTEP)) V(RADFAC) = RFAC1 * DMAX1(V(RDFCMN),
+ 1 HALF * V(GTSTEP)/EMAX)
+C
+C *** DO FALSE CONVERGENCE TEST ***
+C
+ 170 IF (V(RELDX) .LE. V(XFTOL)) GO TO 180
+ IV(IRC) = IV(XIRC)
+ IF (V(F) .LT. V(F0)) GO TO 200
+ GO TO 230
+C
+ 180 IV(IRC) = 12
+ GO TO 240
+C
+C *** HANDLE GOOD FUNCTION DECREASE ***
+C
+ 190 IF (V(FDIF) .LT. (-V(TUNER3) * V(GTSTEP))) GO TO 210
+C
+C *** INCREASING RADIUS LOOKS WORTHWHILE. SEE IF WE JUST
+C *** RECOMPUTED STEP WITH A DECREASED RADIUS OR RESTORED STEP
+C *** AFTER RECOMPUTING IT WITH A LARGER RADIUS.
+C
+ IF (IV(RADINC) .LT. 0) GO TO 210
+ IF (IV(RESTOR) .EQ. 1) GO TO 210
+ IF (IV(RESTOR) .EQ. 3) GO TO 210
+C
+C *** WE DID NOT. TRY A LONGER STEP UNLESS THIS WAS A NEWTON
+C *** STEP.
+C
+ V(RADFAC) = V(RDFCMX)
+ GTS = V(GTSTEP)
+ IF (V(FDIF) .LT. (HALF/V(RADFAC) - ONE) * GTS)
+ 1 V(RADFAC) = DMAX1(V(INCFAC), HALF*GTS/(GTS + V(FDIF)))
+ IV(IRC) = 4
+ IF (V(STPPAR) .EQ. ZERO) GO TO 230
+ IF (V(DST0) .GE. ZERO .AND. (V(DST0) .LT. TWO*V(DSTNRM)
+ 1 .OR. V(NREDUC) .LT. ONEP2*V(FDIF))) GO TO 230
+C *** STEP WAS NOT A NEWTON STEP. RECOMPUTE IT WITH
+C *** A LARGER RADIUS.
+ IV(IRC) = 5
+ IV(RADINC) = IV(RADINC) + 1
+C
+C *** SAVE VALUES CORRESPONDING TO GOOD STEP ***
+C
+ 200 V(FLSTGD) = V(F)
+ IV(MLSTGD) = IV(MODEL)
+ IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2
+ V(DSTSAV) = V(DSTNRM)
+ IV(NFGCAL) = NFC
+ V(PLSTGD) = V(PREDUC)
+ V(GTSLST) = V(GTSTEP)
+ GO TO 230
+C
+C *** ACCEPT STEP WITH RADIUS UNCHANGED ***
+C
+ 210 V(RADFAC) = ONE
+ IV(IRC) = 3
+ GO TO 230
+C
+C *** COME HERE FOR A RESTART AFTER CONVERGENCE ***
+C
+ 220 IV(IRC) = IV(XIRC)
+ IF (V(DSTSAV) .GE. ZERO) GO TO 240
+ IV(IRC) = 12
+ GO TO 240
+C
+C *** PERFORM CONVERGENCE TESTS ***
+C
+ 230 IV(XIRC) = IV(IRC)
+ 240 IF (IV(RESTOR) .EQ. 1 .AND. V(FLSTGD) .LT. V(F0)) IV(RESTOR) = 3
+ IF (DABS(V(F)) .LT. V(AFCTOL)) IV(IRC) = 10
+ IF (HALF * V(FDIF) .GT. V(PREDUC)) GO TO 999
+ EMAX = V(RFCTOL) * DABS(V(F0))
+ EMAXS = V(SCTOL) * DABS(V(F0))
+ IF (V(PREDUC) .LE. EMAXS .AND. (V(DSTNRM) .GT. V(LMAXS) .OR.
+ 1 V(STPPAR) .EQ. ZERO)) IV(IRC) = 11
+ IF (V(DST0) .LT. ZERO) GO TO 250
+ I = 0
+ IF ((V(NREDUC) .GT. ZERO .AND. V(NREDUC) .LE. EMAX) .OR.
+ 1 (V(NREDUC) .EQ. ZERO. AND. V(PREDUC) .EQ. ZERO)) I = 2
+ IF (V(STPPAR) .EQ. ZERO .AND. V(RELDX) .LE. V(XCTOL)
+ 1 .AND. GOODX) I = I + 1
+ IF (I .GT. 0) IV(IRC) = I + 6
+C
+C *** CONSIDER RECOMPUTING STEP OF LENGTH V(LMAXS) FOR SINGULAR
+C *** CONVERGENCE TEST.
+C
+ 250 IF (IV(IRC) .GT. 5 .AND. IV(IRC) .NE. 12) GO TO 999
+ IF (V(STPPAR) .EQ. ZERO) GO TO 999
+ IF (V(DSTNRM) .GT. V(LMAXS)) GO TO 260
+ IF (V(PREDUC) .GE. EMAXS) GO TO 999
+ IF (V(DST0) .LE. ZERO) GO TO 270
+ IF (HALF * V(DST0) .LE. V(LMAXS)) GO TO 999
+ GO TO 270
+ 260 IF (HALF * V(DSTNRM) .LE. V(LMAXS)) GO TO 999
+ XMAX = V(LMAXS) / V(DSTNRM)
+ IF (XMAX * (TWO - XMAX) * V(PREDUC) .GE. EMAXS) GO TO 999
+ 270 IF (V(NREDUC) .LT. ZERO) GO TO 290
+C
+C *** RECOMPUTE V(PREDUC) FOR USE IN SINGULAR CONVERGENCE TEST ***
+C
+ V(GTSLST) = V(GTSTEP)
+ V(DSTSAV) = V(DSTNRM)
+ IF (IV(IRC) .EQ. 12) V(DSTSAV) = -V(DSTSAV)
+ V(PLSTGD) = V(PREDUC)
+ I = IV(RESTOR)
+ IV(RESTOR) = 2
+ IF (I .EQ. 3) IV(RESTOR) = 0
+ IV(IRC) = 6
+ GO TO 999
+C
+C *** PERFORM SINGULAR CONVERGENCE TEST WITH RECOMPUTED V(PREDUC) ***
+C
+ 280 V(GTSTEP) = V(GTSLST)
+ V(DSTNRM) = DABS(V(DSTSAV))
+ IV(IRC) = IV(XIRC)
+ IF (V(DSTSAV) .LE. ZERO) IV(IRC) = 12
+ V(NREDUC) = -V(PREDUC)
+ V(PREDUC) = V(PLSTGD)
+ IV(RESTOR) = 3
+ 290 IF (-V(NREDUC) .LE. V(SCTOL) * DABS(V(F0))) IV(IRC) = 11
+C
+ 999 RETURN
+C
+C *** LAST LINE OF DA7SST FOLLOWS ***
+ END
+ SUBROUTINE I7SHFT(N, K, X)
+C
+C *** SHIFT X(K),...,X(N) LEFT CIRCULARLY ONE POSITION IF K .GT. 0.
+C *** SHIFT X(-K),...,X(N) RIGHT CIRCULARLY ONE POSITION IF K .LT. 0.
+C
+ INTEGER N, K
+ INTEGER X(N)
+C
+ INTEGER I, II, K1, NM1, T
+C
+ IF (K .LT. 0) GO TO 20
+ IF (K .GE. N) GO TO 999
+ NM1 = N - 1
+ T = X(K)
+ DO 10 I = K, NM1
+ 10 X(I) = X(I+1)
+ X(N) = T
+ GO TO 999
+C
+ 20 K1 = -K
+ IF (K1 .GE. N) GO TO 999
+ T = X(N)
+ NM1 = N - K1
+ DO 30 II = 1, NM1
+ I = N - II
+ X(I+1) = X(I)
+ 30 CONTINUE
+ X(K1) = T
+ 999 RETURN
+C *** LAST LINE OF I7SHFT FOLLOWS ***
+ END
+ SUBROUTINE S7ETR(M,N,INDROW,JPNTR,INDCOL,IPNTR,IWA)
+ INTEGER M,N
+ INTEGER INDROW(1),JPNTR(1),INDCOL(1),IPNTR(1),IWA(M)
+C **********
+C
+C SUBROUTINE S7ETR
+C
+C GIVEN A COLUMN-ORIENTED DEFINITION OF THE SPARSITY PATTERN
+C OF AN M BY N MATRIX A, THIS SUBROUTINE DETERMINES A
+C ROW-ORIENTED DEFINITION OF THE SPARSITY PATTERN OF A.
+C
+C ON INPUT THE COLUMN-ORIENTED DEFINITION IS SPECIFIED BY
+C THE ARRAYS INDROW AND JPNTR. ON OUTPUT THE ROW-ORIENTED
+C DEFINITION IS SPECIFIED BY THE ARRAYS INDCOL AND IPNTR.
+C
+C THE SUBROUTINE STATEMENT IS
+C
+C SUBROUTINE S7ETR(M,N,INDROW,JPNTR,INDCOL,IPNTR,IWA)
+C
+C WHERE
+C
+C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C OF ROWS OF A.
+C
+C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C OF COLUMNS OF A.
+C
+C INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW
+C INDICES FOR THE NON-ZEROES IN THE MATRIX A.
+C
+C JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH
+C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW.
+C THE ROW INDICES FOR COLUMN J ARE
+C
+C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1.
+C
+C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO
+C ELEMENTS OF THE MATRIX A.
+C
+C INDCOL IS AN INTEGER OUTPUT ARRAY WHICH CONTAINS THE
+C COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A.
+C
+C IPNTR IS AN INTEGER OUTPUT ARRAY OF LENGTH M + 1 WHICH
+C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL.
+C THE COLUMN INDICES FOR ROW I ARE
+C
+C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1.
+C
+C NOTE THAT IPNTR(1) IS SET TO 1 AND THAT IPNTR(M+1)-1 IS
+C THEN THE NUMBER OF NON-ZERO ELEMENTS OF THE MATRIX A.
+C
+C IWA IS AN INTEGER WORK ARRAY OF LENGTH M.
+C
+C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982.
+C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE
+C
+C **********
+ INTEGER IR,JCOL,JP,JPL,JPU,L,NNZ
+C
+C DETERMINE THE NUMBER OF NON-ZEROES IN THE ROWS.
+C
+ DO 10 IR = 1, M
+ IWA(IR) = 0
+ 10 CONTINUE
+ NNZ = JPNTR(N+1) - 1
+ DO 20 JP = 1, NNZ
+ IR = INDROW(JP)
+ IWA(IR) = IWA(IR) + 1
+ 20 CONTINUE
+C
+C SET POINTERS TO THE START OF THE ROWS IN INDCOL.
+C
+ IPNTR(1) = 1
+ DO 30 IR = 1, M
+ IPNTR(IR+1) = IPNTR(IR) + IWA(IR)
+ IWA(IR) = IPNTR(IR)
+ 30 CONTINUE
+C
+C FILL INDCOL.
+C
+ DO 60 JCOL = 1, N
+ JPL = JPNTR(JCOL)
+ JPU = JPNTR(JCOL+1) - 1
+ IF (JPU .LT. JPL) GO TO 50
+ DO 40 JP = JPL, JPU
+ IR = INDROW(JP)
+ L = IWA(IR)
+ INDCOL(L) = JCOL
+ IWA(IR) = IWA(IR) + 1
+ 40 CONTINUE
+ 50 CONTINUE
+ 60 CONTINUE
+ RETURN
+C
+C LAST CARD OF SUBROUTINE S7ETR.
+C
+ END
+ SUBROUTINE DG7QSB(B, D, DIHDI, G, IPIV, IPIV1, IPIV2, KA, L, LV,
+ 1 P, P0, PC, STEP, TD, TG, V, W, X, X0)
+C
+C *** COMPUTE HEURISTIC BOUNDED NEWTON STEP ***
+C
+ INTEGER KA, LV, P, P0, PC
+ INTEGER IPIV(P), IPIV1(P), IPIV2(P)
+ DOUBLE PRECISION B(2,P), D(P), DIHDI(*), G(P), L(*),
+ 1 STEP(P,2), TD(P), TG(P), V(LV), W(P), X0(P), X(P)
+C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2)
+C
+ DOUBLE PRECISION DD7TPR
+ EXTERNAL DD7TPR,DG7QTS, DS7BQN, DS7IPR,DV7CPY, DV7IPR,
+ 1 DV7SCP, DV7VMP
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER K, KB, KINIT, NS, P1, P10
+ DOUBLE PRECISION DS0, NRED, PRED, RAD
+ DOUBLE PRECISION ZERO
+C
+C *** V SUBSCRIPTS ***
+C
+ INTEGER DST0, DSTNRM, GTSTEP, NREDUC, PREDUC, RADIUS
+C
+ PARAMETER (DST0=3, DSTNRM=2, GTSTEP=4, NREDUC=6, PREDUC=7,
+ 1 RADIUS=8)
+ DATA ZERO/0.D+0/
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ P1 = PC
+ IF (KA .LT. 0) GO TO 10
+ NRED = V(NREDUC)
+ DS0 = V(DST0)
+ GO TO 20
+ 10 P0 = 0
+ KA = -1
+C
+ 20 KINIT = -1
+ IF (P0 .EQ. P1) KINIT = KA
+ CALL DV7CPY(P, X, X0)
+ PRED = ZERO
+ RAD = V(RADIUS)
+ KB = -1
+ V(DSTNRM) = ZERO
+ IF (P1 .GT. 0) GO TO 30
+ NRED = ZERO
+ DS0 = ZERO
+ CALL DV7SCP(P, STEP, ZERO)
+ GO TO 60
+C
+ 30 CALL DV7CPY(P, TD, D)
+ CALL DV7IPR(P, IPIV, TD)
+ CALL DV7VMP(P, TG, G, D, -1)
+ CALL DV7IPR(P, IPIV, TG)
+ 40 K = KINIT
+ KINIT = -1
+ V(RADIUS) = RAD - V(DSTNRM)
+ CALL DG7QTS(TD, TG, DIHDI, K, L, P1, STEP, V, W)
+ P0 = P1
+ IF (KA .GE. 0) GO TO 50
+ NRED = V(NREDUC)
+ DS0 = V(DST0)
+C
+ 50 KA = K
+ V(RADIUS) = RAD
+ P10 = P1
+ CALL DS7BQN(B, D, STEP(1,2), IPIV, IPIV1, IPIV2, KB, L, LV,
+ 1 NS, P, P1, STEP, TD, TG, V, W, X, X0)
+ IF (NS .GT. 0) CALL DS7IPR(P10, IPIV1, DIHDI)
+ PRED = PRED + V(PREDUC)
+ IF (NS .NE. 0) P0 = 0
+ IF (KB .LE. 0) GO TO 40
+C
+ 60 V(DST0) = DS0
+ V(NREDUC) = NRED
+ V(PREDUC) = PRED
+ V(GTSTEP) = DD7TPR(P, G, STEP)
+C
+ RETURN
+C *** LAST LINE OF DG7QSB FOLLOWS ***
+ END
+ DOUBLE PRECISION FUNCTION DL7SVX(P, L, X, Y)
+C
+C *** ESTIMATE LARGEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER P
+ DOUBLE PRECISION L(*), X(P), Y(P)
+C DIMENSION L(P*(P+1)/2)
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+C *** PURPOSE ***
+C
+C THIS FUNCTION RETURNS A GOOD UNDER-ESTIMATE OF THE LARGEST
+C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L.
+C
+C *** PARAMETER DESCRIPTION ***
+C
+C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX.
+C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E.
+C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC.
+C X (OUT) IF DL7SVX RETURNS A POSITIVE VALUE, THEN X = (L**T)*Y IS AN
+C (UNNORMALIZED) APPROXIMATE RIGHT SINGULAR VECTOR
+C CORRESPONDING TO THE LARGEST SINGULAR VALUE. THIS
+C APPROXIMATION MAY BE CRUDE.
+C Y (OUT) IF DL7SVX RETURNS A POSITIVE VALUE, THEN Y = L*X IS A
+C NORMALIZED APPROXIMATE LEFT SINGULAR VECTOR CORRESPOND-
+C ING TO THE LARGEST SINGULAR VALUE. THIS APPROXIMATION
+C MAY BE VERY CRUDE. THE CALLER MAY PASS THE SAME VECTOR
+C FOR X AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE X
+C OVER-WRITES Y.
+C
+C *** ALGORITHM NOTES ***
+C
+C THE ALGORITHM IS BASED ON ANALOGY WITH (1). IT USES A
+C RANDOM NUMBER GENERATOR PROPOSED IN (4), WHICH PASSES THE
+C SPECTRAL TEST WITH FLYING COLORS -- SEE (2) AND (3).
+C
+C *** SUBROUTINES AND FUNCTIONS CALLED ***
+C
+C DV2NRM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR.
+C
+C *** REFERENCES ***
+C
+C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977),
+C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT
+C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY.
+C
+C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL
+C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW,
+C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV.
+C
+C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2
+C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS.
+C
+C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER
+C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18,
+C PP. 586-593.
+C
+C *** HISTORY ***
+C
+C DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978).
+C
+C *** GENERAL ***
+C
+C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
+C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
+C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER I, IX, J, JI, JJ, JJJ, JM1, J0, PM1, PPLUS1
+ DOUBLE PRECISION B, BLJI, SMINUS, SPLUS, T, YI
+C
+C *** CONSTANTS ***
+C
+ DOUBLE PRECISION HALF, ONE, R9973, ZERO
+C
+C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
+C
+ DOUBLE PRECISION DD7TPR, DV2NRM
+ EXTERNAL DD7TPR, DV2NRM,DV2AXY
+C
+ PARAMETER (HALF=0.5D+0, ONE=1.D+0, R9973=9973.D+0, ZERO=0.D+0)
+C
+C *** BODY ***
+C
+ IX = 2
+ PPLUS1 = P + 1
+ PM1 = P - 1
+C
+C *** FIRST INITIALIZE X TO PARTIAL SUMS ***
+C
+ J0 = P*PM1/2
+ JJ = J0 + P
+ IX = MOD(3432*IX, 9973)
+ B = HALF*(ONE + DBLE(IX)/R9973)
+ X(P) = B * L(JJ)
+ IF (P .LE. 1) GO TO 40
+ DO 10 I = 1, PM1
+ JI = J0 + I
+ X(I) = B * L(JI)
+ 10 CONTINUE
+C
+C *** COMPUTE X = (L**T)*B, WHERE THE COMPONENTS OF B HAVE RANDOMLY
+C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE.
+C
+C DO J = P-1 TO 1 BY -1...
+ DO 30 JJJ = 1, PM1
+ J = P - JJJ
+C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J
+C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I.
+ IX = MOD(3432*IX, 9973)
+ B = HALF*(ONE + DBLE(IX)/R9973)
+ JM1 = J - 1
+ J0 = J*JM1/2
+ SPLUS = ZERO
+ SMINUS = ZERO
+ DO 20 I = 1, J
+ JI = J0 + I
+ BLJI = B * L(JI)
+ SPLUS = SPLUS + DABS(BLJI + X(I))
+ SMINUS = SMINUS + DABS(BLJI - X(I))
+ 20 CONTINUE
+ IF (SMINUS .GT. SPLUS) B = -B
+ X(J) = ZERO
+C *** UPDATE PARTIAL SUMS ***
+ CALL DV2AXY(J, X, B, L(J0+1), X)
+ 30 CONTINUE
+C
+C *** NORMALIZE X ***
+C
+ 40 T = DV2NRM(P, X)
+ IF (T .LE. ZERO) GO TO 80
+ T = ONE / T
+ DO 50 I = 1, P
+ 50 X(I) = T*X(I)
+C
+C *** COMPUTE L*X = Y AND RETURN SVMAX = TWONORM(Y) ***
+C
+ DO 60 JJJ = 1, P
+ J = PPLUS1 - JJJ
+ JI = J*(J-1)/2 + 1
+ Y(J) = DD7TPR(J, L(JI), X)
+ 60 CONTINUE
+C
+C *** NORMALIZE Y AND SET X = (L**T)*Y ***
+C
+ T = ONE / DV2NRM(P, Y)
+ JI = 1
+ DO 70 I = 1, P
+ YI = T * Y(I)
+ X(I) = ZERO
+ CALL DV2AXY(I, X, YI, L(JI), X)
+ JI = JI + I
+ 70 CONTINUE
+ DL7SVX = DV2NRM(P, X)
+ GO TO 999
+C
+ 80 DL7SVX = ZERO
+C
+ 999 RETURN
+C *** LAST CARD OF DL7SVX FOLLOWS ***
+ END
+ SUBROUTINE DD7DUP(D, HDIAG, IV, LIV, LV, N, V)
+C
+C *** UPDATE SCALE VECTOR D FOR DMNH ***
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER LIV, LV, N
+ INTEGER IV(LIV)
+ DOUBLE PRECISION D(N), HDIAG(N), V(LV)
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER DTOLI, D0I, I
+ DOUBLE PRECISION T, VDFAC
+C
+C *** INTRINSIC FUNCTIONS ***
+C/+
+ DOUBLE PRECISION DSQRT
+C/
+C *** SUBSCRIPTS FOR IV AND V ***
+C
+ INTEGER DFAC, DTOL, DTYPE, NITER
+ PARAMETER (DFAC=41, DTOL=59, DTYPE=16, NITER=31)
+C
+C------------------------------- BODY --------------------------------
+C
+ I = IV(DTYPE)
+ IF (I .EQ. 1) GO TO 10
+ IF (IV(NITER) .GT. 0) GO TO 999
+C
+ 10 DTOLI = IV(DTOL)
+ D0I = DTOLI + N
+ VDFAC = V(DFAC)
+ DO 20 I = 1, N
+ T = DMAX1(DSQRT(DABS(HDIAG(I))), VDFAC*D(I))
+ IF (T .LT. V(DTOLI)) T = DMAX1(V(DTOLI), V(D0I))
+ D(I) = T
+ DTOLI = DTOLI + 1
+ D0I = D0I + 1
+ 20 CONTINUE
+C
+ 999 RETURN
+C *** LAST CARD OF DD7DUP FOLLOWS ***
+ END
+ SUBROUTINE S7RTDT(N,NNZ,INDROW,INDCOL,JPNTR,IWA)
+ INTEGER N,NNZ
+ INTEGER INDROW(NNZ),INDCOL(NNZ),JPNTR(1),IWA(N)
+C **********
+C
+C SUBROUTINE S7RTDT
+C
+C GIVEN THE NON-ZERO ELEMENTS OF AN M BY N MATRIX A IN
+C ARBITRARY ORDER AS SPECIFIED BY THEIR ROW AND COLUMN
+C INDICES, THIS SUBROUTINE PERMUTES THESE ELEMENTS SO
+C THAT THEIR COLUMN INDICES ARE IN NON-DECREASING ORDER.
+C
+C ON INPUT IT IS ASSUMED THAT THE ELEMENTS ARE SPECIFIED IN
+C
+C INDROW(K),INDCOL(K), K = 1,...,NNZ.
+C
+C ON OUTPUT THE ELEMENTS ARE PERMUTED SO THAT INDCOL IS
+C IN NON-DECREASING ORDER. IN ADDITION, THE ARRAY JPNTR
+C IS SET SO THAT THE ROW INDICES FOR COLUMN J ARE
+C
+C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1.
+C
+C NOTE THAT THE VALUE OF M IS NOT NEEDED BY S7RTDT AND IS
+C THEREFORE NOT PRESENT IN THE SUBROUTINE STATEMENT.
+C
+C THE SUBROUTINE STATEMENT IS
+C
+C SUBROUTINE S7RTDT(N,NNZ,INDROW,INDCOL,JPNTR,IWA)
+C
+C WHERE
+C
+C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C OF COLUMNS OF A.
+C
+C NNZ IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C OF NON-ZERO ELEMENTS OF A.
+C
+C INDROW IS AN INTEGER ARRAY OF LENGTH NNZ. ON INPUT INDROW
+C MUST CONTAIN THE ROW INDICES OF THE NON-ZERO ELEMENTS OF A.
+C ON OUTPUT INDROW IS PERMUTED SO THAT THE CORRESPONDING
+C COLUMN INDICES OF INDCOL ARE IN NON-DECREASING ORDER.
+C
+C INDCOL IS AN INTEGER ARRAY OF LENGTH NNZ. ON INPUT INDCOL
+C MUST CONTAIN THE COLUMN INDICES OF THE NON-ZERO ELEMENTS
+C OF A. ON OUTPUT INDCOL IS PERMUTED SO THAT THESE INDICES
+C ARE IN NON-DECREASING ORDER.
+C
+C JPNTR IS AN INTEGER OUTPUT ARRAY OF LENGTH N + 1 WHICH
+C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN THE OUTPUT
+C INDROW. THE ROW INDICES FOR COLUMN J ARE
+C
+C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1.
+C
+C NOTE THAT JPNTR(1) IS SET TO 1 AND THAT JPNTR(N+1)-1
+C IS THEN NNZ.
+C
+C IWA IS AN INTEGER WORK ARRAY OF LENGTH N.
+C
+C SUBPROGRAMS CALLED
+C
+C FORTRAN-SUPPLIED ... MAX0
+C
+C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982.
+C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE
+C
+C **********
+ INTEGER I,J,K,L
+C
+C DETERMINE THE NUMBER OF NON-ZEROES IN THE COLUMNS.
+C
+ DO 10 J = 1, N
+ IWA(J) = 0
+ 10 CONTINUE
+ DO 20 K = 1, NNZ
+ J = INDCOL(K)
+ IWA(J) = IWA(J) + 1
+ 20 CONTINUE
+C
+C SET POINTERS TO THE START OF THE COLUMNS IN INDROW.
+C
+ JPNTR(1) = 1
+ DO 30 J = 1, N
+ JPNTR(J+1) = JPNTR(J) + IWA(J)
+ IWA(J) = JPNTR(J)
+ 30 CONTINUE
+ K = 1
+C
+C BEGIN IN-PLACE SORT.
+C
+ 40 CONTINUE
+ J = INDCOL(K)
+ IF (K .LT. JPNTR(J) .OR. K .GE. JPNTR(J+1)) GO TO 50
+C
+C CURRENT ELEMENT IS IN POSITION. NOW EXAMINE THE
+C NEXT ELEMENT OR THE FIRST UN-SORTED ELEMENT IN
+C THE J-TH GROUP.
+C
+ K = MAX0(K+1,IWA(J))
+ GO TO 60
+ 50 CONTINUE
+C
+C CURRENT ELEMENT IS NOT IN POSITION. PLACE ELEMENT
+C IN POSITION AND MAKE THE DISPLACED ELEMENT THE
+C CURRENT ELEMENT.
+C
+ L = IWA(J)
+ IWA(J) = IWA(J) + 1
+ I = INDROW(K)
+ INDROW(K) = INDROW(L)
+ INDCOL(K) = INDCOL(L)
+ INDROW(L) = I
+ INDCOL(L) = J
+ 60 CONTINUE
+ IF (K .LE. NNZ) GO TO 40
+ RETURN
+C
+C LAST CARD OF SUBROUTINE S7RTDT.
+C
+ END
+ SUBROUTINE DL7SRT(N1, N, L, A, IRC)
+C
+C *** COMPUTE ROWS N1 THROUGH N OF THE CHOLESKY FACTOR L OF
+C *** A = L*(L**T), WHERE L AND THE LOWER TRIANGLE OF A ARE BOTH
+C *** STORED COMPACTLY BY ROWS (AND MAY OCCUPY THE SAME STORAGE).
+C *** IRC = 0 MEANS ALL WENT WELL. IRC = J MEANS THE LEADING
+C *** PRINCIPAL J X J SUBMATRIX OF A IS NOT POSITIVE DEFINITE --
+C *** AND L(J*(J+1)/2) CONTAINS THE (NONPOS.) REDUCED J-TH DIAGONAL.
+C
+C *** PARAMETERS ***
+C
+ INTEGER N1, N, IRC
+ DOUBLE PRECISION L(*), A(*)
+C DIMENSION L(N*(N+1)/2), A(N*(N+1)/2)
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER I, IJ, IK, IM1, I0, J, JK, JM1, J0, K
+ DOUBLE PRECISION T, TD, ZERO
+C
+C *** INTRINSIC FUNCTIONS ***
+C/+
+ DOUBLE PRECISION DSQRT
+C/
+ PARAMETER (ZERO=0.D+0)
+C
+C *** BODY ***
+C
+ I0 = N1 * (N1 - 1) / 2
+ DO 50 I = N1, N
+ TD = ZERO
+ IF (I .EQ. 1) GO TO 40
+ J0 = 0
+ IM1 = I - 1
+ DO 30 J = 1, IM1
+ T = ZERO
+ IF (J .EQ. 1) GO TO 20
+ JM1 = J - 1
+ DO 10 K = 1, JM1
+ IK = I0 + K
+ JK = J0 + K
+ T = T + L(IK)*L(JK)
+ 10 CONTINUE
+ 20 IJ = I0 + J
+ J0 = J0 + J
+ T = (A(IJ) - T) / L(J0)
+ L(IJ) = T
+ TD = TD + T*T
+ 30 CONTINUE
+ 40 I0 = I0 + I
+ T = A(I0) - TD
+ IF (T .LE. ZERO) GO TO 60
+ L(I0) = DSQRT(T)
+ 50 CONTINUE
+C
+ IRC = 0
+ GO TO 999
+C
+ 60 L(I0) = T
+ IRC = I
+C
+ 999 RETURN
+C
+C *** LAST CARD OF DL7SRT ***
+ END
+ DOUBLE PRECISION FUNCTION DL7SVN(P, L, X, Y)
+C
+C *** ESTIMATE SMALLEST SING. VALUE OF PACKED LOWER TRIANG. MATRIX L
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER P
+ DOUBLE PRECISION L(*), X(P), Y(P)
+C DIMENSION L(P*(P+1)/2)
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+C *** PURPOSE ***
+C
+C THIS FUNCTION RETURNS A GOOD OVER-ESTIMATE OF THE SMALLEST
+C SINGULAR VALUE OF THE PACKED LOWER TRIANGULAR MATRIX L.
+C
+C *** PARAMETER DESCRIPTION ***
+C
+C P (IN) = THE ORDER OF L. L IS A P X P LOWER TRIANGULAR MATRIX.
+C L (IN) = ARRAY HOLDING THE ELEMENTS OF L IN ROW ORDER, I.E.
+C L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), L(3,3), ETC.
+C X (OUT) IF DL7SVN RETURNS A POSITIVE VALUE, THEN X IS A NORMALIZED
+C APPROXIMATE LEFT SINGULAR VECTOR CORRESPONDING TO THE
+C SMALLEST SINGULAR VALUE. THIS APPROXIMATION MAY BE VERY
+C CRUDE. IF DL7SVN RETURNS ZERO, THEN SOME COMPONENTS OF X
+C ARE ZERO AND THE REST RETAIN THEIR INPUT VALUES.
+C Y (OUT) IF DL7SVN RETURNS A POSITIVE VALUE, THEN Y = (L**-1)*X IS AN
+C UNNORMALIZED APPROXIMATE RIGHT SINGULAR VECTOR CORRESPOND-
+C ING TO THE SMALLEST SINGULAR VALUE. THIS APPROXIMATION
+C MAY BE CRUDE. IF DL7SVN RETURNS ZERO, THEN Y RETAINS ITS
+C INPUT VALUE. THE CALLER MAY PASS THE SAME VECTOR FOR X
+C AND Y (NONSTANDARD FORTRAN USAGE), IN WHICH CASE Y OVER-
+C WRITES X (FOR NONZERO DL7SVN RETURNS).
+C
+C *** ALGORITHM NOTES ***
+C
+C THE ALGORITHM IS BASED ON (1), WITH THE ADDITIONAL PROVISION THAT
+C DL7SVN = 0 IS RETURNED IF THE SMALLEST DIAGONAL ELEMENT OF L
+C (IN MAGNITUDE) IS NOT MORE THAN THE UNIT ROUNDOFF TIMES THE
+C LARGEST. THE ALGORITHM USES A RANDOM NUMBER GENERATOR PROPOSED
+C IN (4), WHICH PASSES THE SPECTRAL TEST WITH FLYING COLORS -- SEE
+C (2) AND (3).
+C
+C *** SUBROUTINES AND FUNCTIONS CALLED ***
+C
+C DV2NRM - FUNCTION, RETURNS THE 2-NORM OF A VECTOR.
+C
+C *** REFERENCES ***
+C
+C (1) CLINE, A., MOLER, C., STEWART, G., AND WILKINSON, J.H.(1977),
+C AN ESTIMATE FOR THE CONDITION NUMBER OF A MATRIX, REPORT
+C TM-310, APPLIED MATH. DIV., ARGONNE NATIONAL LABORATORY.
+C
+C (2) HOAGLIN, D.C. (1976), THEORETICAL PROPERTIES OF CONGRUENTIAL
+C RANDOM-NUMBER GENERATORS -- AN EMPIRICAL VIEW,
+C MEMORANDUM NS-340, DEPT. OF STATISTICS, HARVARD UNIV.
+C
+C (3) KNUTH, D.E. (1969), THE ART OF COMPUTER PROGRAMMING, VOL. 2
+C (SEMINUMERICAL ALGORITHMS), ADDISON-WESLEY, READING, MASS.
+C
+C (4) SMITH, C.S. (1971), MULTIPLICATIVE PSEUDO-RANDOM NUMBER
+C GENERATORS WITH PRIME MODULUS, J. ASSOC. COMPUT. MACH. 18,
+C PP. 586-593.
+C
+C *** HISTORY ***
+C
+C DESIGNED AND CODED BY DAVID M. GAY (WINTER 1977/SUMMER 1978).
+C
+C *** GENERAL ***
+C
+C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
+C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
+C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER I, II, IX, J, JI, JJ, JJJ, JM1, J0, PM1
+ DOUBLE PRECISION B, SMINUS, SPLUS, T, XMINUS, XPLUS
+C
+C *** CONSTANTS ***
+C
+ DOUBLE PRECISION HALF, ONE, R9973, ZERO
+C
+C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
+C
+ DOUBLE PRECISION DD7TPR, DV2NRM
+ EXTERNAL DD7TPR, DV2NRM,DV2AXY
+C
+ PARAMETER (HALF=0.5D+0, ONE=1.D+0, R9973=9973.D+0, ZERO=0.D+0)
+C
+C *** BODY ***
+C
+ IX = 2
+ PM1 = P - 1
+C
+C *** FIRST CHECK WHETHER TO RETURN DL7SVN = 0 AND INITIALIZE X ***
+C
+ II = 0
+ J0 = P*PM1/2
+ JJ = J0 + P
+ IF (L(JJ) .EQ. ZERO) GO TO 110
+ IX = MOD(3432*IX, 9973)
+ B = HALF*(ONE + DBLE(IX)/R9973)
+ XPLUS = B / L(JJ)
+ X(P) = XPLUS
+ IF (P .LE. 1) GO TO 60
+ DO 10 I = 1, PM1
+ II = II + I
+ IF (L(II) .EQ. ZERO) GO TO 110
+ JI = J0 + I
+ X(I) = XPLUS * L(JI)
+ 10 CONTINUE
+C
+C *** SOLVE (L**T)*X = B, WHERE THE COMPONENTS OF B HAVE RANDOMLY
+C *** CHOSEN MAGNITUDES IN (.5,1) WITH SIGNS CHOSEN TO MAKE X LARGE.
+C
+C DO J = P-1 TO 1 BY -1...
+ DO 50 JJJ = 1, PM1
+ J = P - JJJ
+C *** DETERMINE X(J) IN THIS ITERATION. NOTE FOR I = 1,2,...,J
+C *** THAT X(I) HOLDS THE CURRENT PARTIAL SUM FOR ROW I.
+ IX = MOD(3432*IX, 9973)
+ B = HALF*(ONE + DBLE(IX)/R9973)
+ XPLUS = (B - X(J))
+ XMINUS = (-B - X(J))
+ SPLUS = DABS(XPLUS)
+ SMINUS = DABS(XMINUS)
+ JM1 = J - 1
+ J0 = J*JM1/2
+ JJ = J0 + J
+ XPLUS = XPLUS/L(JJ)
+ XMINUS = XMINUS/L(JJ)
+ IF (JM1 .EQ. 0) GO TO 30
+ DO 20 I = 1, JM1
+ JI = J0 + I
+ SPLUS = SPLUS + DABS(X(I) + L(JI)*XPLUS)
+ SMINUS = SMINUS + DABS(X(I) + L(JI)*XMINUS)
+ 20 CONTINUE
+ 30 IF (SMINUS .GT. SPLUS) XPLUS = XMINUS
+ X(J) = XPLUS
+C *** UPDATE PARTIAL SUMS ***
+ IF (JM1 .GT. 0) CALL DV2AXY(JM1, X, XPLUS, L(J0+1), X)
+ 50 CONTINUE
+C
+C *** NORMALIZE X ***
+C
+ 60 T = ONE/DV2NRM(P, X)
+ DO 70 I = 1, P
+ 70 X(I) = T*X(I)
+C
+C *** SOLVE L*Y = X AND RETURN DL7SVN = 1/TWONORM(Y) ***
+C
+ DO 100 J = 1, P
+ JM1 = J - 1
+ J0 = J*JM1/2
+ JJ = J0 + J
+ T = ZERO
+ IF (JM1 .GT. 0) T = DD7TPR(JM1, L(J0+1), Y)
+ Y(J) = (X(J) - T) / L(JJ)
+ 100 CONTINUE
+C
+ DL7SVN = ONE/DV2NRM(P, Y)
+ GO TO 999
+C
+ 110 DL7SVN = ZERO
+ 999 RETURN
+C *** LAST CARD OF DL7SVN FOLLOWS ***
+ END
+ SUBROUTINE DS7LVM(P, Y, S, X)
+C
+C *** SET Y = S * X, S = P X P SYMMETRIC MATRIX. ***
+C *** LOWER TRIANGLE OF S STORED ROWWISE. ***
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER P
+ DOUBLE PRECISION S(*), X(P), Y(P)
+C DIMENSION S(P*(P+1)/2)
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER I, IM1, J, K
+ DOUBLE PRECISION XI
+C
+C *** NO INTRINSIC FUNCTIONS ***
+C
+C *** EXTERNAL FUNCTION ***
+C
+ DOUBLE PRECISION DD7TPR
+ EXTERNAL DD7TPR
+C
+C-----------------------------------------------------------------------
+C
+ J = 1
+ DO 10 I = 1, P
+ Y(I) = DD7TPR(I, S(J), X)
+ J = J + I
+ 10 CONTINUE
+C
+ IF (P .LE. 1) GO TO 999
+ J = 1
+ DO 40 I = 2, P
+ XI = X(I)
+ IM1 = I - 1
+ J = J + 1
+ DO 30 K = 1, IM1
+ Y(K) = Y(K) + S(J)*XI
+ J = J + 1
+ 30 CONTINUE
+ 40 CONTINUE
+C
+ 999 RETURN
+C *** LAST CARD OF DS7LVM FOLLOWS ***
+ END
+ DOUBLE PRECISION FUNCTION DH2RFG(A, B, X, Y, Z)
+C
+C *** DETERMINE X, Y, Z SO I + (1,Z)**T * (X,Y) IS A 2X2
+C *** HOUSEHOLDER REFLECTION SENDING (A,B)**T INTO (C,0)**T,
+C *** WHERE C = -SIGN(A)*SQRT(A**2 + B**2) IS THE VALUE DH2RFG
+C *** RETURNS.
+C
+ DOUBLE PRECISION A, B, X, Y, Z
+C
+ DOUBLE PRECISION A1, B1, C, T
+C/+
+ DOUBLE PRECISION DSQRT
+C/
+ DOUBLE PRECISION ZERO
+ DATA ZERO/0.D+0/
+C
+C *** BODY ***
+C
+ IF (B .NE. ZERO) GO TO 10
+ X = ZERO
+ Y = ZERO
+ Z = ZERO
+ DH2RFG = A
+ GO TO 999
+ 10 T = DABS(A) + DABS(B)
+ A1 = A / T
+ B1 = B / T
+ C = DSQRT(A1**2 + B1**2)
+ IF (A1 .GT. ZERO) C = -C
+ A1 = A1 - C
+ Z = B1 / A1
+ X = A1 / C
+ Y = B1 / C
+ DH2RFG = T * C
+ 999 RETURN
+C *** LAST LINE OF DH2RFG FOLLOWS ***
+ END
+ SUBROUTINE DL7NVR(N, LIN, L)
+C
+C *** COMPUTE LIN = L**-1, BOTH N X N LOWER TRIANG. STORED ***
+C *** COMPACTLY BY ROWS. LIN AND L MAY SHARE THE SAME STORAGE. ***
+C
+C *** PARAMETERS ***
+C
+ INTEGER N
+ DOUBLE PRECISION L(*), LIN(*)
+C DIMENSION L(N*(N+1)/2), LIN(N*(N+1)/2)
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER I, II, IM1, JJ, J0, J1, K, K0, NP1
+ DOUBLE PRECISION ONE, T, ZERO
+ PARAMETER (ONE=1.D+0, ZERO=0.D+0)
+C
+C *** BODY ***
+C
+ NP1 = N + 1
+ J0 = N*NP1/2
+ DO 30 II = 1, N
+ I = NP1 - II
+ LIN(J0) = ONE/L(J0)
+ IF (I .LE. 1) GO TO 999
+ J1 = J0
+ IM1 = I - 1
+ DO 20 JJ = 1, IM1
+ T = ZERO
+ J0 = J1
+ K0 = J1 - JJ
+ DO 10 K = 1, JJ
+ T = T - L(K0)*LIN(J0)
+ J0 = J0 - 1
+ K0 = K0 + K - I
+ 10 CONTINUE
+ LIN(J0) = T/L(K0)
+ 20 CONTINUE
+ J0 = J0 - 1
+ 30 CONTINUE
+ 999 RETURN
+C *** LAST CARD OF DL7NVR FOLLOWS ***
+ END
+ SUBROUTINE DD7DOG(DIG, LV, N, NWTSTP, STEP, V)
+C
+C *** COMPUTE DOUBLE DOGLEG STEP ***
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER LV, N
+ DOUBLE PRECISION DIG(N), NWTSTP(N), STEP(N), V(LV)
+C
+C *** PURPOSE ***
+C
+C THIS SUBROUTINE COMPUTES A CANDIDATE STEP (FOR USE IN AN UNCON-
+C STRAINED MINIMIZATION CODE) BY THE DOUBLE DOGLEG ALGORITHM OF
+C DENNIS AND MEI (REF. 1), WHICH IS A VARIATION ON POWELL*S DOGLEG
+C SCHEME (REF. 2, P. 95).
+C
+C-------------------------- PARAMETER USAGE --------------------------
+C
+C DIG (INPUT) DIAG(D)**-2 * G -- SEE ALGORITHM NOTES.
+C G (INPUT) THE CURRENT GRADIENT VECTOR.
+C LV (INPUT) LENGTH OF V.
+C N (INPUT) NUMBER OF COMPONENTS IN DIG, G, NWTSTP, AND STEP.
+C NWTSTP (INPUT) NEGATIVE NEWTON STEP -- SEE ALGORITHM NOTES.
+C STEP (OUTPUT) THE COMPUTED STEP.
+C V (I/O) VALUES ARRAY, THE FOLLOWING COMPONENTS OF WHICH ARE
+C USED HERE...
+C V(BIAS) (INPUT) BIAS FOR RELAXED NEWTON STEP, WHICH IS V(BIAS) OF
+C THE WAY FROM THE FULL NEWTON TO THE FULLY RELAXED NEWTON
+C STEP. RECOMMENDED VALUE = 0.8 .
+C V(DGNORM) (INPUT) 2-NORM OF DIAG(D)**-1 * G -- SEE ALGORITHM NOTES.
+C V(DSTNRM) (OUTPUT) 2-NORM OF DIAG(D) * STEP, WHICH IS V(RADIUS)
+C UNLESS V(STPPAR) = 0 -- SEE ALGORITHM NOTES.
+C V(DST0) (INPUT) 2-NORM OF DIAG(D) * NWTSTP -- SEE ALGORITHM NOTES.
+C V(GRDFAC) (OUTPUT) THE COEFFICIENT OF DIG IN THE STEP RETURNED --
+C STEP(I) = V(GRDFAC)*DIG(I) + V(NWTFAC)*NWTSTP(I).
+C V(GTHG) (INPUT) SQUARE-ROOT OF (DIG**T) * (HESSIAN) * DIG -- SEE
+C ALGORITHM NOTES.
+C V(GTSTEP) (OUTPUT) INNER PRODUCT BETWEEN G AND STEP.
+C V(NREDUC) (OUTPUT) FUNCTION REDUCTION PREDICTED FOR THE FULL NEWTON
+C STEP.
+C V(NWTFAC) (OUTPUT) THE COEFFICIENT OF NWTSTP IN THE STEP RETURNED --
+C SEE V(GRDFAC) ABOVE.
+C V(PREDUC) (OUTPUT) FUNCTION REDUCTION PREDICTED FOR THE STEP RETURNED.
+C V(RADIUS) (INPUT) THE TRUST REGION RADIUS. D TIMES THE STEP RETURNED
+C HAS 2-NORM V(RADIUS) UNLESS V(STPPAR) = 0.
+C V(STPPAR) (OUTPUT) CODE TELLING HOW STEP WAS COMPUTED... 0 MEANS A
+C FULL NEWTON STEP. BETWEEN 0 AND 1 MEANS V(STPPAR) OF THE
+C WAY FROM THE NEWTON TO THE RELAXED NEWTON STEP. BETWEEN
+C 1 AND 2 MEANS A TRUE DOUBLE DOGLEG STEP, V(STPPAR) - 1 OF
+C THE WAY FROM THE RELAXED NEWTON TO THE CAUCHY STEP.
+C GREATER THAN 2 MEANS 1 / (V(STPPAR) - 1) TIMES THE CAUCHY
+C STEP.
+C
+C------------------------------- NOTES -------------------------------
+C
+C *** ALGORITHM NOTES ***
+C
+C LET G AND H BE THE CURRENT GRADIENT AND HESSIAN APPROXIMA-
+C TION RESPECTIVELY AND LET D BE THE CURRENT SCALE VECTOR. THIS
+C ROUTINE ASSUMES DIG = DIAG(D)**-2 * G AND NWTSTP = H**-1 * G.
+C THE STEP COMPUTED IS THE SAME ONE WOULD GET BY REPLACING G AND H
+C BY DIAG(D)**-1 * G AND DIAG(D)**-1 * H * DIAG(D)**-1,
+C COMPUTING STEP, AND TRANSLATING STEP BACK TO THE ORIGINAL
+C VARIABLES, I.E., PREMULTIPLYING IT BY DIAG(D)**-1.
+C
+C *** REFERENCES ***
+C
+C 1. DENNIS, J.E., AND MEI, H.H.W. (1979), TWO NEW UNCONSTRAINED OPTI-
+C MIZATION ALGORITHMS WHICH USE FUNCTION AND GRADIENT
+C VALUES, J. OPTIM. THEORY APPLIC. 28, PP. 453-482.
+C 2. POWELL, M.J.D. (1970), A HYBRID METHOD FOR NON-LINEAR EQUATIONS,
+C IN NUMERICAL METHODS FOR NON-LINEAR EQUATIONS, EDITED BY
+C P. RABINOWITZ, GORDON AND BREACH, LONDON.
+C
+C *** GENERAL ***
+C
+C CODED BY DAVID M. GAY.
+C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
+C BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS-7600324 AND
+C MCS-7906671.
+C
+C------------------------ EXTERNAL QUANTITIES ------------------------
+C
+C *** INTRINSIC FUNCTIONS ***
+C/+
+ DOUBLE PRECISION DSQRT
+C/
+C-------------------------- LOCAL VARIABLES --------------------------
+C
+ INTEGER I
+ DOUBLE PRECISION CFACT, CNORM, CTRNWT, GHINVG, FEMNSQ, GNORM,
+ 1 NWTNRM, RELAX, RLAMBD, T, T1, T2
+ DOUBLE PRECISION HALF, ONE, TWO, ZERO
+C
+C *** V SUBSCRIPTS ***
+C
+ INTEGER BIAS, DGNORM, DSTNRM, DST0, GRDFAC, GTHG, GTSTEP,
+ 1 NREDUC, NWTFAC, PREDUC, RADIUS, STPPAR
+C
+C *** DATA INITIALIZATIONS ***
+C
+ PARAMETER (HALF=0.5D+0, ONE=1.D+0, TWO=2.D+0, ZERO=0.D+0)
+C
+ PARAMETER (BIAS=43, DGNORM=1, DSTNRM=2, DST0=3, GRDFAC=45,
+ 1 GTHG=44, GTSTEP=4, NREDUC=6, NWTFAC=46, PREDUC=7,
+ 2 RADIUS=8, STPPAR=5)
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ NWTNRM = V(DST0)
+ RLAMBD = ONE
+ IF (NWTNRM .GT. ZERO) RLAMBD = V(RADIUS) / NWTNRM
+ GNORM = V(DGNORM)
+ GHINVG = TWO * V(NREDUC)
+ V(GRDFAC) = ZERO
+ V(NWTFAC) = ZERO
+ IF (RLAMBD .LT. ONE) GO TO 30
+C
+C *** THE NEWTON STEP IS INSIDE THE TRUST REGION ***
+C
+ V(STPPAR) = ZERO
+ V(DSTNRM) = NWTNRM
+ V(GTSTEP) = -GHINVG
+ V(PREDUC) = V(NREDUC)
+ V(NWTFAC) = -ONE
+ DO 20 I = 1, N
+ 20 STEP(I) = -NWTSTP(I)
+ GO TO 999
+C
+ 30 V(DSTNRM) = V(RADIUS)
+ CFACT = (GNORM / V(GTHG))**2
+C *** CAUCHY STEP = -CFACT * G.
+ CNORM = GNORM * CFACT
+ RELAX = ONE - V(BIAS) * (ONE - GNORM*CNORM/GHINVG)
+ IF (RLAMBD .LT. RELAX) GO TO 50
+C
+C *** STEP IS BETWEEN RELAXED NEWTON AND FULL NEWTON STEPS ***
+C
+ V(STPPAR) = ONE - (RLAMBD - RELAX) / (ONE - RELAX)
+ T = -RLAMBD
+ V(GTSTEP) = T * GHINVG
+ V(PREDUC) = RLAMBD * (ONE - HALF*RLAMBD) * GHINVG
+ V(NWTFAC) = T
+ DO 40 I = 1, N
+ 40 STEP(I) = T * NWTSTP(I)
+ GO TO 999
+C
+ 50 IF (CNORM .LT. V(RADIUS)) GO TO 70
+C
+C *** THE CAUCHY STEP LIES OUTSIDE THE TRUST REGION --
+C *** STEP = SCALED CAUCHY STEP ***
+C
+ T = -V(RADIUS) / GNORM
+ V(GRDFAC) = T
+ V(STPPAR) = ONE + CNORM / V(RADIUS)
+ V(GTSTEP) = -V(RADIUS) * GNORM
+ V(PREDUC) = V(RADIUS)*(GNORM - HALF*V(RADIUS)*(V(GTHG)/GNORM)**2)
+ DO 60 I = 1, N
+ 60 STEP(I) = T * DIG(I)
+ GO TO 999
+C
+C *** COMPUTE DOGLEG STEP BETWEEN CAUCHY AND RELAXED NEWTON ***
+C *** FEMUR = RELAXED NEWTON STEP MINUS CAUCHY STEP ***
+C
+ 70 CTRNWT = CFACT * RELAX * GHINVG / GNORM
+C *** CTRNWT = INNER PROD. OF CAUCHY AND RELAXED NEWTON STEPS,
+C *** SCALED BY GNORM**-1.
+ T1 = CTRNWT - GNORM*CFACT**2
+C *** T1 = INNER PROD. OF FEMUR AND CAUCHY STEP, SCALED BY
+C *** GNORM**-1.
+ T2 = V(RADIUS)*(V(RADIUS)/GNORM) - GNORM*CFACT**2
+ T = RELAX * NWTNRM
+ FEMNSQ = (T/GNORM)*T - CTRNWT - T1
+C *** FEMNSQ = SQUARE OF 2-NORM OF FEMUR, SCALED BY GNORM**-1.
+ T = T2 / (T1 + DSQRT(T1**2 + FEMNSQ*T2))
+C *** DOGLEG STEP = CAUCHY STEP + T * FEMUR.
+ T1 = (T - ONE) * CFACT
+ V(GRDFAC) = T1
+ T2 = -T * RELAX
+ V(NWTFAC) = T2
+ V(STPPAR) = TWO - T
+ V(GTSTEP) = T1*GNORM**2 + T2*GHINVG
+ V(PREDUC) = -T1*GNORM * ((T2 + ONE)*GNORM)
+ 1 - T2 * (ONE + HALF*T2)*GHINVG
+ 2 - HALF * (V(GTHG)*T1)**2
+ DO 80 I = 1, N
+ 80 STEP(I) = T1*DIG(I) + T2*NWTSTP(I)
+C
+ 999 RETURN
+C *** LAST LINE OF DD7DOG FOLLOWS ***
+ END
+ SUBROUTINE DS7IPR(P, IP, H)
+C
+C APPLY THE PERMUTATION DEFINED BY IP TO THE ROWS AND COLUMNS OF THE
+C P X P SYMMETRIC MATRIX WHOSE LOWER TRIANGLE IS STORED COMPACTLY IN H.
+C THUS H.OUTPUT(I,J) = H.INPUT(IP(I), IP(J)).
+C
+ INTEGER P
+ INTEGER IP(P)
+ DOUBLE PRECISION H(*)
+C
+ INTEGER I, J, J1, JM, K, K1, KK, KM, KMJ, L, M
+ DOUBLE PRECISION T
+C
+C *** BODY ***
+C
+ DO 90 I = 1, P
+ J = IP(I)
+ IF (J .EQ. I) GO TO 90
+ IP(I) = IABS(J)
+ IF (J .LT. 0) GO TO 90
+ K = I
+ 10 J1 = J
+ K1 = K
+ IF (J .LE. K) GO TO 20
+ J1 = K
+ K1 = J
+ 20 KMJ = K1-J1
+ L = J1-1
+ JM = J1*L/2
+ KM = K1*(K1-1)/2
+ IF (L .LE. 0) GO TO 40
+ DO 30 M = 1, L
+ JM = JM+1
+ T = H(JM)
+ KM = KM+1
+ H(JM) = H(KM)
+ H(KM) = T
+ 30 CONTINUE
+ 40 KM = KM+1
+ KK = KM+KMJ
+ JM = JM+1
+ T = H(JM)
+ H(JM) = H(KK)
+ H(KK) = T
+ J1 = L
+ L = KMJ-1
+ IF (L .LE. 0) GO TO 60
+ DO 50 M = 1, L
+ JM = JM+J1+M
+ T = H(JM)
+ KM = KM+1
+ H(JM) = H(KM)
+ H(KM) = T
+ 50 CONTINUE
+ 60 IF (K1 .GE. P) GO TO 80
+ L = P-K1
+ K1 = K1-1
+ KM = KK
+ DO 70 M = 1, L
+ KM = KM+K1+M
+ JM = KM-KMJ
+ T = H(JM)
+ H(JM) = H(KM)
+ H(KM) = T
+ 70 CONTINUE
+ 80 K = J
+ J = IP(K)
+ IP(K) = -J
+ IF (J .GT. I) GO TO 10
+ 90 CONTINUE
+ RETURN
+C *** LAST LINE OF DS7IPR FOLLOWS ***
+ END
+ SUBROUTINE DH2RFA(N, A, B, X, Y, Z)
+C
+C *** APPLY 2X2 HOUSEHOLDER REFLECTION DETERMINED BY X, Y, Z TO
+C *** N-VECTORS A, B ***
+C
+ INTEGER N
+ DOUBLE PRECISION A(N), B(N), X, Y, Z
+ INTEGER I
+ DOUBLE PRECISION T
+ DO 10 I = 1, N
+ T = A(I)*X + B(I)*Y
+ A(I) = A(I) + T
+ B(I) = B(I) + T*Z
+ 10 CONTINUE
+ RETURN
+C *** LAST LINE OF DH2RFA FOLLOWS ***
+ END
+ SUBROUTINE DPARCK(ALG, D, IV, LIV, LV, N, V)
+C
+C *** CHECK ***SOL (VERSION 2.3) PARAMETERS, PRINT CHANGED VALUES ***
+C
+C *** ALG = 1 FOR REGRESSION, ALG = 2 FOR GENERAL UNCONSTRAINED OPT.
+C
+ INTEGER ALG, LIV, LV, N
+ INTEGER IV(LIV)
+ DOUBLE PRECISION D(N), V(LV)
+C
+ DOUBLE PRECISION DR7MDC
+ EXTERNAL DIVSET, DR7MDC,DV7CPY,DV7DFL
+C DIVSET -- SUPPLIES DEFAULT VALUES TO BOTH IV AND V.
+C DR7MDC -- RETURNS MACHINE-DEPENDENT CONSTANTS.
+C DV7CPY -- COPIES ONE VECTOR TO ANOTHER.
+C DV7DFL -- SUPPLIES DEFAULT PARAMETER VALUES TO V ALONE.
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER ALG1, I, II, IV1, J, K, L, M, MIV1, MIV2, NDFALT, PARSV1,
+ 1 PU
+ INTEGER IJMP, JLIM(4), MINIV(4), NDFLT(4)
+ CHARACTER*4 CNGD(3), DFLT(3), WHICH(3)
+ DOUBLE PRECISION BIG, MACHEP, TINY, VK, VM(34), VX(34), ZERO
+C
+C *** IV AND V SUBSCRIPTS ***
+C
+ INTEGER ALGSAV, DINIT, DTYPE, DTYPE0, EPSLON, INITS, IVNEED,
+ 1 LASTIV, LASTV, LMAT, NEXTIV, NEXTV, NVDFLT, OLDN,
+ 2 PARPRT, PARSAV, PERM, PRUNIT, VNEED
+C
+C
+ PARAMETER (ALGSAV=51, DINIT=38, DTYPE=16, DTYPE0=54, EPSLON=19,
+ 1 INITS=25, IVNEED=3, LASTIV=44, LASTV=45, LMAT=42,
+ 2 NEXTIV=46, NEXTV=47, NVDFLT=50, OLDN=38, PARPRT=20,
+ 3 PARSAV=49, PERM=58, PRUNIT=21, VNEED=4)
+ SAVE BIG, MACHEP, TINY
+C
+ DATA BIG/0.D+0/, MACHEP/-1.D+0/, TINY/1.D+0/, ZERO/0.D+0/
+C
+ DATA VM(1)/1.0D-3/, VM(2)/-0.99D+0/, VM(3)/1.0D-3/, VM(4)/1.0D-2/,
+ 1 VM(5)/1.2D+0/, VM(6)/1.D-2/, VM(7)/1.2D+0/, VM(8)/0.D+0/,
+ 2 VM(9)/0.D+0/, VM(10)/1.D-3/, VM(11)/-1.D+0/, VM(13)/0.D+0/,
+ 3 VM(15)/0.D+0/, VM(16)/0.D+0/, VM(19)/0.D+0/, VM(20)/-10.D+0/,
+ 4 VM(21)/0.D+0/, VM(22)/0.D+0/, VM(23)/0.D+0/, VM(27)/1.01D+0/,
+ 5 VM(28)/1.D+10/, VM(30)/0.D+0/, VM(31)/0.D+0/, VM(32)/0.D+0/,
+ 6 VM(34)/0.D+0/
+ DATA VX(1)/0.9D+0/, VX(2)/-1.D-3/, VX(3)/1.D+1/, VX(4)/0.8D+0/,
+ 1 VX(5)/1.D+2/, VX(6)/0.8D+0/, VX(7)/1.D+2/, VX(8)/0.5D+0/,
+ 2 VX(9)/0.5D+0/, VX(10)/1.D+0/, VX(11)/1.D+0/, VX(14)/0.1D+0/,
+ 3 VX(15)/1.D+0/, VX(16)/1.D+0/, VX(19)/1.D+0/, VX(23)/1.D+0/,
+ 4 VX(24)/1.D+0/, VX(25)/1.D+0/, VX(26)/1.D+0/, VX(27)/1.D+10/,
+ 5 VX(29)/1.D+0/, VX(31)/1.D+0/, VX(32)/1.D+0/, VX(33)/1.D+0/,
+ 6 VX(34)/1.D+0/
+C
+ DATA CNGD(1),CNGD(2),CNGD(3)/'---C','HANG','ED V'/,
+ 1 DFLT(1),DFLT(2),DFLT(3)/'NOND','EFAU','LT V'/
+ DATA IJMP/33/, JLIM(1)/0/, JLIM(2)/24/, JLIM(3)/0/, JLIM(4)/24/,
+ 1 NDFLT(1)/32/, NDFLT(2)/25/, NDFLT(3)/32/, NDFLT(4)/25/
+ DATA MINIV(1)/82/, MINIV(2)/59/, MINIV(3)/103/, MINIV(4)/103/
+C
+C............................... BODY ................................
+C
+ PU = 0
+ IF (PRUNIT .LE. LIV) PU = IV(PRUNIT)
+ IF (ALGSAV .GT. LIV) GO TO 20
+ IF (ALG .EQ. IV(ALGSAV)) GO TO 20
+C IF (PU .NE. 0) WRITE(PU,10) ALG, IV(ALGSAV)
+C 10 FORMAT(/40H THE FIRST PARAMETER TO DIVSET SHOULD BE,I3,
+C 1 12H RATHER THAN,I3)
+ IV(1) = 67
+ GO TO 999
+ 20 IF (ALG .LT. 1 .OR. ALG .GT. 4) GO TO 340
+ MIV1 = MINIV(ALG)
+ IF (IV(1) .EQ. 15) GO TO 360
+ ALG1 = MOD(ALG-1,2) + 1
+ IF (IV(1) .EQ. 0) CALL DIVSET(ALG, IV, LIV, LV, V)
+ IV1 = IV(1)
+ IF (IV1 .NE. 13 .AND. IV1 .NE. 12) GO TO 30
+ IF (PERM .LE. LIV) MIV1 = MAX0(MIV1, IV(PERM) - 1)
+ IF (IVNEED .LE. LIV) MIV2 = MIV1 + MAX0(IV(IVNEED), 0)
+ IF (LASTIV .LE. LIV) IV(LASTIV) = MIV2
+ IF (LIV .LT. MIV1) GO TO 300
+ IV(IVNEED) = 0
+ IV(LASTV) = MAX0(IV(VNEED), 0) + IV(LMAT) - 1
+ IV(VNEED) = 0
+ IF (LIV .LT. MIV2) GO TO 300
+ IF (LV .LT. IV(LASTV)) GO TO 320
+ 30 IF (IV1 .LT. 12 .OR. IV1 .GT. 14) GO TO 60
+ IF (N .GE. 1) GO TO 50
+ IV(1) = 81
+ IF (PU .EQ. 0) GO TO 999
+C WRITE(PU,40) VARNM(ALG1), N
+C 40 FORMAT(/8H /// BAD,A1,2H =,I5)
+ GO TO 999
+ 50 IF (IV1 .NE. 14) IV(NEXTIV) = IV(PERM)
+ IF (IV1 .NE. 14) IV(NEXTV) = IV(LMAT)
+ IF (IV1 .EQ. 13) GO TO 999
+ K = IV(PARSAV) - EPSLON
+ CALL DV7DFL(ALG1, LV-K, V(K+1))
+ IV(DTYPE0) = 2 - ALG1
+ IV(OLDN) = N
+ WHICH(1) = DFLT(1)
+ WHICH(2) = DFLT(2)
+ WHICH(3) = DFLT(3)
+ GO TO 110
+ 60 IF (N .EQ. IV(OLDN)) GO TO 80
+ IV(1) = 17
+ IF (PU .EQ. 0) GO TO 999
+C WRITE(PU,70) VARNM(ALG1), IV(OLDN), N
+C 70 FORMAT(/5H /// ,1A1,14H CHANGED FROM ,I5,4H TO ,I5)
+ GO TO 999
+C
+ 80 IF (IV1 .LE. 11 .AND. IV1 .GE. 1) GO TO 100
+ IV(1) = 80
+C IF (PU .NE. 0) WRITE(PU,90) IV1
+C 90 FORMAT(/13H /// IV(1) =,I5,28H SHOULD BE BETWEEN 0 AND 14.)
+ GO TO 999
+C
+ 100 WHICH(1) = CNGD(1)
+ WHICH(2) = CNGD(2)
+ WHICH(3) = CNGD(3)
+C
+ 110 IF (IV1 .EQ. 14) IV1 = 12
+ IF (BIG .GT. TINY) GO TO 120
+ TINY = DR7MDC(1)
+ MACHEP = DR7MDC(3)
+ BIG = DR7MDC(6)
+ VM(12) = MACHEP
+ VX(12) = BIG
+ VX(13) = BIG
+ VM(14) = MACHEP
+ VM(17) = TINY
+ VX(17) = BIG
+ VM(18) = TINY
+ VX(18) = BIG
+ VX(20) = BIG
+ VX(21) = BIG
+ VX(22) = BIG
+ VM(24) = MACHEP
+ VM(25) = MACHEP
+ VM(26) = MACHEP
+ VX(28) = DR7MDC(5)
+ VM(29) = MACHEP
+ VX(30) = BIG
+ VM(33) = MACHEP
+ 120 M = 0
+ I = 1
+ J = JLIM(ALG1)
+ K = EPSLON
+ NDFALT = NDFLT(ALG1)
+ DO 150 L = 1, NDFALT
+ VK = V(K)
+ IF (VK .GE. VM(I) .AND. VK .LE. VX(I)) GO TO 140
+ M = K
+C IF (PU .NE. 0) WRITE(PU,130) VN(1,I), VN(2,I), K, VK,
+C 1 VM(I), VX(I)
+C 130 FORMAT(/6H /// ,2A4,5H.. V(,I2,3H) =,D11.3,7H SHOULD,
+C 1 11H BE BETWEEN,D11.3,4H AND,D11.3)
+ 140 K = K + 1
+ I = I + 1
+ IF (I .EQ. J) I = IJMP
+ 150 CONTINUE
+C
+ IF (IV(NVDFLT) .EQ. NDFALT) GO TO 170
+ IV(1) = 51
+ IF (PU .EQ. 0) GO TO 999
+C WRITE(PU,160) IV(NVDFLT), NDFALT
+C 160 FORMAT(/13H IV(NVDFLT) =,I5,13H RATHER THAN ,I5)
+ GO TO 999
+ 170 IF ((IV(DTYPE) .GT. 0 .OR. V(DINIT) .GT. ZERO) .AND. IV1 .EQ. 12)
+ 1 GO TO 200
+ DO 190 I = 1, N
+ IF (D(I) .GT. ZERO) GO TO 190
+ M = 18
+C IF (PU .NE. 0) WRITE(PU,180) I, D(I)
+C 180 FORMAT(/8H /// D(,I3,3H) =,D11.3,19H SHOULD BE POSITIVE)
+ 190 CONTINUE
+ 200 IF (M .EQ. 0) GO TO 210
+ IV(1) = M
+ GO TO 999
+C
+ 210 IF (PU .EQ. 0 .OR. IV(PARPRT) .EQ. 0) GO TO 999
+ IF (IV1 .NE. 12 .OR. IV(INITS) .EQ. ALG1-1) GO TO 230
+ M = 1
+C WRITE(PU,220) SH(ALG1), IV(INITS)
+C 220 FORMAT(/22H NONDEFAULT VALUES..../5H INIT,A1,14H..... IV(25) =,
+C 1 I3)
+ 230 IF (IV(DTYPE) .EQ. IV(DTYPE0)) GO TO 250
+C IF (M .EQ. 0) WRITE(PU,260) WHICH
+ M = 1
+C WRITE(PU,240) IV(DTYPE)
+C 240 FORMAT(20H DTYPE..... IV(16) =,I3)
+ 250 I = 1
+ J = JLIM(ALG1)
+ K = EPSLON
+ L = IV(PARSAV)
+ NDFALT = NDFLT(ALG1)
+ DO 290 II = 1, NDFALT
+ IF (V(K) .EQ. V(L)) GO TO 280
+C IF (M .EQ. 0) WRITE(PU,260) WHICH
+C 260 FORMAT(/1H ,3A4,9HALUES..../)
+ M = 1
+C WRITE(PU,270) VN(1,I), VN(2,I), K, V(K)
+C 270 FORMAT(1X,2A4,5H.. V(,I2,3H) =,D15.7)
+ 280 K = K + 1
+ L = L + 1
+ I = I + 1
+ IF (I .EQ. J) I = IJMP
+ 290 CONTINUE
+C
+ IV(DTYPE0) = IV(DTYPE)
+ PARSV1 = IV(PARSAV)
+ CALL DV7CPY(IV(NVDFLT), V(PARSV1), V(EPSLON))
+ GO TO 999
+C
+ 300 IV(1) = 15
+ IF (PU .EQ. 0) GO TO 999
+C WRITE(PU,310) LIV, MIV2
+C 310 FORMAT(/10H /// LIV =,I5,17H MUST BE AT LEAST,I5)
+ IF (LIV .LT. MIV1) GO TO 999
+ IF (LV .LT. IV(LASTV)) GO TO 320
+ GO TO 999
+C
+ 320 IV(1) = 16
+C IF (PU .NE. 0) WRITE(PU,330) LV, IV(LASTV)
+C 330 FORMAT(/9H /// LV =,I5,17H MUST BE AT LEAST,I5)
+ GO TO 999
+C
+ 340 IV(1) = 67
+C IF (PU .NE. 0) WRITE(PU,350) ALG
+C 350 FORMAT(/10H /// ALG =,I5,21H MUST BE 1 2, 3, OR 4)
+ GO TO 999
+ 360 CONTINUE
+C 360 IF (PU .NE. 0) WRITE(PU,370) LIV, MIV1
+C 370 FORMAT(/10H /// LIV =,I5,17H MUST BE AT LEAST,I5,
+C 1 37H TO COMPUTE TRUE MIN. LIV AND MIN. LV)
+ IF (LASTIV .LE. LIV) IV(LASTIV) = MIV1
+ IF (LASTV .LE. LIV) IV(LASTV) = 0
+C
+ 999 RETURN
+C *** LAST LINE OF DPARCK FOLLOWS ***
+ END
+
+ SUBROUTINE DQ7APL(NN, N, P, J, R, IERR)
+C *****PARAMETERS.
+ INTEGER NN, N, P, IERR
+ DOUBLE PRECISION J(NN,P), R(N)
+C
+C ..................................................................
+C ..................................................................
+C
+C *****PURPOSE.
+C THIS SUBROUTINE APPLIES TO R THE ORTHOGONAL TRANSFORMATIONS
+C STORED IN J BY QRFACT
+C
+C *****PARAMETER DESCRIPTION.
+C ON INPUT.
+C
+C NN IS THE ROW DIMENSION OF THE MATRIX J AS DECLARED IN
+C THE CALLING PROGRAM DIMENSION STATEMENT
+C
+C N IS THE NUMBER OF ROWS OF J AND THE SIZE OF THE VECTOR R
+C
+C P IS THE NUMBER OF COLUMNS OF J AND THE SIZE OF SIGMA
+C
+C J CONTAINS ON AND BELOW ITS DIAGONAL THE COLUMN VECTORS
+C U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS
+C IDENT - U*U.TRANSPOSE
+C
+C R IS THE RIGHT HAND SIDE VECTOR TO WHICH THE ORTHOGONAL
+C TRANSFORMATIONS WILL BE APPLIED
+C
+C IERR IF NON-ZERO INDICATES THAT NOT ALL THE TRANSFORMATIONS
+C WERE SUCCESSFULLY DETERMINED AND ONLY THE FIRST
+C ABS(IERR) - 1 TRANSFORMATIONS WILL BE USED
+C
+C ON OUTPUT.
+C
+C R HAS BEEN OVERWRITTEN BY ITS TRANSFORMED IMAGE
+C
+C *****APPLICATION AND USAGE RESTRICTIONS.
+C NONE
+C
+C *****ALGORITHM NOTES.
+C THE VECTORS U WHICH DETERMINE THE HOUSEHOLDER TRANSFORMATIONS
+C ARE NORMALIZED SO THAT THEIR 2-NORM SQUARED IS 2. THE USE OF
+C THESE TRANSFORMATIONS HERE IS IN THE SPIRIT OF (1).
+C
+C *****SUBROUTINES AND FUNCTIONS CALLED.
+C
+C DD7TPR - FUNCTION, RETURNS THE INNER PRODUCT OF VECTORS
+C
+C *****REFERENCES.
+C (1) BUSINGER, P. A., AND GOLUB, G. H. (1965), LINEAR LEAST SQUARES
+C SOLUTIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7,
+C PP. 269-276.
+C
+C *****HISTORY.
+C DESIGNED BY DAVID M. GAY, CODED BY STEPHEN C. PETERS (WINTER 1977)
+C CALL ON DV2AXY SUBSTITUTED FOR DO LOOP, FALL 1983.
+C
+C *****GENERAL.
+C
+C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
+C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
+C MCS-7600324, DCR75-10143, 76-14311DSS, AND MCS76-11989.
+C
+C ..................................................................
+C ..................................................................
+C
+C *****LOCAL VARIABLES.
+ INTEGER K, L, NL1
+C *****FUNCTIONS.
+ DOUBLE PRECISION DD7TPR
+ EXTERNAL DD7TPR,DV2AXY
+C
+C *** BODY ***
+C
+ K = P
+ IF (IERR .NE. 0) K = IABS(IERR) - 1
+ IF ( K .EQ. 0) GO TO 999
+C
+ DO 20 L = 1, K
+ NL1 = N - L + 1
+ CALL DV2AXY(NL1, R(L), -DD7TPR(NL1,J(L,L),R(L)), J(L,L), R(L))
+ 20 CONTINUE
+C
+ 999 RETURN
+C *** LAST LINE OF DQ7APL FOLLOWS ***
+ END
+
+ SUBROUTINE DV7DFL(ALG, LV, V)
+C
+C *** SUPPLY ***SOL (VERSION 2.3) DEFAULT VALUES TO V ***
+C
+C *** ALG = 1 MEANS REGRESSION CONSTANTS.
+C *** ALG = 2 MEANS GENERAL UNCONSTRAINED OPTIMIZATION CONSTANTS.
+C
+ INTEGER ALG, LV
+ DOUBLE PRECISION V(LV)
+C
+ DOUBLE PRECISION DR7MDC
+ EXTERNAL DR7MDC
+C DR7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS
+C
+ DOUBLE PRECISION MACHEP, MEPCRT, ONE, SQTEPS, THREE
+C
+C *** SUBSCRIPTS FOR V ***
+C
+ INTEGER AFCTOL, BIAS, COSMIN, DECFAC, DELTA0, DFAC, DINIT, DLTFDC,
+ 1 DLTFDJ, DTINIT, D0INIT, EPSLON, ETA0, FUZZ,
+ 2 INCFAC, LMAX0, LMAXS, PHMNFC, PHMXFC, RDFCMN, RDFCMX,
+ 3 RFCTOL, RLIMIT, RSPTOL, SCTOL, SIGMIN, TUNER1, TUNER2,
+ 4 TUNER3, TUNER4, TUNER5, XCTOL, XFTOL
+C
+ PARAMETER (ONE=1.D+0, THREE=3.D+0)
+C
+C *** V SUBSCRIPT VALUES ***
+C
+ PARAMETER (AFCTOL=31, BIAS=43, COSMIN=47, DECFAC=22, DELTA0=44,
+ 1 DFAC=41, DINIT=38, DLTFDC=42, DLTFDJ=43, DTINIT=39,
+ 2 D0INIT=40, EPSLON=19, ETA0=42, FUZZ=45,
+ 3 INCFAC=23, LMAX0=35, LMAXS=36, PHMNFC=20, PHMXFC=21,
+ 4 RDFCMN=24, RDFCMX=25, RFCTOL=32, RLIMIT=46, RSPTOL=49,
+ 5 SCTOL=37, SIGMIN=50, TUNER1=26, TUNER2=27, TUNER3=28,
+ 6 TUNER4=29, TUNER5=30, XCTOL=33, XFTOL=34)
+C
+C------------------------------- BODY --------------------------------
+C
+ MACHEP = DR7MDC(3)
+ if (MACHEP .GT. 1.D-10) then
+ V(AFCTOL) = MACHEP**2
+ else
+ V(AFCTOL) = 1.D-20
+ endif
+
+ V(DECFAC) = 0.5D+0
+ SQTEPS = DR7MDC(4)
+ V(DFAC) = 0.6D+0
+ V(DTINIT) = 1.D-6
+ MEPCRT = MACHEP ** (ONE/THREE)
+ V(D0INIT) = 1.D+0
+ V(EPSLON) = 0.1D+0
+ V(INCFAC) = 2.D+0
+ V(LMAX0) = 1.D+0
+ V(LMAXS) = 1.D+0
+ V(PHMNFC) = -0.1D+0
+ V(PHMXFC) = 0.1D+0
+ V(RDFCMN) = 0.1D+0
+ V(RDFCMX) = 4.D+0
+ V(RFCTOL) = DMAX1(1.D-10, MEPCRT**2)
+ V(SCTOL) = V(RFCTOL)
+ V(TUNER1) = 0.1D+0
+ V(TUNER2) = 1.D-4
+ V(TUNER3) = 0.75D+0
+ V(TUNER4) = 0.5D+0
+ V(TUNER5) = 0.75D+0
+ V(XCTOL) = SQTEPS
+ V(XFTOL) = 1.D+2 * MACHEP
+C
+ if (ALG .eq. 1) then
+C
+C *** REGRESSION VALUES (nls)
+C
+ V(COSMIN) = DMAX1(1.D-6, 1.D+2 * MACHEP)
+ V(DINIT) = 0.D+0
+ V(DELTA0) = SQTEPS
+ V(DLTFDC) = MEPCRT
+ V(DLTFDJ) = SQTEPS
+ V(FUZZ) = 1.5D+0
+ V(RLIMIT) = DR7MDC(5)
+ V(RSPTOL) = 1.D-3
+ V(SIGMIN) = 1.D-4
+ else
+C
+C *** GENERAL OPTIMIZATION VALUES (nlminb)
+C
+ V(BIAS) = 0.8D+0
+ V(DINIT) = -1.0D+0
+ V(ETA0) = 1.0D+3 * MACHEP
+C
+ end if
+C *** LAST CARD OF DV7DFL FOLLOWS ***
+ END
+
+ DOUBLE PRECISION FUNCTION DR7MDC(K)
+C
+C *** RETURN MACHINE DEPENDENT CONSTANTS USED BY NL2SOL ***
+C
+ INTEGER K
+C
+C *** THE CONSTANT RETURNED DEPENDS ON K...
+C
+C *** K = 1... SMALLEST POS. ETA SUCH THAT -ETA EXISTS.
+C *** K = 2... SQUARE ROOT OF ETA.
+C *** K = 3... UNIT ROUNDOFF = SMALLEST POS. NO. MACHEP SUCH
+C *** THAT 1 + MACHEP .GT. 1 .AND. 1 - MACHEP .LT. 1.
+C *** K = 4... SQUARE ROOT OF MACHEP.
+C *** K = 5... SQUARE ROOT OF BIG (SEE K = 6).
+C *** K = 6... LARGEST MACHINE NO. BIG SUCH THAT -BIG EXISTS.
+C
+ DOUBLE PRECISION BIG, ETA, MACHEP
+C/+
+ DOUBLE PRECISION DSQRT
+C/
+C
+ DOUBLE PRECISION D1MACH, ZERO
+ EXTERNAL D1MACH
+ DATA BIG/0.D+0/, ETA/0.D+0/, MACHEP/0.D+0/, ZERO/0.D+0/
+ IF (BIG .GT. ZERO) GO TO 1
+ BIG = D1MACH(2)
+ ETA = D1MACH(1)
+ MACHEP = D1MACH(4)
+ 1 CONTINUE
+C
+C------------------------------- BODY --------------------------------
+C
+ GO TO (10, 20, 30, 40, 50, 60), K
+C
+ 10 DR7MDC = ETA
+ GO TO 999
+C
+ 20 DR7MDC = DSQRT(256.D+0*ETA)/16.D+0
+ GO TO 999
+C
+ 30 DR7MDC = MACHEP
+ GO TO 999
+C
+ 40 DR7MDC = DSQRT(MACHEP)
+ GO TO 999
+C
+ 50 DR7MDC = DSQRT(BIG/256.D+0)*16.D+0
+ GO TO 999
+C
+ 60 DR7MDC = BIG
+C
+ 999 RETURN
+C *** LAST CARD OF DR7MDC FOLLOWS ***
+ END
+ SUBROUTINE DG7ITB(B, D, G, IV, LIV, LV, P, PS, V, X, Y)
+C
+C *** CARRY OUT NL2SOL-LIKE ITERATIONS FOR GENERALIZED LINEAR ***
+C *** REGRESSION PROBLEMS (AND OTHERS OF SIMILAR STRUCTURE) ***
+C *** HAVING SIMPLE BOUNDS ON THE PARAMETERS BEING ESTIMATED. ***
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER LIV, LV, P, PS
+ INTEGER IV(LIV)
+ DOUBLE PRECISION B(2,P), D(P), G(P), V(LV), X(P), Y(P)
+C
+C-------------------------- PARAMETER USAGE --------------------------
+C
+C B.... VECTOR OF LOWER AND UPPER BOUNDS ON X.
+C D.... SCALE VECTOR.
+C IV... INTEGER VALUE ARRAY.
+C LIV.. LENGTH OF IV. MUST BE AT LEAST 80.
+C LH... LENGTH OF H = P*(P+1)/2.
+C LV... LENGTH OF V. MUST BE AT LEAST P*(3*P + 19)/2 + 7.
+C G.... GRADIENT AT X (WHEN IV(1) = 2).
+C HC... GAUSS-NEWTON HESSIAN AT X (WHEN IV(1) = 2).
+C P.... NUMBER OF PARAMETERS (COMPONENTS IN X).
+C PS... NUMBER OF NONZERO ROWS AND COLUMNS IN S.
+C V.... FLOATING-POINT VALUE ARRAY.
+C X.... PARAMETER VECTOR.
+C Y.... PART OF YIELD VECTOR (WHEN IV(1)= 2, SCRATCH OTHERWISE).
+C
+C *** DISCUSSION ***
+C
+C DG7ITB IS SIMILAR TO DG7LIT, EXCEPT FOR THE EXTRA PARAMETER B
+C -- DG7ITB ENFORCES THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I),
+C I = 1(1)P.
+C DG7ITB PERFORMS NL2SOL-LIKE ITERATIONS FOR A VARIETY OF
+C REGRESSION PROBLEMS THAT ARE SIMILAR TO NONLINEAR LEAST-SQUARES
+C IN THAT THE HESSIAN IS THE SUM OF TWO TERMS, A READILY-COMPUTED
+C FIRST-ORDER TERM AND A SECOND-ORDER TERM. THE CALLER SUPPLIES
+C THE FIRST-ORDER TERM OF THE HESSIAN IN HC (LOWER TRIANGLE, STORED
+C COMPACTLY BY ROWS), AND DG7ITB BUILDS AN APPROXIMATION, S, TO THE
+C SECOND-ORDER TERM. THE CALLER ALSO PROVIDES THE FUNCTION VALUE,
+C GRADIENT, AND PART OF THE YIELD VECTOR USED IN UPDATING S.
+C DG7ITB DECIDES DYNAMICALLY WHETHER OR NOT TO USE S WHEN CHOOSING
+C THE NEXT STEP TO TRY... THE HESSIAN APPROXIMATION USED IS EITHER
+C HC ALONE (GAUSS-NEWTON MODEL) OR HC + S (AUGMENTED MODEL).
+C IF PS .LT. P, THEN ROWS AND COLUMNS PS+1...P OF S ARE KEPT
+C CONSTANT. THEY WILL BE ZERO UNLESS THE CALLER SETS IV(INITS) TO
+C 1 OR 2 AND SUPPLIES NONZERO VALUES FOR THEM, OR THE CALLER SETS
+C IV(INITS) TO 3 OR 4 AND THE FINITE-DIFFERENCE INITIAL S THEN
+C COMPUTED HAS NONZERO VALUES IN THESE ROWS.
+C
+C IF IV(INITS) IS 3 OR 4, THEN THE INITIAL S IS COMPUTED BY
+C FINITE DIFFERENCES. 3 MEANS USE FUNCTION DIFFERENCES, 4 MEANS
+C USE GRADIENT DIFFERENCES. FINITE DIFFERENCING IS DONE THE SAME
+C WAY AS IN COMPUTING A COVARIANCE MATRIX (WITH IV(COVREQ) = -1, -2,
+C 1, OR 2).
+C
+C FOR UPDATING S, DG7ITB ASSUMES THAT THE GRADIENT HAS THE FORM
+C OF A SUM OVER I OF RHO(I,X)*GRAD(R(I,X)), WHERE GRAD DENOTES THE
+C GRADIENT WITH RESPECT TO X. THE TRUE SECOND-ORDER TERM THEN IS
+C THE SUM OVER I OF RHO(I,X)*HESSIAN(R(I,X)). IF X = X0 + STEP,
+C THEN WE WISH TO UPDATE S SO THAT S*STEP IS THE SUM OVER I OF
+C RHO(I,X)*(GRAD(R(I,X)) - GRAD(R(I,X0))). THE CALLER MUST SUPPLY
+C PART OF THIS IN Y, NAMELY THE SUM OVER I OF
+C RHO(I,X)*GRAD(R(I,X0)), WHEN CALLING DG7ITB WITH IV(1) = 2 AND
+C IV(MODE) = 0 (WHERE MODE = 38). G THEN CONTANS THE OTHER PART,
+C SO THAT THE DESIRED YIELD VECTOR IS G - Y. IF PS .LT. P, THEN
+C THE ABOVE DISCUSSION APPLIES ONLY TO THE FIRST PS COMPONENTS OF
+C GRAD(R(I,X)), STEP, AND Y.
+C
+C PARAMETERS IV, P, V, AND X ARE THE SAME AS THE CORRESPONDING
+C ONES TO DN2GB (AND NL2SOL), EXCEPT THAT V CAN BE SHORTER
+C (SINCE THE PART OF V THAT DN2GB USES FOR STORING D, J, AND R IS
+C NOT NEEDED). MOREOVER, COMPARED WITH DN2GB (AND NL2SOL), IV(1)
+C MAY HAVE THE TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE
+C EXPLAINED BELOW, AS IS THE USE OF IV(TOOBIG) AND IV(NFGCAL).
+C THE VALUES IV(D), IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM
+C DN2GB (AND DN2FB), ARE NOT REFERENCED BY DG7ITB OR THE
+C SUBROUTINES IT CALLS.
+C
+C WHEN DG7ITB IS FIRST CALLED, I.E., WHEN DG7ITB IS CALLED WITH
+C IV(1) = 0 OR 12, V(F), G, AND HC NEED NOT BE INITIALIZED. TO
+C OBTAIN THESE STARTING VALUES, DG7ITB RETURNS FIRST WITH IV(1) = 1,
+C THEN WITH IV(1) = 2, WITH IV(MODE) = -1 IN BOTH CASES. ON
+C SUBSEQUENT RETURNS WITH IV(1) = 2, IV(MODE) = 0 IMPLIES THAT
+C Y MUST ALSO BE SUPPLIED. (NOTE THAT Y IS USED FOR SCRATCH -- ITS
+C INPUT CONTENTS ARE LOST. BY CONTRAST, HC IS NEVER CHANGED.)
+C ONCE CONVERGENCE HAS BEEN OBTAINED, IV(RDREQ) AND IV(COVREQ) MAY
+C IMPLY THAT A FINITE-DIFFERENCE HESSIAN SHOULD BE COMPUTED FOR USE
+C IN COMPUTING A COVARIANCE MATRIX. IN THIS CASE DG7ITB WILL MAKE
+C A NUMBER OF RETURNS WITH IV(1) = 1 OR 2 AND IV(MODE) POSITIVE.
+C WHEN IV(MODE) IS POSITIVE, Y SHOULD NOT BE CHANGED.
+C
+C IV(1) = 1 MEANS THE CALLER SHOULD SET V(F) (I.E., V(10)) TO F(X), THE
+C FUNCTION VALUE AT X, AND CALL DG7ITB AGAIN, HAVING CHANGED
+C NONE OF THE OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X)
+C CANNOT BE EVALUATED (E.G. IF OVERFLOW WOULD OCCUR), WHICH
+C MAY HAPPEN BECAUSE OF AN OVERSIZED STEP. IN THIS CASE
+C THE CALLER SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL
+C CAUSE DG7ITB TO IGNORE V(F) AND TRY A SMALLER STEP. NOTE
+C THAT THE CURRENT FUNCTION EVALUATION COUNT IS AVAILABLE
+C IN IV(NFCALL) = IV(6). THIS MAY BE USED TO IDENTIFY
+C WHICH COPY OF SAVED INFORMATION SHOULD BE USED IN COM-
+C PUTING G, HC, AND Y THE NEXT TIME DG7ITB RETURNS WITH
+C IV(1) = 2. SEE MLPIT FOR AN EXAMPLE OF THIS.
+C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT
+C X. THE CALLER SHOULD ALSO SET HC TO THE GAUSS-NEWTON
+C HESSIAN AT X. IF IV(MODE) = 0, THEN THE CALLER SHOULD
+C ALSO COMPUTE THE PART OF THE YIELD VECTOR DESCRIBED ABOVE.
+C THE CALLER SHOULD THEN CALL DG7ITB AGAIN (WITH IV(1) = 2).
+C THE CALLER MAY ALSO CHANGE D AT THIS TIME, BUT SHOULD NOT
+C CHANGE X. NOTE THAT IV(NFGCAL) = IV(7) CONTAINS THE
+C VALUE THAT IV(NFCALL) HAD DURING THE RETURN WITH
+C IV(1) = 1 IN WHICH X HAD THE SAME VALUE AS IT NOW HAS.
+C IV(NFGCAL) IS EITHER IV(NFCALL) OR IV(NFCALL) - 1. MLPIT
+C IS AN EXAMPLE WHERE THIS INFORMATION IS USED. IF G OR HC
+C CANNOT BE EVALUATED AT X, THEN THE CALLER MAY SET
+C IV(NFGCAL) TO 0, IN WHICH CASE DG7ITB WILL RETURN WITH
+C IV(1) = 15.
+C
+C *** GENERAL ***
+C
+C CODED BY DAVID M. GAY.
+C
+C (SEE NL2SOL FOR REFERENCES.)
+C
+C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
+C
+C *** LOCAL VARIABLES ***
+C
+ LOGICAL HAVQTR, HAVRM
+ INTEGER DUMMY, DIG1, G01, H1, HC1, I, I1, IPI, IPIV0, IPIV1,
+ 1 IPIV2, IPN, J, K, L, LMAT1, LSTGST, P1, P1LEN, PP1, PP1O2,
+ 2 QTR1, RMAT1, RSTRST, STEP1, STPMOD, S1, TD1, TEMP1, TEMP2,
+ 3 TG1, W1, WLM1, X01
+ DOUBLE PRECISION E, GI, STTSST, T, T1, XI
+C
+C *** CONSTANTS ***
+C
+ DOUBLE PRECISION HALF, NEGONE, ONE, ONEP2, ZERO
+C
+C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
+C
+ LOGICAL STOPX
+ DOUBLE PRECISION DD7TPR, DRLDST, DV2NRM
+ EXTERNAL DA7SST, DD7TPR, DF7DHB, DG7QSB,I7COPY, I7PNVR, I7SHFT,
+ 1 DITSUM, DL7MSB, DL7SQR, DL7TVM,DL7VML,DPARCK, DQ7RSH,
+ 2 DRLDST, DS7DMP, DS7IPR, DS7LUP, DS7LVM, STOPX, DV2NRM,
+ 3 DV2AXY,DV7CPY, DV7IPR, DV7SCP, DV7VMP
+C
+C DA7SST.... ASSESSES CANDIDATE STEP.
+C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
+C DF7DHB... COMPUTE FINITE-DIFFERENCE HESSIAN (FOR INIT. S MATRIX).
+C DG7QSB... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL).
+C I7COPY.... COPIES ONE INTEGER VECTOR TO ANOTHER.
+C I7PNVR... INVERTS PERMUTATION ARRAY.
+C I7SHFT... SHIFTS AN INTEGER VECTOR.
+C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
+C DL7MSB... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL).
+C DL7SQR... COMPUTES L * L**T FROM LOWER TRIANGULAR MATRIX L.
+C DL7TVM... COMPUTES L**T * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
+C DL7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
+C DPARCK.... CHECK VALIDITY OF IV AND V INPUT COMPONENTS.
+C DQ7RSH... SHIFTS A QR FACTORIZATION.
+C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
+C DS7DMP... MULTIPLIES A SYM. MATRIX FORE AND AFT BY A DIAG. MATRIX.
+C DS7IPR... APPLIES PERMUTATION TO (LOWER TRIANG. OF) SYM. MATRIX.
+C DS7LUP... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI-
+C ANGLE OF A SYMMETRIC MATRIX.
+C DS7LVM... MULTIPLIES COMPACTLY STORED SYM. MATRIX TIMES VECTOR.
+C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
+C DV2NRM... RETURNS THE 2-NORM OF A VECTOR.
+C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
+C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
+C DV7IPR... APPLIES A PERMUTATION TO A VECTOR.
+C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
+C DV7VMP... MULTIPLIES (DIVIDES) VECTORS COMPONENTWISE.
+C
+C *** SUBSCRIPTS FOR IV AND V ***
+C
+ INTEGER CNVCOD, COSMIN, COVMAT, COVREQ, DGNORM, DIG,
+ 1 DSTNRM, F, FDH, FDIF, FUZZ, F0, GTSTEP, H, HC, IERR,
+ 2 INCFAC, INITS, IPIVOT, IRC, IVNEED, KAGQT, KALM, LMAT,
+ 3 LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTIV, NEXTV,
+ 4 NFCALL, NFGCAL, NFCOV, NGCOV, NGCALL, NITER, NVSAVE, P0,
+ 5 PC, PERM, PHMXFC, PREDUC, QTR, RADFAC, RADINC, RADIUS,
+ 6 RAD0, RDREQ, REGD, RELDX, RESTOR, RMAT, S, SIZE, STEP,
+ 7 STGLIM, STPPAR, SUSED, SWITCH, TOOBIG, TUNER4, TUNER5,
+ 8 VNEED, VSAVE, W, WSCALE, XIRC, X0
+C
+C *** IV SUBSCRIPT VALUES ***
+C
+C *** (NOTE THAT P0 AND PC ARE STORED IN IV(G0) AND IV(STLSTG) RESP.)
+C
+ PARAMETER (CNVCOD=55, COVMAT=26, COVREQ=15, DIG=37, FDH=74, H=56,
+ 1 HC=71, IERR=75, INITS=25, IPIVOT=76, IRC=29, IVNEED=3,
+ 2 KAGQT=33, KALM=34, LMAT=42, MODE=35, MODEL=5,
+ 3 MXFCAL=17, MXITER=18, NEXTIV=46, NEXTV=47, NFCALL=6,
+ 4 NFGCAL=7, NFCOV=52, NGCOV=53, NGCALL=30, NITER=31,
+ 5 P0=48, PC=41, PERM=58, QTR=77, RADINC=8, RDREQ=57,
+ 6 REGD=67, RESTOR=9, RMAT=78, S=62, STEP=40, STGLIM=11,
+ 7 SUSED=64, SWITCH=12, TOOBIG=2, VNEED=4, VSAVE=60, W=65,
+ 8 XIRC=13, X0=43)
+C
+C *** V SUBSCRIPT VALUES ***
+C
+ PARAMETER (COSMIN=47, DGNORM=1, DSTNRM=2, F=10, FDIF=11, FUZZ=45,
+ 1 F0=13, GTSTEP=4, INCFAC=23, LMAX0=35, LMAXS=36,
+ 2 NVSAVE=9, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8,
+ 3 RAD0=9, RELDX=17, SIZE=55, STPPAR=5, TUNER4=29,
+ 4 TUNER5=30, WSCALE=56)
+C
+C
+ PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0,
+ 1 ZERO=0.D+0)
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ I = IV(1)
+ IF (I .EQ. 1) GO TO 50
+ IF (I .EQ. 2) GO TO 60
+C
+ IF (I .LT. 12) GO TO 10
+ IF (I .GT. 13) GO TO 10
+ IV(VNEED) = IV(VNEED) + P*(3*P + 25)/2 + 7
+ IV(IVNEED) = IV(IVNEED) + 4*P
+ 10 CALL DPARCK(1, D, IV, LIV, LV, P, V)
+ I = IV(1) - 2
+ IF (I .GT. 12) GO TO 999
+ GO TO (360, 360, 360, 360, 360, 360, 240, 190, 240, 20, 20, 30), I
+C
+C *** STORAGE ALLOCATION ***
+C
+ 20 PP1O2 = P * (P + 1) / 2
+ IV(S) = IV(LMAT) + PP1O2
+ IV(X0) = IV(S) + PP1O2
+ IV(STEP) = IV(X0) + 2*P
+ IV(DIG) = IV(STEP) + 3*P
+ IV(W) = IV(DIG) + 2*P
+ IV(H) = IV(W) + 4*P + 7
+ IV(NEXTV) = IV(H) + PP1O2
+ IV(IPIVOT) = IV(PERM) + 3*P
+ IV(NEXTIV) = IV(IPIVOT) + P
+ IF (IV(1) .NE. 13) GO TO 30
+ IV(1) = 14
+ GO TO 999
+C
+C *** INITIALIZATION ***
+C
+ 30 IV(NITER) = 0
+ IV(NFCALL) = 1
+ IV(NGCALL) = 1
+ IV(NFGCAL) = 1
+ IV(MODE) = -1
+ IV(STGLIM) = 2
+ IV(TOOBIG) = 0
+ IV(CNVCOD) = 0
+ IV(COVMAT) = 0
+ IV(NFCOV) = 0
+ IV(NGCOV) = 0
+ IV(RADINC) = 0
+ IV(PC) = P
+ V(RAD0) = ZERO
+ V(STPPAR) = ZERO
+ V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC))
+C
+C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY ***
+C
+ IPI = IV(IPIVOT)
+ DO 40 I = 1, P
+ IV(IPI) = I
+ IPI = IPI + 1
+ IF (B(1,I) .GT. B(2,I)) GO TO 680
+ 40 CONTINUE
+C
+C *** SET INITIAL MODEL AND S MATRIX ***
+C
+ IV(MODEL) = 1
+ IV(1) = 1
+ IF (IV(S) .LT. 0) GO TO 710
+ IF (IV(INITS) .GT. 1) IV(MODEL) = 2
+ S1 = IV(S)
+ IF (IV(INITS) .EQ. 0 .OR. IV(INITS) .GT. 2)
+ 1 CALL DV7SCP(P*(P+1)/2, V(S1), ZERO)
+ GO TO 710
+C
+C *** NEW FUNCTION VALUE ***
+C
+ 50 IF (IV(MODE) .EQ. 0) GO TO 360
+ IF (IV(MODE) .GT. 0) GO TO 590
+C
+ IF (IV(TOOBIG) .EQ. 0) GO TO 690
+ IV(1) = 63
+ GO TO 999
+C
+C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
+C
+ 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70
+ IV(1) = 65
+ GO TO 999
+C
+C *** NEW GRADIENT ***
+C
+ 70 IV(KALM) = -1
+ IV(KAGQT) = -1
+ IV(FDH) = 0
+ IF (IV(MODE) .GT. 0) GO TO 590
+ IF (IV(HC) .LE. 0 .AND. IV(RMAT) .LE. 0) GO TO 670
+C
+C *** CHOOSE INITIAL PERMUTATION ***
+C
+ IPI = IV(IPIVOT)
+ IPN = IPI + P - 1
+ IPIV2 = IV(PERM) - 1
+ K = IV(PC)
+ P1 = P
+ PP1 = P + 1
+ RMAT1 = IV(RMAT)
+ HAVRM = RMAT1 .GT. 0
+ QTR1 = IV(QTR)
+ HAVQTR = QTR1 .GT. 0
+C *** MAKE SURE V(QTR1) IS LEGAL (EVEN WHEN NOT REFERENCED) ***
+ W1 = IV(W)
+ IF (.NOT. HAVQTR) QTR1 = W1 + P
+C
+ DO 100 I = 1, P
+ I1 = IV(IPN)
+ IPN = IPN - 1
+ IF (B(1,I1) .GE. B(2,I1)) GO TO 80
+ XI = X(I1)
+ GI = G(I1)
+ IF (XI .LE. B(1,I1) .AND. GI .GT. ZERO) GO TO 80
+ IF (XI .GE. B(2,I1) .AND. GI .LT. ZERO) GO TO 80
+C *** DISALLOW CONVERGENCE IF X(I1) HAS JUST BEEN FREED ***
+ J = IPIV2 + I1
+ IF (IV(J) .GT. K) IV(CNVCOD) = 0
+ GO TO 100
+ 80 IF (I1 .GE. P1) GO TO 90
+ I1 = PP1 - I
+ CALL I7SHFT(P1, I1, IV(IPI))
+ IF (HAVRM)
+ 1 CALL DQ7RSH(I1, P1, HAVQTR, V(QTR1), V(RMAT1), V(W1))
+ 90 P1 = P1 - 1
+ 100 CONTINUE
+ IV(PC) = P1
+C
+C *** COMPUTE V(DGNORM) (AN OUTPUT VALUE IF WE STOP NOW) ***
+C
+ V(DGNORM) = ZERO
+ IF (P1 .LE. 0) GO TO 110
+ DIG1 = IV(DIG)
+ CALL DV7VMP(P, V(DIG1), G, D, -1)
+ CALL DV7IPR(P, IV(IPI), V(DIG1))
+ V(DGNORM) = DV2NRM(P1, V(DIG1))
+ 110 IF (IV(CNVCOD) .NE. 0) GO TO 580
+ IF (IV(MODE) .EQ. 0) GO TO 510
+ IV(MODE) = 0
+ V(F0) = V(F)
+ IF (IV(INITS) .LE. 2) GO TO 170
+C
+C *** ARRANGE FOR FINITE-DIFFERENCE INITIAL S ***
+C
+ IV(XIRC) = IV(COVREQ)
+ IV(COVREQ) = -1
+ IF (IV(INITS) .GT. 3) IV(COVREQ) = 1
+ IV(CNVCOD) = 70
+ GO TO 600
+C
+C *** COME TO NEXT STMT AFTER COMPUTING F.D. HESSIAN FOR INIT. S ***
+C
+ 120 H1 = IV(FDH)
+ IF (H1 .LE. 0) GO TO 660
+ IV(CNVCOD) = 0
+ IV(MODE) = 0
+ IV(NFCOV) = 0
+ IV(NGCOV) = 0
+ IV(COVREQ) = IV(XIRC)
+ S1 = IV(S)
+ PP1O2 = PS * (PS + 1) / 2
+ HC1 = IV(HC)
+ IF (HC1 .LE. 0) GO TO 130
+ CALL DV2AXY(PP1O2, V(S1), NEGONE, V(HC1), V(H1))
+ GO TO 140
+ 130 RMAT1 = IV(RMAT)
+ LMAT1 = IV(LMAT)
+ CALL DL7SQR(P, V(LMAT1), V(RMAT1))
+ IPI = IV(IPIVOT)
+ IPIV1 = IV(PERM) + P
+ CALL I7PNVR(P, IV(IPIV1), IV(IPI))
+ CALL DS7IPR(P, IV(IPIV1), V(LMAT1))
+ CALL DV2AXY(PP1O2, V(S1), NEGONE, V(LMAT1), V(H1))
+C
+C *** ZERO PORTION OF S CORRESPONDING TO FIXED X COMPONENTS ***
+C
+ 140 DO 160 I = 1, P
+ IF (B(1,I) .LT. B(2,I)) GO TO 160
+ K = S1 + I*(I-1)/2
+ CALL DV7SCP(I, V(K), ZERO)
+ IF (I .GE. P) GO TO 170
+ K = K + 2*I - 1
+ I1 = I + 1
+ DO 150 J = I1, P
+ V(K) = ZERO
+ K = K + J
+ 150 CONTINUE
+ 160 CONTINUE
+C
+ 170 IV(1) = 2
+C
+C
+C----------------------------- MAIN LOOP -----------------------------
+C
+C
+C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
+C
+ 180 CALL DITSUM(D, G, IV, LIV, LV, P, V, X)
+ 190 K = IV(NITER)
+ IF (K .LT. IV(MXITER)) GO TO 200
+ IV(1) = 10
+ GO TO 999
+ 200 IV(NITER) = K + 1
+C
+C *** UPDATE RADIUS ***
+C
+ IF (K .EQ. 0) GO TO 220
+ STEP1 = IV(STEP)
+ DO 210 I = 1, P
+ V(STEP1) = D(I) * V(STEP1)
+ STEP1 = STEP1 + 1
+ 210 CONTINUE
+ STEP1 = IV(STEP)
+ T = V(RADFAC) * DV2NRM(P, V(STEP1))
+ IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T
+C
+C *** INITIALIZE FOR START OF NEXT ITERATION ***
+C
+ 220 X01 = IV(X0)
+ V(F0) = V(F)
+ IV(IRC) = 4
+ IV(H) = -IABS(IV(H))
+ IV(SUSED) = IV(MODEL)
+C
+C *** COPY X TO X0 ***
+C
+ CALL DV7CPY(P, V(X01), X)
+C
+C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
+C
+ 230 IF (.NOT. STOPX(DUMMY)) GO TO 250
+ IV(1) = 11
+ GO TO 260
+C
+C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
+C
+ 240 IF (V(F) .GE. V(F0)) GO TO 250
+ V(RADFAC) = ONE
+ K = IV(NITER)
+ GO TO 200
+C
+ 250 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 270
+ IV(1) = 9
+ 260 IF (V(F) .GE. V(F0)) GO TO 999
+C
+C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
+C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
+C
+ IV(CNVCOD) = IV(1)
+ GO TO 500
+C
+C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
+C
+ 270 STEP1 = IV(STEP)
+ TG1 = IV(DIG)
+ TD1 = TG1 + P
+ X01 = IV(X0)
+ W1 = IV(W)
+ H1 = IV(H)
+ P1 = IV(PC)
+ IPI = IV(PERM)
+ IPIV1 = IPI + P
+ IPIV2 = IPIV1 + P
+ IPIV0 = IV(IPIVOT)
+ IF (IV(MODEL) .EQ. 2) GO TO 280
+C
+C *** COMPUTE LEVENBERG-MARQUARDT STEP IF POSSIBLE...
+C
+ RMAT1 = IV(RMAT)
+ IF (RMAT1 .LE. 0) GO TO 280
+ QTR1 = IV(QTR)
+ IF (QTR1 .LE. 0) GO TO 280
+ LMAT1 = IV(LMAT)
+ WLM1 = W1 + P
+ CALL DL7MSB(B, D, G, IV(IERR), IV(IPIV0), IV(IPIV1),
+ 1 IV(IPIV2), IV(KALM), V(LMAT1), LV, P, IV(P0),
+ 2 IV(PC), V(QTR1), V(RMAT1), V(STEP1), V(TD1),
+ 3 V(TG1), V, V(W1), V(WLM1), X, V(X01))
+C *** H IS STORED IN THE END OF W AND HAS JUST BEEN OVERWRITTEN,
+C *** SO WE MARK IT INVALID...
+ IV(H) = -IABS(H1)
+C *** EVEN IF H WERE STORED ELSEWHERE, IT WOULD BE NECESSARY TO
+C *** MARK INVALID THE INFORMATION DG7QTS MAY HAVE STORED IN V...
+ IV(KAGQT) = -1
+ GO TO 330
+C
+ 280 IF (H1 .GT. 0) GO TO 320
+C
+C *** SET H TO D**-1 * (HC + T1*S) * D**-1. ***
+C
+ P1LEN = P1*(P1+1)/2
+ H1 = -H1
+ IV(H) = H1
+ IV(FDH) = 0
+ IF (P1 .LE. 0) GO TO 320
+C *** MAKE TEMPORARY PERMUTATION ARRAY ***
+ CALL I7COPY(P, IV(IPI), IV(IPIV0))
+ J = IV(HC)
+ IF (J .GT. 0) GO TO 290
+ J = H1
+ RMAT1 = IV(RMAT)
+ CALL DL7SQR(P1, V(H1), V(RMAT1))
+ GO TO 300
+ 290 CALL DV7CPY(P*(P+1)/2, V(H1), V(J))
+ CALL DS7IPR(P, IV(IPI), V(H1))
+ 300 IF (IV(MODEL) .EQ. 1) GO TO 310
+ LMAT1 = IV(LMAT)
+ S1 = IV(S)
+ CALL DV7CPY(P*(P+1)/2, V(LMAT1), V(S1))
+ CALL DS7IPR(P, IV(IPI), V(LMAT1))
+ CALL DV2AXY(P1LEN, V(H1), ONE, V(LMAT1), V(H1))
+ 310 CALL DV7CPY(P, V(TD1), D)
+ CALL DV7IPR(P, IV(IPI), V(TD1))
+ CALL DS7DMP(P1, V(H1), V(H1), V(TD1), -1)
+ IV(KAGQT) = -1
+C
+C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP ***
+C
+ 320 LMAT1 = IV(LMAT)
+ CALL DG7QSB(B, D, V(H1), G, IV(IPI), IV(IPIV1), IV(IPIV2),
+ 1 IV(KAGQT), V(LMAT1), LV, P, IV(P0), P1, V(STEP1),
+ 2 V(TD1), V(TG1), V, V(W1), X, V(X01))
+ IF (IV(KALM) .GT. 0) IV(KALM) = 0
+C
+ 330 IF (IV(IRC) .NE. 6) GO TO 340
+ IF (IV(RESTOR) .NE. 2) GO TO 360
+ RSTRST = 2
+ GO TO 370
+C
+C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
+C
+ 340 IV(TOOBIG) = 0
+ IF (V(DSTNRM) .LE. ZERO) GO TO 360
+ IF (IV(IRC) .NE. 5) GO TO 350
+ IF (V(RADFAC) .LE. ONE) GO TO 350
+ IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 350
+ STEP1 = IV(STEP)
+ X01 = IV(X0)
+ CALL DV2AXY(P, V(STEP1), NEGONE, V(X01), X)
+ IF (IV(RESTOR) .NE. 2) GO TO 360
+ RSTRST = 0
+ GO TO 370
+C
+C *** COMPUTE F(X0 + STEP) ***
+C
+ 350 X01 = IV(X0)
+ STEP1 = IV(STEP)
+ CALL DV2AXY(P, X, ONE, V(STEP1), V(X01))
+ IV(NFCALL) = IV(NFCALL) + 1
+ IV(1) = 1
+ GO TO 710
+C
+C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
+C
+ 360 RSTRST = 3
+ 370 X01 = IV(X0)
+ V(RELDX) = DRLDST(P, D, X, V(X01))
+ CALL DA7SST(IV, LIV, LV, V)
+ STEP1 = IV(STEP)
+ LSTGST = X01 + P
+ I = IV(RESTOR) + 1
+ GO TO (410, 380, 390, 400), I
+ 380 CALL DV7CPY(P, X, V(X01))
+ GO TO 410
+ 390 CALL DV7CPY(P, V(LSTGST), V(STEP1))
+ GO TO 410
+ 400 CALL DV7CPY(P, V(STEP1), V(LSTGST))
+ CALL DV2AXY(P, X, ONE, V(STEP1), V(X01))
+ V(RELDX) = DRLDST(P, D, X, V(X01))
+ IV(RESTOR) = RSTRST
+C
+C *** IF NECESSARY, SWITCH MODELS ***
+C
+ 410 IF (IV(SWITCH) .EQ. 0) GO TO 420
+ IV(H) = -IABS(IV(H))
+ IV(SUSED) = IV(SUSED) + 2
+ L = IV(VSAVE)
+ CALL DV7CPY(NVSAVE, V, V(L))
+ 420 L = IV(IRC) - 4
+ STPMOD = IV(MODEL)
+ IF (L .GT. 0) GO TO (440,450,460,460,460,460,460,460,570,510), L
+C
+C *** DECIDE WHETHER TO CHANGE MODELS ***
+C
+ E = V(PREDUC) - V(FDIF)
+ S1 = IV(S)
+ CALL DS7LVM(PS, Y, V(S1), V(STEP1))
+ STTSST = HALF * DD7TPR(PS, V(STEP1), Y)
+ IF (IV(MODEL) .EQ. 1) STTSST = -STTSST
+ IF (DABS(E + STTSST) * V(FUZZ) .GE. DABS(E)) GO TO 430
+C
+C *** SWITCH MODELS ***
+C
+ IV(MODEL) = 3 - IV(MODEL)
+ IF (-2 .LT. L) GO TO 470
+ IV(H) = -IABS(IV(H))
+ IV(SUSED) = IV(SUSED) + 2
+ L = IV(VSAVE)
+ CALL DV7CPY(NVSAVE, V(L), V)
+ GO TO 230
+C
+ 430 IF (-3 .LT. L) GO TO 470
+C
+C *** RECOMPUTE STEP WITH DIFFERENT RADIUS ***
+C
+ 440 V(RADIUS) = V(RADFAC) * V(DSTNRM)
+ GO TO 230
+C
+C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST
+C
+ 450 V(RADIUS) = V(LMAXS)
+ GO TO 270
+C
+C *** CONVERGENCE OR FALSE CONVERGENCE ***
+C
+ 460 IV(CNVCOD) = L
+ IF (V(F) .GE. V(F0)) GO TO 580
+ IF (IV(XIRC) .EQ. 14) GO TO 580
+ IV(XIRC) = 14
+C
+C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
+C
+ 470 IV(COVMAT) = 0
+ IV(REGD) = 0
+C
+C *** SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS ***
+C
+ IF (IV(IRC) .NE. 3) GO TO 500
+ STEP1 = IV(STEP)
+ TEMP1 = STEP1 + P
+ TEMP2 = IV(X0)
+C
+C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS ***
+C
+ HC1 = IV(HC)
+ IF (HC1 .LE. 0) GO TO 480
+ CALL DS7LVM(P, V(TEMP1), V(HC1), V(STEP1))
+ GO TO 490
+ 480 RMAT1 = IV(RMAT)
+ IPIV0 = IV(IPIVOT)
+ CALL DV7CPY(P, V(TEMP1), V(STEP1))
+ CALL DV7IPR(P, IV(IPIV0), V(TEMP1))
+ CALL DL7TVM(P, V(TEMP1), V(RMAT1), V(TEMP1))
+ CALL DL7VML(P, V(TEMP1), V(RMAT1), V(TEMP1))
+ IPIV1 = IV(PERM) + P
+ CALL I7PNVR(P, IV(IPIV1), IV(IPIV0))
+ CALL DV7IPR(P, IV(IPIV1), V(TEMP1))
+C
+ 490 IF (STPMOD .EQ. 1) GO TO 500
+ S1 = IV(S)
+ CALL DS7LVM(PS, V(TEMP2), V(S1), V(STEP1))
+ CALL DV2AXY(PS, V(TEMP1), ONE, V(TEMP2), V(TEMP1))
+C
+C *** SAVE OLD GRADIENT AND COMPUTE NEW ONE ***
+C
+ 500 IV(NGCALL) = IV(NGCALL) + 1
+ G01 = IV(W)
+ CALL DV7CPY(P, V(G01), G)
+ GO TO 690
+C
+C *** INITIALIZATIONS -- G0 = G - G0, ETC. ***
+C
+ 510 G01 = IV(W)
+ CALL DV2AXY(P, V(G01), NEGONE, V(G01), G)
+ STEP1 = IV(STEP)
+ TEMP1 = STEP1 + P
+ TEMP2 = IV(X0)
+ IF (IV(IRC) .NE. 3) GO TO 540
+C
+C *** SET V(RADFAC) BY GRADIENT TESTS ***
+C
+C *** SET TEMP1 = D**-1 * (HESSIAN * STEP + (G(X0) - G(X))) ***
+C
+ K = TEMP1
+ L = G01
+ DO 520 I = 1, P
+ V(K) = (V(K) - V(L)) / D(I)
+ K = K + 1
+ L = L + 1
+ 520 CONTINUE
+C
+C *** DO GRADIENT TESTS ***
+C
+ IF (DV2NRM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 530
+ IF (DD7TPR(P, G, V(STEP1))
+ 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 540
+ 530 V(RADFAC) = V(INCFAC)
+C
+C *** COMPUTE Y VECTOR NEEDED FOR UPDATING S ***
+C
+ 540 CALL DV2AXY(PS, Y, NEGONE, Y, G)
+C
+C *** DETERMINE SIZING FACTOR V(SIZE) ***
+C
+C *** SET TEMP1 = S * STEP ***
+ S1 = IV(S)
+ CALL DS7LVM(PS, V(TEMP1), V(S1), V(STEP1))
+C
+ T1 = DABS(DD7TPR(PS, V(STEP1), V(TEMP1)))
+ T = DABS(DD7TPR(PS, V(STEP1), Y))
+ V(SIZE) = ONE
+ IF (T .LT. T1) V(SIZE) = T / T1
+C
+C *** SET G0 TO WCHMTD CHOICE OF FLETCHER AND AL-BAALI ***
+C
+ HC1 = IV(HC)
+ IF (HC1 .LE. 0) GO TO 550
+ CALL DS7LVM(PS, V(G01), V(HC1), V(STEP1))
+ GO TO 560
+C
+ 550 RMAT1 = IV(RMAT)
+ IPIV0 = IV(IPIVOT)
+ CALL DV7CPY(P, V(G01), V(STEP1))
+ I = G01 + PS
+ IF (PS .LT. P) CALL DV7SCP(P-PS, V(I), ZERO)
+ CALL DV7IPR(P, IV(IPIV0), V(G01))
+ CALL DL7TVM(P, V(G01), V(RMAT1), V(G01))
+ CALL DL7VML(P, V(G01), V(RMAT1), V(G01))
+ IPIV1 = IV(PERM) + P
+ CALL I7PNVR(P, IV(IPIV1), IV(IPIV0))
+ CALL DV7IPR(P, IV(IPIV1), V(G01))
+C
+ 560 CALL DV2AXY(PS, V(G01), ONE, Y, V(G01))
+C
+C *** UPDATE S ***
+C
+ CALL DS7LUP(V(S1), V(COSMIN), PS, V(SIZE), V(STEP1), V(TEMP1),
+ 1 V(TEMP2), V(G01), V(WSCALE), Y)
+ IV(1) = 2
+ GO TO 180
+C
+C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
+C
+C *** BAD PARAMETERS TO ASSESS ***
+C
+ 570 IV(1) = 64
+ GO TO 999
+C
+C
+C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE ***
+C
+ 580 IF (IV(RDREQ) .EQ. 0) GO TO 660
+ IF (IV(FDH) .NE. 0) GO TO 660
+ IF (IV(CNVCOD) .GE. 7) GO TO 660
+ IF (IV(REGD) .GT. 0) GO TO 660
+ IF (IV(COVMAT) .GT. 0) GO TO 660
+ IF (IABS(IV(COVREQ)) .GE. 3) GO TO 640
+ IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2
+ GO TO 600
+C
+C *** COMPUTE FINITE-DIFFERENCE HESSIAN FOR COMPUTING COVARIANCE ***
+C
+ 590 IV(RESTOR) = 0
+ 600 CALL DF7DHB(B, D, G, I, IV, LIV, LV, P, V, X)
+ GO TO (610, 620, 630), I
+ 610 IV(NFCOV) = IV(NFCOV) + 1
+ IV(NFCALL) = IV(NFCALL) + 1
+ IV(1) = 1
+ GO TO 710
+C
+ 620 IV(NGCOV) = IV(NGCOV) + 1
+ IV(NGCALL) = IV(NGCALL) + 1
+ IV(NFGCAL) = IV(NFCALL) + IV(NGCOV)
+ GO TO 690
+C
+ 630 IF (IV(CNVCOD) .EQ. 70) GO TO 120
+ GO TO 660
+C
+ 640 H1 = IABS(IV(H))
+ IV(FDH) = H1
+ IV(H) = -H1
+ HC1 = IV(HC)
+ IF (HC1 .LE. 0) GO TO 650
+ CALL DV7CPY(P*(P+1)/2, V(H1), V(HC1))
+ GO TO 660
+ 650 RMAT1 = IV(RMAT)
+ CALL DL7SQR(P, V(H1), V(RMAT1))
+C
+ 660 IV(MODE) = 0
+ IV(1) = IV(CNVCOD)
+ IV(CNVCOD) = 0
+ GO TO 999
+C
+C *** SPECIAL RETURN FOR MISSING HESSIAN INFORMATION -- BOTH
+C *** IV(HC) .LE. 0 AND IV(RMAT) .LE. 0
+C
+ 670 IV(1) = 1400
+ GO TO 999
+C
+C *** INCONSISTENT B ***
+C
+ 680 IV(1) = 82
+ GO TO 999
+C
+C *** SAVE, THEN INITIALIZE IPIVOT ARRAY BEFORE COMPUTING G ***
+C
+ 690 IV(1) = 2
+ J = IV(IPIVOT)
+ IPI = IV(PERM)
+ CALL I7PNVR(P, IV(IPI), IV(J))
+ DO 700 I = 1, P
+ IV(J) = I
+ J = J + 1
+ 700 CONTINUE
+C
+C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) ***
+C
+ 710 DO 720 I = 1, P
+ IF (X(I) .LT. B(1,I)) X(I) = B(1,I)
+ IF (X(I) .GT. B(2,I)) X(I) = B(2,I)
+ 720 CONTINUE
+ IV(TOOBIG) = 0
+C
+ 999 RETURN
+C
+C *** LAST LINE OF DG7ITB FOLLOWS ***
+ END
+ SUBROUTINE DRNSGB(A, ALF, B, C, DA, IN, IV, L, L1, LA, LIV, LV,
+ 1 N, NDA, P, V, Y)
+C
+C *** ITERATION DRIVER FOR SEPARABLE NONLINEAR LEAST SQUARES,
+C *** WITH SIMPLE BOUNDS ON THE NONLINEAR VARIABLES.
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER L, L1, LA, LIV, LV, N, NDA, P
+ INTEGER IN(2,NDA), IV(LIV)
+C DIMENSION UIPARM(*)
+ DOUBLE PRECISION A(LA,L1), ALF(P), B(2,P), C(L), DA(LA,NDA),
+ 1 V(LV), Y(N)
+C
+C *** PURPOSE ***
+C
+C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE
+C T(1)...T(N), DRNSGB ATTEMPTS TO COMPUTE A LEAST SQUARES FIT
+C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION
+C
+C L
+C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T)
+C J=1 J J L+1
+C
+C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P)
+C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES
+C NONLINEAR PARAMETERS ALF WHICH MINIMIZE
+C
+C 2 N 2
+C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )) ,
+C I=1 I I
+C
+C SUBJECT TO THE SIMPLE BOUND CONSTRAINTS
+C B(1,I) .LE. ALF(I) .LE. B(2,I), I = 1(1)P.
+C
+C THE (L+1)ST TERM IS OPTIONAL.
+C
+C
+C *** PARAMETERS ***
+C
+C A (IN) MATRIX PHI(ALF,T) OF THE MODEL.
+C ALF (I/O) NONLINEAR PARAMETERS.
+C INPUT = INITIAL GUESS,
+C OUTPUT = BEST ESTIMATE FOUND.
+C C (OUT) LINEAR PARAMETERS (ESTIMATED).
+C DA (IN) DERIVATIVES OF COLUMNS OF A WITH RESPECT TO COMPONENTS
+C OF ALF, AS SPECIFIED BY THE IN ARRAY...
+C IN (IN) WHEN DRNSGB IS CALLED WITH IV(1) = 2 OR -2, THEN FOR
+C I = 1(1)NDA, COLUMN I OF DA IS THE PARTIAL
+C DERIVATIVE WITH RESPECT TO ALF(IN(1,I)) OF COLUMN
+C IN(2,I) OF A, UNLESS IV(1,I) IS NOT POSITIVE (IN
+C WHICH CASE COLUMN I OF DA IS IGNORED. IV(1) = -2
+C MEANS THERE ARE MORE COLUMNS OF DA TO COME AND
+C DRNSGB SHOULD RETURN FOR THEM.
+C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR. DRNSGB RETURNS
+C WITH IV(1) = 1 WHEN IT WANTS A TO BE EVALUATED AT
+C ALF AND WITH IV(1) = 2 WHEN IT WANTS DA TO BE
+C EVALUATED AT ALF. WHEN CALLED WITH IV(1) = -2
+C (AFTER A RETURN WITH IV(1) = 2), DRNSGB RETURNS
+C WITH IV(1) = -2 TO GET MORE COLUMNS OF DA.
+C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED.
+C L1 (IN) L+1 IF PHI(L+1) IS IN THE MODEL, L IF NOT.
+C LA (IN) LEAD DIMENSION OF A. MUST BE AT LEAST N.
+C LIV (IN) LENGTH OF IV. MUST BE AT LEAST 110 + L + 4*P.
+C LV (IN) LENGTH OF V. MUST BE AT LEAST
+C 105 + 2*N + L*(L+3)/2 + P*(2*P + 21 + N).
+C N (IN) NUMBER OF OBSERVATIONS.
+C NDA (IN) NUMBER OF COLUMNS IN DA AND IN.
+C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED.
+C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR.
+C Y (IN) RIGHT-HAND SIDE VECTOR.
+C
+C
+C *** EXTERNAL SUBROUTINES ***
+C
+ DOUBLE PRECISION DL7SVX, DL7SVN, DR7MDC
+ EXTERNAL DIVSET,DITSUM, DL7ITV, DL7SVX, DL7SVN, DRN2GB, DQ7APL,
+ 1 DQ7RFH, DR7MDC, DS7CPR,DV2AXY,DV7CPY,DV7PRM, DV7SCP
+C
+C DIVSET.... SUPPLIES DEFAULT PARAMETER VALUES.
+C DITSUM.... PRINTS ITERATION SUMMARY, INITIAL AND FINAL ALF.
+C DL7ITV... APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
+C DL7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX.
+C DL7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX.
+C DRN2GB... UNDERLYING NONLINEAR LEAST-SQUARES SOLVER.
+C DQ7APL... APPLIES HOUSEHOLDER TRANSFORMS STORED BY DQ7RFH.
+C DQ7RFH.... COMPUTES QR FACT. VIA HOUSEHOLDER TRANSFORMS WITH PIVOTING.
+C DR7MDC... RETURNS MACHINE-DEP. CONSTANTS.
+C DS7CPR... PRINTS LINEAR PARAMETERS AT SOLUTION.
+C DV2AXY.... ADDS MULTIPLE OF ONE VECTOR TO ANOTHER.
+C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
+C DV7PRM.... PERMUTES VECTOR.
+C DV7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER.
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER AR1, CSAVE1, D1, DR1, DR1L, I, I1,
+ 1 IPIV1, IER, IV1, J1, JLEN, K, LL1O2, MD, N1, N2,
+ 2 NML, NRAN, R1, R1L, RD1
+ DOUBLE PRECISION SINGTL, T
+ DOUBLE PRECISION MACHEP, NEGONE, SNGFAC, ZERO
+C
+C *** SUBSCRIPTS FOR IV AND V ***
+C
+ INTEGER AR, CSAVE, D, IERS, IPIVS, IV1SAV,
+ 2 IVNEED, J, MODE, NEXTIV, NEXTV,
+ 2 NFCALL, NFGCAL, PERM, R,
+ 3 REGD, REGD0, RESTOR, TOOBIG, VNEED
+C
+C *** IV SUBSCRIPT VALUES ***
+C
+ PARAMETER (AR=110, CSAVE=105, D=27, IERS=108, IPIVS=109,
+ 1 IV1SAV=104, IVNEED=3, J=70, MODE=35, NEXTIV=46,
+ 2 NEXTV=47, NFCALL=6, NFGCAL=7, PERM=58, R=61, REGD=67,
+ 3 REGD0=82, RESTOR=9, TOOBIG=2, VNEED=4)
+ DATA MACHEP/-1.D+0/, NEGONE/-1.D+0/, SNGFAC/1.D+2/, ZERO/0.D+0/
+C
+C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++
+C
+C
+ IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
+ N1 = 1
+ NML = N
+ IV1 = IV(1)
+ IF (IV1 .LE. 2) GO TO 20
+C
+C *** CHECK INPUT INTEGERS ***
+C
+ IF (P .LE. 0) GO TO 240
+ IF (L .LT. 0) GO TO 240
+ IF (N .LE. L) GO TO 240
+ IF (LA .LT. N) GO TO 240
+ IF (IV1 .LT. 12) GO TO 20
+ IF (IV1 .EQ. 14) GO TO 20
+ IF (IV1 .EQ. 12) IV(1) = 13
+C
+C *** FRESH START -- COMPUTE STORAGE REQUIREMENTS ***
+C
+ IF (IV(1) .GT. 16) GO TO 240
+ LL1O2 = L*(L+1)/2
+ JLEN = N*P
+ I = L + P
+ IF (IV(1) .NE. 13) GO TO 10
+ IV(IVNEED) = IV(IVNEED) + L
+ IV(VNEED) = IV(VNEED) + P + 2*N + JLEN + LL1O2 + L
+ 10 IF (IV(PERM) .LE. AR) IV(PERM) = AR + 1
+ CALL DRN2GB(B, V, V, IV, LIV, LV, N, N, N1, NML, P, V, V, V, ALF)
+ IF (IV(1) .NE. 14) GO TO 999
+C
+C *** STORAGE ALLOCATION ***
+C
+ IV(IPIVS) = IV(NEXTIV)
+ IV(NEXTIV) = IV(NEXTIV) + L
+ IV(D) = IV(NEXTV)
+ IV(REGD0) = IV(D) + P
+ IV(AR) = IV(REGD0) + N
+ IV(CSAVE) = IV(AR) + LL1O2
+ IV(J) = IV(CSAVE) + L
+ IV(R) = IV(J) + JLEN
+ IV(NEXTV) = IV(R) + N
+ IV(IERS) = 0
+ IF (IV1 .EQ. 13) GO TO 999
+C
+C *** SET POINTERS INTO IV AND V ***
+C
+ 20 AR1 = IV(AR)
+ D1 = IV(D)
+ DR1 = IV(J)
+ DR1L = DR1 + L
+ R1 = IV(R)
+ R1L = R1 + L
+ RD1 = IV(REGD0)
+ CSAVE1 = IV(CSAVE)
+ NML = N - L
+ IF (IV1 .LE. 2) GO TO 50
+C
+ 30 N2 = NML
+ CALL DRN2GB(B, V(D1), V(DR1L), IV, LIV, LV, NML, N, N1, N2, P,
+ 1 V(R1L), V(RD1), V, ALF)
+ IF (IABS(IV(RESTOR)-2) .EQ. 1 .AND. L .GT. 0)
+ 1 CALL DV7CPY(L, C, V(CSAVE1))
+ IV1 = IV(1)
+ IF (IV1 .EQ. 2) GO TO 150
+ IF (IV1 .GT. 2) GO TO 230
+C
+C *** NEW FUNCTION VALUE (RESIDUAL) NEEDED ***
+C
+ IV(IV1SAV) = IV(1)
+ IV(1) = IABS(IV1)
+ IF (IV(RESTOR) .EQ. 2 .AND. L .GT. 0) CALL DV7CPY(L, V(CSAVE1), C)
+ GO TO 999
+C
+C *** COMPUTE NEW RESIDUAL OR GRADIENT ***
+C
+ 50 IV(1) = IV(IV1SAV)
+ MD = IV(MODE)
+ IF (MD .LE. 0) GO TO 60
+ NML = N
+ DR1L = DR1
+ R1L = R1
+ 60 IF (IV(TOOBIG) .NE. 0) GO TO 30
+ IF (IABS(IV1) .EQ. 2) GO TO 170
+C
+C *** COMPUTE NEW RESIDUAL ***
+C
+ IF (L1 .LE. L) CALL DV7CPY(N, V(R1), Y)
+ IF (L1 .GT. L) CALL DV2AXY(N, V(R1), NEGONE, A(1,L1), Y)
+ IF (MD .GT. 0) GO TO 120
+ IER = 0
+ IF (L .LE. 0) GO TO 110
+ LL1O2 = L * (L + 1) / 2
+ IPIV1 = IV(IPIVS)
+ CALL DQ7RFH(IER, IV(IPIV1), N, LA, 0, L, A, V(AR1), LL1O2, C)
+C
+C *** DETERMINE NUMERICAL RANK OF A ***
+C
+ IF (MACHEP .LE. ZERO) MACHEP = DR7MDC(3)
+ SINGTL = SNGFAC * DBLE(MAX0(L,N)) * MACHEP
+ K = L
+ IF (IER .NE. 0) K = IER - 1
+ 70 IF (K .LE. 0) GO TO 90
+ T = DL7SVX(K, V(AR1), C, C)
+ IF (T .GT. ZERO) T = DL7SVN(K, V(AR1), C, C) / T
+ IF (T .GT. SINGTL) GO TO 80
+ K = K - 1
+ GO TO 70
+C
+C *** RECORD RANK IN IV(IERS)... IV(IERS) = 0 MEANS FULL RANK,
+C *** IV(IERS) .GT. 0 MEANS RANK IV(IERS) - 1.
+C
+ 80 IF (K .GE. L) GO TO 100
+ 90 IER = K + 1
+ CALL DV7SCP(L-K, C(K+1), ZERO)
+ 100 IV(IERS) = IER
+ IF (K .LE. 0) GO TO 110
+C
+C *** APPLY HOUSEHOLDER TRANSFORMATONS TO RESIDUALS...
+C
+ CALL DQ7APL(LA, N, K, A, V(R1), IER)
+C
+C *** COMPUTING C NOW MAY SAVE A FUNCTION EVALUATION AT
+C *** THE LAST ITERATION.
+C
+ CALL DL7ITV(K, C, V(AR1), V(R1))
+ CALL DV7PRM(L, IV(IPIV1), C)
+C
+ 110 IF(IV(1) .LT. 2) GO TO 220
+ GO TO 999
+C
+C
+C *** RESIDUAL COMPUTATION FOR F.D. HESSIAN ***
+C
+ 120 IF (L .LE. 0) GO TO 140
+ DO 130 I = 1, L
+ 130 CALL DV2AXY(N, V(R1), -C(I), A(1,I), V(R1))
+ 140 IF (IV(1) .GT. 0) GO TO 30
+ IV(1) = 2
+ GO TO 160
+C
+C *** NEW GRADIENT (JACOBIAN) NEEDED ***
+C
+ 150 IV(IV1SAV) = IV1
+ IF (IV(NFGCAL) .NE. IV(NFCALL)) IV(1) = 1
+ 160 CALL DV7SCP(N*P, V(DR1), ZERO)
+ GO TO 999
+C
+C *** COMPUTE NEW JACOBIAN ***
+C
+ 170 IF (NDA .LE. 0) GO TO 240
+ DO 180 I = 1, NDA
+ I1 = IN(1,I) - 1
+ IF (I1 .LT. 0) GO TO 180
+ J1 = IN(2,I)
+ K = DR1 + I1*N
+ T = NEGONE
+ IF (J1 .LE. L) T = -C(J1)
+ CALL DV2AXY(N, V(K), T, DA(1,I), V(K))
+ 180 CONTINUE
+ IF (IV1 .EQ. 2) GO TO 190
+ IV(1) = IV1
+ GO TO 999
+ 190 IF (L .LE. 0) GO TO 30
+ IF (MD .GT. 0) GO TO 30
+ K = DR1
+ IER = IV(IERS)
+ NRAN = L
+ IF (IER .GT. 0) NRAN = IER - 1
+ IF (NRAN .LE. 0) GO TO 210
+ DO 200 I = 1, P
+ CALL DQ7APL(LA, N, NRAN, A, V(K), IER)
+ K = K + N
+ 200 CONTINUE
+ 210 CALL DV7CPY(L, V(CSAVE1), C)
+ 220 IF (IER .EQ. 0) GO TO 30
+C
+C *** ADJUST SUBSCRIPTS DESCRIBING R AND DR...
+C
+ NRAN = IER - 1
+ DR1L = DR1 + NRAN
+ NML = N - NRAN
+ R1L = R1 + NRAN
+ GO TO 30
+C
+C *** CONVERGENCE OR LIMIT REACHED ***
+C
+ 230 IF (IV(REGD) .EQ. 1) IV(REGD) = RD1
+ IF (IV(1) .LE. 11) CALL DS7CPR(C, IV, L, LIV)
+ GO TO 999
+C
+ 240 IV(1) = 66
+ CALL DITSUM(V, V, IV, LIV, LV, P, V, ALF)
+C
+ 999 RETURN
+C
+C *** LAST CARD OF DRNSGB FOLLOWS ***
+ END
+ SUBROUTINE DS7LUP(A, COSMIN, P, SIZE, STEP, U, W, WCHMTD, WSCALE,
+ 1 Y)
+C
+C *** UPDATE SYMMETRIC A SO THAT A * STEP = Y ***
+C *** (LOWER TRIANGLE OF A STORED ROWWISE ***
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER P
+ DOUBLE PRECISION A(*), COSMIN, SIZE, STEP(P), U(P), W(P),
+ 1 WCHMTD(P), WSCALE, Y(P)
+C DIMENSION A(P*(P+1)/2)
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER I, J, K
+ DOUBLE PRECISION DENMIN, SDOTWM, T, UI, WI
+C
+C *** CONSTANTS ***
+ DOUBLE PRECISION HALF, ONE, ZERO
+C
+C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
+C
+ DOUBLE PRECISION DD7TPR, DV2NRM
+ EXTERNAL DD7TPR, DS7LVM, DV2NRM
+C
+ PARAMETER (HALF=0.5D+0, ONE=1.D+0, ZERO=0.D+0)
+C
+C-----------------------------------------------------------------------
+C
+ SDOTWM = DD7TPR(P, STEP, WCHMTD)
+ DENMIN = COSMIN * DV2NRM(P,STEP) * DV2NRM(P,WCHMTD)
+ WSCALE = ONE
+ IF (DENMIN .NE. ZERO) WSCALE = DMIN1(ONE, DABS(SDOTWM/DENMIN))
+ T = ZERO
+ IF (SDOTWM .NE. ZERO) T = WSCALE / SDOTWM
+ DO 10 I = 1, P
+ 10 W(I) = T * WCHMTD(I)
+ CALL DS7LVM(P, U, A, STEP)
+ T = HALF * (SIZE * DD7TPR(P, STEP, U) - DD7TPR(P, STEP, Y))
+ DO 20 I = 1, P
+ 20 U(I) = T*W(I) + Y(I) - SIZE*U(I)
+C
+C *** SET A = A + U*(W**T) + W*(U**T) ***
+C
+ K = 1
+ DO 40 I = 1, P
+ UI = U(I)
+ WI = W(I)
+ DO 30 J = 1, I
+ A(K) = SIZE*A(K) + UI*W(J) + WI*U(J)
+ K = K + 1
+ 30 CONTINUE
+ 40 CONTINUE
+C
+ RETURN
+C *** LAST CARD OF DS7LUP FOLLOWS ***
+ END
+ SUBROUTINE DL7MST(D, G, IERR, IPIVOT, KA, P, QTR, R, STEP, V, W)
+C
+C *** COMPUTE LEVENBERG-MARQUARDT STEP USING MORE-HEBDEN TECHNIQUE **
+C *** NL2SOL VERSION 2.2. ***
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER IERR, KA, P
+ INTEGER IPIVOT(P)
+ DOUBLE PRECISION D(P), G(P), QTR(P), R(*), STEP(P), V(21), W(*)
+C DIMENSION W(P*(P+5)/2 + 4)
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+C *** PURPOSE ***
+C
+C GIVEN THE R MATRIX FROM THE QR DECOMPOSITION OF A JACOBIAN
+C MATRIX, J, AS WELL AS Q-TRANSPOSE TIMES THE CORRESPONDING
+C RESIDUAL VECTOR, RESID, THIS SUBROUTINE COMPUTES A LEVENBERG-
+C MARQUARDT STEP OF APPROXIMATE LENGTH V(RADIUS) BY THE MORE-
+C TECHNIQUE.
+C
+C *** PARAMETER DESCRIPTION ***
+C
+C D (IN) = THE SCALE VECTOR.
+C G (IN) = THE GRADIENT VECTOR (J**T)*R.
+C IERR (I/O) = RETURN CODE FROM QRFACT OR DQ7RGS -- 0 MEANS R HAS
+C FULL RANK.
+C IPIVOT (I/O) = PERMUTATION ARRAY FROM QRFACT OR DQ7RGS, WHICH COMPUTE
+C QR DECOMPOSITIONS WITH COLUMN PIVOTING.
+C KA (I/O). KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST CALL ON
+C DL7MST FOR THE CURRENT R AND QTR. ON OUTPUT KA CON-
+C TAINS THE NUMBER OF HEBDEN ITERATIONS NEEDED TO DETERMINE
+C STEP. KA = 0 MEANS A GAUSS-NEWTON STEP.
+C P (IN) = NUMBER OF PARAMETERS.
+C QTR (IN) = (Q**T)*RESID = Q-TRANSPOSE TIMES THE RESIDUAL VECTOR.
+C R (IN) = THE R MATRIX, STORED COMPACTLY BY COLUMNS.
+C STEP (OUT) = THE LEVENBERG-MARQUARDT STEP COMPUTED.
+C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW.
+C W (I/O) = WORKSPACE OF LENGTH P*(P+5)/2 + 4.
+C
+C *** ENTRIES IN V ***
+C
+C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G.
+C V(DSTNRM) (I/O) = 2-NORM OF D*STEP.
+C V(DST0) (I/O) = 2-NORM OF GAUSS-NEWTON STEP (FOR NONSING. J).
+C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED IN TWONORM(R)**2 MINUS
+C TWONORM(R - J*STEP)**2. (SEE ALGORITHM NOTES BELOW.)
+C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP.
+C V(NREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED
+C FOR A GAUSS-NEWTON STEP.
+C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP
+C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE
+C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS).
+C V(PHMXFC) (IN) (SEE V(PHMNFC).)
+C V(PREDUC) (OUT) = HALF THE REDUCTION IN THE SUM OF SQUARES PREDICTED
+C BY THE STEP RETURNED.
+C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION.
+C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL.
+C V(STPPAR) (I/O) = MARQUARDT PARAMETER (OR ITS NEGATIVE IF THE SPECIAL
+C CASE MENTIONED BELOW IN THE ALGORITHM NOTES OCCURS).
+C
+C NOTE -- SEE DATA STATEMENT BELOW FOR VALUES OF ABOVE SUBSCRIPTS.
+C
+C *** USAGE NOTES ***
+C
+C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF
+C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT
+C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS
+C WHY MANY PARAMETERS ARE LISTED AS I/O). ON AN INTIIAL CALL (ONE
+C WITH KA = -1), THE CALLER NEED ONLY HAVE INITIALIZED D, G, KA, P,
+C QTR, R, V(EPSLON), V(PHMNFC), V(PHMXFC), V(RADIUS), AND V(RAD0).
+C
+C *** APPLICATION AND USAGE RESTRICTIONS ***
+C
+C THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR LEAST-
+C SQUARES) PACKAGE (REF. 1).
+C
+C *** ALGORITHM NOTES ***
+C
+C THIS CODE IMPLEMENTS THE STEP COMPUTATION SCHEME DESCRIBED IN
+C REFS. 2 AND 4. FAST GIVENS TRANSFORMATIONS (SEE REF. 3, PP. 60-
+C 62) ARE USED TO COMPUTE STEP WITH A NONZERO MARQUARDT PARAMETER.
+C A SPECIAL CASE OCCURS IF J IS (NEARLY) SINGULAR AND V(RADIUS)
+C IS SUFFICIENTLY LARGE. IN THIS CASE THE STEP RETURNED IS SUCH
+C THAT TWONORM(R)**2 - TWONORM(R - J*STEP)**2 DIFFERS FROM ITS
+C OPTIMAL VALUE BY LESS THAN V(EPSLON) TIMES THIS OPTIMAL VALUE,
+C WHERE J AND R DENOTE THE ORIGINAL JACOBIAN AND RESIDUAL. (SEE
+C REF. 2 FOR MORE DETAILS.)
+C
+C *** FUNCTIONS AND SUBROUTINES CALLED ***
+C
+C DD7TPR - RETURNS INNER PRODUCT OF TWO VECTORS.
+C DL7ITV - APPLY INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
+C DL7IVM - APPLY INVERSE OF COMPACT LOWER TRIANG. MATRIX.
+C DV7CPY - COPIES ONE VECTOR TO ANOTHER.
+C DV2NRM - RETURNS 2-NORM OF A VECTOR.
+C
+C *** REFERENCES ***
+C
+C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
+C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
+C SOFTWARE, VOL. 7, NO. 3.
+C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS,
+C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP.
+C 186-197.
+C 3. LAWSON, C.L., AND HANSON, R.J. (1974), SOLVING LEAST SQUARES
+C PROBLEMS, PRENTICE-HALL, ENGLEWOOD CLIFFS, N.J.
+C 4. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN-
+C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES
+C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER-
+C VERLAG, BERLIN AND NEW YORK.
+C
+C *** GENERAL ***
+C
+C CODED BY DAVID M. GAY.
+C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
+C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
+C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
+C MCS-7906671.
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER DSTSAV, I, IP1, I1, J1, K, KALIM, L, LK0, PHIPIN,
+ 1 PP1O2, RES, RES0, RMAT, RMAT0, UK0
+ DOUBLE PRECISION A, ADI, ALPHAK, B, DFACSQ, DST, DTOL, D1, D2,
+ 1 LK, OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD,
+ 2 SI, SJ, SQRTAK, T, TWOPSI, UK, WL
+C
+C *** CONSTANTS ***
+ DOUBLE PRECISION DFAC, EIGHT, HALF, NEGONE, ONE, P001, THREE,
+ 1 TTOL, ZERO
+ DOUBLE PRECISION BIG
+C
+C *** INTRINSIC FUNCTIONS ***
+C/+
+ DOUBLE PRECISION DSQRT
+C/
+C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
+C
+ DOUBLE PRECISION DD7TPR, DL7SVN, DR7MDC, DV2NRM
+ EXTERNAL DD7TPR, DL7ITV, DL7IVM, DL7SVN, DR7MDC,DV7CPY, DV2NRM
+C
+C *** SUBSCRIPTS FOR V ***
+C
+ INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, NREDUC, PHMNFC,
+ 1 PHMXFC, PREDUC, RADIUS, RAD0, STPPAR
+ PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19, GTSTEP=4,
+ 1 NREDUC=6, PHMNFC=20, PHMXFC=21, PREDUC=7, RADIUS=8,
+ 2 RAD0=9, STPPAR=5)
+C
+ PARAMETER (DFAC=256.D+0, EIGHT=8.D+0, HALF=0.5D+0, NEGONE=-1.D+0,
+ 1 ONE=1.D+0, P001=1.D-3, THREE=3.D+0, TTOL=2.5D+0,
+ 2 ZERO=0.D+0)
+ SAVE BIG
+ DATA BIG/0.D+0/
+C
+C *** BODY ***
+C
+C *** FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK AND UK,
+C *** THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR NONSING. J)
+C *** AND THE VALUE RETURNED AS V(DSTNRM) ARE STORED AT W(LK0),
+C *** W(UK0), W(PHIPIN), AND W(DSTSAV) RESPECTIVELY.
+ LK0 = P + 1
+ PHIPIN = LK0 + 1
+ UK0 = PHIPIN + 1
+ DSTSAV = UK0 + 1
+ RMAT0 = DSTSAV
+C *** A COPY OF THE R-MATRIX FROM THE QR DECOMPOSITION OF J IS
+C *** STORED IN W STARTING AT W(RMAT), AND A COPY OF THE RESIDUAL
+C *** VECTOR IS STORED IN W STARTING AT W(RES). THE LOOPS BELOW
+C *** THAT UPDATE THE QR DECOMP. FOR A NONZERO MARQUARDT PARAMETER
+C *** WORK ON THESE COPIES.
+ RMAT = RMAT0 + 1
+ PP1O2 = P * (P + 1) / 2
+ RES0 = PP1O2 + RMAT0
+ RES = RES0 + 1
+ RAD = V(RADIUS)
+ IF (RAD .GT. ZERO)
+ 1 PSIFAC = V(EPSLON)/((EIGHT*(V(PHMNFC) + ONE) + THREE) * RAD**2)
+ IF (BIG .LE. ZERO) BIG = DR7MDC(6)
+ PHIMAX = V(PHMXFC) * RAD
+ PHIMIN = V(PHMNFC) * RAD
+C *** DTOL, DFAC, AND DFACSQ ARE USED IN RESCALING THE FAST GIVENS
+C *** REPRESENTATION OF THE UPDATED QR DECOMPOSITION.
+ DTOL = ONE/DFAC
+ DFACSQ = DFAC*DFAC
+C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF
+C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT.
+ OLDPHI = ZERO
+ LK = ZERO
+ UK = ZERO
+ KALIM = KA + 12
+C
+C *** START OR RESTART, DEPENDING ON KA ***
+C
+ IF (KA .EQ. 0) GO TO 20
+ IF (KA .GT. 0) GO TO 370
+C
+C *** FRESH START -- COMPUTE V(NREDUC) ***
+C
+ KA = 0
+ KALIM = 12
+ K = P
+ IF (IERR .NE. 0) K = IABS(IERR) - 1
+ V(NREDUC) = HALF*DD7TPR(K, QTR, QTR)
+C
+C *** SET UP TO TRY INITIAL GAUSS-NEWTON STEP ***
+C
+ 20 V(DST0) = NEGONE
+ IF (IERR .NE. 0) GO TO 90
+ T = DL7SVN(P, R, STEP, W(RES))
+ IF (T .GE. ONE) GO TO 30
+ IF (DV2NRM(P, QTR) .GE. BIG*T) GO TO 90
+C
+C *** COMPUTE GAUSS-NEWTON STEP ***
+C
+C *** NOTE -- THE R-MATRIX IS STORED COMPACTLY BY COLUMNS IN
+C *** R(1), R(2), R(3), ... IT IS THE TRANSPOSE OF A
+C *** LOWER TRIANGULAR MATRIX STORED COMPACTLY BY ROWS, AND WE
+C *** TREAT IT AS SUCH WHEN USING DL7ITV AND DL7IVM.
+ 30 CALL DL7ITV(P, W, R, QTR)
+C *** TEMPORARILY STORE PERMUTED -D*STEP IN STEP.
+ DO 60 I = 1, P
+ J1 = IPIVOT(I)
+ STEP(I) = D(J1)*W(I)
+ 60 CONTINUE
+ DST = DV2NRM(P, STEP)
+ V(DST0) = DST
+ PHI = DST - RAD
+ IF (PHI .LE. PHIMAX) GO TO 410
+C *** IF THIS IS A RESTART, GO TO 110 ***
+ IF (KA .GT. 0) GO TO 110
+C
+C *** GAUSS-NEWTON STEP WAS UNACCEPTABLE. COMPUTE L0 ***
+C
+ DO 70 I = 1, P
+ J1 = IPIVOT(I)
+ STEP(I) = D(J1)*(STEP(I)/DST)
+ 70 CONTINUE
+ CALL DL7IVM(P, STEP, R, STEP)
+ T = ONE / DV2NRM(P, STEP)
+ W(PHIPIN) = (T/RAD)*T
+ LK = PHI*W(PHIPIN)
+C
+C *** COMPUTE U0 ***
+C
+ 90 DO 100 I = 1, P
+ 100 W(I) = G(I)/D(I)
+ V(DGNORM) = DV2NRM(P, W)
+ UK = V(DGNORM)/RAD
+ IF (UK .LE. ZERO) GO TO 390
+C
+C *** ALPHAK WILL BE USED AS THE CURRENT MARQUARDT PARAMETER. WE
+C *** USE MORE*S SCHEME FOR INITIALIZING IT.
+C
+ ALPHAK = DABS(V(STPPAR)) * V(RAD0)/RAD
+ ALPHAK = DMIN1(UK, DMAX1(ALPHAK, LK))
+C
+C
+C *** TOP OF LOOP -- INCREMENT KA, COPY R TO RMAT, QTR TO RES ***
+C
+ 110 KA = KA + 1
+ CALL DV7CPY(PP1O2, W(RMAT), R)
+ CALL DV7CPY(P, W(RES), QTR)
+C
+C *** SAFEGUARD ALPHAK AND INITIALIZE FAST GIVENS SCALE VECTOR. ***
+C
+ IF (ALPHAK .LE. ZERO .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK)
+ 1 ALPHAK = UK * DMAX1(P001, DSQRT(LK/UK))
+ IF (ALPHAK .LE. ZERO) ALPHAK = HALF * UK
+ SQRTAK = DSQRT(ALPHAK)
+ DO 120 I = 1, P
+ 120 W(I) = ONE
+C
+C *** ADD ALPHAK*D AND UPDATE QR DECOMP. USING FAST GIVENS TRANS. ***
+C
+ DO 270 I = 1, P
+C *** GENERATE, APPLY 1ST GIVENS TRANS. FOR ROW I OF ALPHAK*D.
+C *** (USE STEP TO STORE TEMPORARY ROW) ***
+ L = I*(I+1)/2 + RMAT0
+ WL = W(L)
+ D2 = ONE
+ D1 = W(I)
+ J1 = IPIVOT(I)
+ ADI = SQRTAK*D(J1)
+ IF (ADI .GE. DABS(WL)) GO TO 150
+ 130 A = ADI/WL
+ B = D2*A/D1
+ T = A*B + ONE
+ IF (T .GT. TTOL) GO TO 150
+ W(I) = D1/T
+ D2 = D2/T
+ W(L) = T*WL
+ A = -A
+ DO 140 J1 = I, P
+ L = L + J1
+ STEP(J1) = A*W(L)
+ 140 CONTINUE
+ GO TO 170
+C
+ 150 B = WL/ADI
+ A = D1*B/D2
+ T = A*B + ONE
+ IF (T .GT. TTOL) GO TO 130
+ W(I) = D2/T
+ D2 = D1/T
+ W(L) = T*ADI
+ DO 160 J1 = I, P
+ L = L + J1
+ WL = W(L)
+ STEP(J1) = -WL
+ W(L) = A*WL
+ 160 CONTINUE
+C
+ 170 IF (I .EQ. P) GO TO 280
+C
+C *** NOW USE GIVENS TRANS. TO ZERO ELEMENTS OF TEMP. ROW ***
+C
+ IP1 = I + 1
+ DO 260 I1 = IP1, P
+ SI = STEP(I1-1)
+ IF (SI .EQ. ZERO) GO TO 260
+ L = I1*(I1+1)/2 + RMAT0
+ WL = W(L)
+ D1 = W(I1)
+C
+C *** RESCALE ROW I1 IF NECESSARY ***
+C
+ IF (D1 .GE. DTOL) GO TO 190
+ D1 = D1*DFACSQ
+ WL = WL/DFAC
+ K = L
+ DO 180 J1 = I1, P
+ K = K + J1
+ W(K) = W(K)/DFAC
+ 180 CONTINUE
+C
+C *** USE GIVENS TRANS. TO ZERO NEXT ELEMENT OF TEMP. ROW
+C
+ 190 IF (DABS(SI) .GT. DABS(WL)) GO TO 220
+ 200 A = SI/WL
+ B = D2*A/D1
+ T = A*B + ONE
+ IF (T .GT. TTOL) GO TO 220
+ W(L) = T*WL
+ W(I1) = D1/T
+ D2 = D2/T
+ DO 210 J1 = I1, P
+ L = L + J1
+ WL = W(L)
+ SJ = STEP(J1)
+ W(L) = WL + B*SJ
+ STEP(J1) = SJ - A*WL
+ 210 CONTINUE
+ GO TO 240
+C
+ 220 B = WL/SI
+ A = D1*B/D2
+ T = A*B + ONE
+ IF (T .GT. TTOL) GO TO 200
+ W(I1) = D2/T
+ D2 = D1/T
+ W(L) = T*SI
+ DO 230 J1 = I1, P
+ L = L + J1
+ WL = W(L)
+ SJ = STEP(J1)
+ W(L) = A*WL + SJ
+ STEP(J1) = B*SJ - WL
+ 230 CONTINUE
+C
+C *** RESCALE TEMP. ROW IF NECESSARY ***
+C
+ 240 IF (D2 .GE. DTOL) GO TO 260
+ D2 = D2*DFACSQ
+ DO 250 K = I1, P
+ 250 STEP(K) = STEP(K)/DFAC
+ 260 CONTINUE
+ 270 CONTINUE
+C
+C *** COMPUTE STEP ***
+C
+ 280 CALL DL7ITV(P, W(RES), W(RMAT), W(RES))
+C *** RECOVER STEP AND STORE PERMUTED -D*STEP AT W(RES) ***
+ DO 290 I = 1, P
+ J1 = IPIVOT(I)
+ K = RES0 + I
+ T = W(K)
+ STEP(J1) = -T
+ W(K) = T*D(J1)
+ 290 CONTINUE
+ DST = DV2NRM(P, W(RES))
+ PHI = DST - RAD
+ IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 430
+ IF (OLDPHI .EQ. PHI) GO TO 430
+ OLDPHI = PHI
+C
+C *** CHECK FOR (AND HANDLE) SPECIAL CASE ***
+C
+ IF (PHI .GT. ZERO) GO TO 310
+ IF (KA .GE. KALIM) GO TO 430
+ TWOPSI = ALPHAK*DST*DST - DD7TPR(P, STEP, G)
+ IF (ALPHAK .GE. TWOPSI*PSIFAC) GO TO 310
+ V(STPPAR) = -ALPHAK
+ GO TO 440
+C
+C *** UNACCEPTABLE STEP -- UPDATE LK, UK, ALPHAK, AND TRY AGAIN ***
+C
+ 300 IF (PHI .LT. ZERO) UK = DMIN1(UK, ALPHAK)
+ GO TO 320
+ 310 IF (PHI .LT. ZERO) UK = ALPHAK
+ 320 DO 330 I = 1, P
+ J1 = IPIVOT(I)
+ K = RES0 + I
+ STEP(I) = D(J1) * (W(K)/DST)
+ 330 CONTINUE
+ CALL DL7IVM(P, STEP, W(RMAT), STEP)
+ DO 340 I = 1, P
+ 340 STEP(I) = STEP(I) / DSQRT(W(I))
+ T = ONE / DV2NRM(P, STEP)
+ ALPHAK = ALPHAK + T*PHI*T/RAD
+ LK = DMAX1(LK, ALPHAK)
+ ALPHAK = LK
+ GO TO 110
+C
+C *** RESTART ***
+C
+ 370 LK = W(LK0)
+ UK = W(UK0)
+ IF (V(DST0) .GT. ZERO .AND. V(DST0) - RAD .LE. PHIMAX) GO TO 20
+ ALPHAK = DABS(V(STPPAR))
+ DST = W(DSTSAV)
+ PHI = DST - RAD
+ T = V(DGNORM)/RAD
+ IF (RAD .GT. V(RAD0)) GO TO 380
+C
+C *** SMALLER RADIUS ***
+ UK = T
+ IF (ALPHAK .LE. ZERO) LK = ZERO
+ IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
+ GO TO 300
+C
+C *** BIGGER RADIUS ***
+ 380 IF (ALPHAK .LE. ZERO .OR. UK .GT. T) UK = T
+ LK = ZERO
+ IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
+ GO TO 300
+C
+C *** SPECIAL CASE -- RAD .LE. 0 OR (G = 0 AND J IS SINGULAR) ***
+C
+ 390 V(STPPAR) = ZERO
+ DST = ZERO
+ LK = ZERO
+ UK = ZERO
+ V(GTSTEP) = ZERO
+ V(PREDUC) = ZERO
+ DO 400 I = 1, P
+ 400 STEP(I) = ZERO
+ GO TO 450
+C
+C *** ACCEPTABLE GAUSS-NEWTON STEP -- RECOVER STEP FROM W ***
+C
+ 410 ALPHAK = ZERO
+ DO 420 I = 1, P
+ J1 = IPIVOT(I)
+ STEP(J1) = -W(I)
+ 420 CONTINUE
+C
+C *** SAVE VALUES FOR USE IN A POSSIBLE RESTART ***
+C
+ 430 V(STPPAR) = ALPHAK
+ 440 V(GTSTEP) = DMIN1(DD7TPR(P,STEP,G), ZERO)
+ V(PREDUC) = HALF * (ALPHAK*DST*DST - V(GTSTEP))
+ 450 V(DSTNRM) = DST
+ W(DSTSAV) = DST
+ W(LK0) = LK
+ W(UK0) = UK
+ V(RAD0) = RAD
+C
+ RETURN
+C
+C *** LAST CARD OF DL7MST FOLLOWS ***
+ END
+ SUBROUTINE DRMNFB(B, D, FX, IV, LIV, LV, P, V, X)
+C
+C *** ITERATION DRIVER FOR DMNF...
+C *** MINIMIZE GENERAL UNCONSTRAINED OBJECTIVE FUNCTION USING
+C *** FINITE-DIFFERENCE GRADIENTS AND SECANT HESSIAN APPROXIMATIONS.
+C
+ INTEGER LIV, LV, P
+ INTEGER IV(LIV)
+ DOUBLE PRECISION B(2,P), D(P), FX, X(P), V(LV)
+C DIMENSION IV(59 + P), V(77 + P*(P+23)/2)
+C
+C *** PURPOSE ***
+C
+C THIS ROUTINE INTERACTS WITH SUBROUTINE DRMNGB IN AN ATTEMPT
+C TO FIND AN P-VECTOR X* THAT MINIMIZES THE (UNCONSTRAINED)
+C OBJECTIVE FUNCTION FX = F(X) COMPUTED BY THE CALLER. (OFTEN
+C THE X* FOUND IS A LOCAL MINIMIZER RATHER THAN A GLOBAL ONE.)
+C
+C *** PARAMETERS ***
+C
+C THE PARAMETERS FOR DRMNFB ARE THE SAME AS THOSE FOR DMNG
+C (WHICH SEE), EXCEPT THAT CALCF, CALCG, UIPARM, URPARM, AND UFPARM
+C ARE OMITTED, AND A PARAMETER FX FOR THE OBJECTIVE FUNCTION
+C VALUE AT X IS ADDED. INSTEAD OF CALLING CALCG TO OBTAIN THE
+C GRADIENT OF THE OBJECTIVE FUNCTION AT X, DRMNFB CALLS DS3GRD,
+C WHICH COMPUTES AN APPROXIMATION TO THE GRADIENT BY FINITE
+C (FORWARD AND CENTRAL) DIFFERENCES USING THE METHOD OF REF. 1.
+C THE FOLLOWING INPUT COMPONENT IS OF INTEREST IN THIS REGARD
+C (AND IS NOT DESCRIBED IN DMNG).
+C
+C V(ETA0)..... V(42) IS AN ESTIMATED BOUND ON THE RELATIVE ERROR IN THE
+C OBJECTIVE FUNCTION VALUE COMPUTED BY CALCF...
+C (TRUE VALUE) = (COMPUTED VALUE) * (1 + E),
+C WHERE ABS(E) .LE. V(ETA0). DEFAULT = MACHEP * 10**3,
+C WHERE MACHEP IS THE UNIT ROUNDOFF.
+C
+C THE OUTPUT VALUES IV(NFCALL) AND IV(NGCALL) HAVE DIFFERENT
+C MEANINGS FOR DMNF THAN FOR DMNG...
+C
+C IV(NFCALL)... IV(6) IS THE NUMBER OF CALLS SO FAR MADE ON CALCF (I.E.,
+C FUNCTION EVALUATIONS) EXCLUDING THOSE MADE ONLY FOR
+C COMPUTING GRADIENTS. THE INPUT VALUE IV(MXFCAL) IS A
+C LIMIT ON IV(NFCALL).
+C IV(NGCALL)... IV(30) IS THE NUMBER OF FUNCTION EVALUATIONS MADE ONLY
+C FOR COMPUTING GRADIENTS. THE TOTAL NUMBER OF FUNCTION
+C EVALUATIONS IS THUS IV(NFCALL) + IV(NGCALL).
+C
+C *** REFERENCES ***
+C
+C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
+C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
+C J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
+C.
+C *** GENERAL ***
+C
+C CODED BY DAVID M. GAY (AUGUST 1982).
+C
+C---------------------------- DECLARATIONS ---------------------------
+C
+ DOUBLE PRECISION DD7TPR
+ EXTERNAL DIVSET, DD7TPR, DS3GRD, DRMNGB, DV7SCP
+C
+C DIVSET.... SUPPLIES DEFAULT PARAMETER VALUES.
+C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
+C DS3GRD... COMPUTES FINITE-DIFFERENCE GRADIENT APPROXIMATION.
+C DRMNGB... REVERSE-COMMUNICATION ROUTINE THAT DOES DMNGB ALGORITHM.
+C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
+C
+ INTEGER ALPHA, ALPHA0, G1, I, IPI, IV1, J, K, W
+ DOUBLE PRECISION ZERO
+C
+C *** SUBSCRIPTS FOR IV ***
+C
+ INTEGER ETA0, F, G, LMAT, NEXTV, NGCALL,
+ 1 NITER, PERM, SGIRC, TOOBIG, VNEED
+C
+ PARAMETER (ETA0=42, F=10, G=28, LMAT=42, NEXTV=47, NGCALL=30,
+ 1 NITER=31, PERM=58, SGIRC=57, TOOBIG=2, VNEED=4)
+ PARAMETER (ZERO=0.D+0)
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ IV1 = IV(1)
+ IF (IV1 .EQ. 1) GO TO 10
+ IF (IV1 .EQ. 2) GO TO 50
+ IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
+ IV1 = IV(1)
+ IF (IV1 .EQ. 12 .OR. IV1 .EQ. 13) IV(VNEED) = IV(VNEED) + 2*P + 6
+ IF (IV1 .EQ. 14) GO TO 10
+ IF (IV1 .GT. 2 .AND. IV1 .LT. 12) GO TO 10
+ G1 = 1
+ IF (IV1 .EQ. 12) IV(1) = 13
+ GO TO 20
+C
+ 10 G1 = IV(G)
+C
+ 20 CALL DRMNGB(B, D, FX, V(G1), IV, LIV, LV, P, V, X)
+ IF (IV(1) .LT. 2) GO TO 999
+ IF (IV(1) .GT. 2) GO TO 80
+C
+C *** COMPUTE GRADIENT ***
+C
+ IF (IV(NITER) .EQ. 0) CALL DV7SCP(P, V(G1), ZERO)
+ J = IV(LMAT)
+ ALPHA0 = G1 - P - 1
+ IPI = IV(PERM)
+ DO 40 I = 1, P
+ K = ALPHA0 + IV(IPI)
+ V(K) = DD7TPR(I, V(J), V(J))
+ IPI = IPI + 1
+ J = J + I
+ 40 CONTINUE
+C *** UNDO INCREMENT OF IV(NGCALL) DONE BY DRMNGB ***
+ IV(NGCALL) = IV(NGCALL) - 1
+C *** STORE RETURN CODE FROM DS3GRD IN IV(SGIRC) ***
+ IV(SGIRC) = 0
+C *** X MAY HAVE BEEN RESTORED, SO COPY BACK FX... ***
+ FX = V(F)
+ GO TO 60
+C
+C *** GRADIENT LOOP ***
+C
+ 50 IF (IV(TOOBIG) .NE. 0) GO TO 10
+C
+ 60 G1 = IV(G)
+ ALPHA = G1 - P
+ W = ALPHA - 6
+ CALL DS3GRD(V(ALPHA), B, D, V(ETA0), FX, V(G1), IV(SGIRC), P,
+ 1 V(W), X)
+ I = IV(SGIRC)
+ IF (I .EQ. 0) GO TO 10
+ IF (I .LE. P) GO TO 70
+ IV(TOOBIG) = 1
+ GO TO 10
+C
+ 70 IV(NGCALL) = IV(NGCALL) + 1
+ GO TO 999
+C
+ 80 IF (IV(1) .NE. 14) GO TO 999
+C
+C *** STORAGE ALLOCATION ***
+C
+ IV(G) = IV(NEXTV) + P + 6
+ IV(NEXTV) = IV(G) + P
+ IF (IV1 .NE. 13) GO TO 10
+C
+ 999 RETURN
+C *** LAST CARD OF DRMNFB FOLLOWS ***
+ END
+ SUBROUTINE D7EGR(N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,IWA,BWA)
+ INTEGER N
+ INTEGER INDROW(1),JPNTR(1),INDCOL(1),IPNTR(1),NDEG(N),IWA(N)
+ LOGICAL BWA(N)
+C **********
+C
+C SUBROUTINE D7EGR
+C
+C GIVEN THE SPARSITY PATTERN OF AN M BY N MATRIX A,
+C THIS SUBROUTINE DETERMINES THE DEGREE SEQUENCE FOR
+C THE INTERSECTION GRAPH OF THE COLUMNS OF A.
+C
+C IN GRAPH-THEORY TERMINOLOGY, THE INTERSECTION GRAPH OF
+C THE COLUMNS OF A IS THE LOOPLESS GRAPH G WITH VERTICES
+C A(J), J = 1,2,...,N WHERE A(J) IS THE J-TH COLUMN OF A
+C AND WITH EDGE (A(I),A(J)) IF AND ONLY IF COLUMNS I AND J
+C HAVE A NON-ZERO IN THE SAME ROW POSITION.
+C
+C NOTE THAT THE VALUE OF M IS NOT NEEDED BY D7EGR AND IS
+C THEREFORE NOT PRESENT IN THE SUBROUTINE STATEMENT.
+C
+C THE SUBROUTINE STATEMENT IS
+C
+C SUBROUTINE D7EGR(N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,IWA,BWA)
+C
+C WHERE
+C
+C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C OF COLUMNS OF A.
+C
+C INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW
+C INDICES FOR THE NON-ZEROES IN THE MATRIX A.
+C
+C JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH
+C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW.
+C THE ROW INDICES FOR COLUMN J ARE
+C
+C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1.
+C
+C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO
+C ELEMENTS OF THE MATRIX A.
+C
+C INDCOL IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE
+C COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A.
+C
+C IPNTR IS AN INTEGER INPUT ARRAY OF LENGTH M + 1 WHICH
+C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL.
+C THE COLUMN INDICES FOR ROW I ARE
+C
+C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1.
+C
+C NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO
+C ELEMENTS OF THE MATRIX A.
+C
+C NDEG IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH
+C SPECIFIES THE DEGREE SEQUENCE. THE DEGREE OF THE
+C J-TH COLUMN OF A IS NDEG(J).
+C
+C IWA IS AN INTEGER WORK ARRAY OF LENGTH N.
+C
+C BWA IS A LOGICAL WORK ARRAY OF LENGTH N.
+C
+C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982.
+C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE
+C
+C **********
+ INTEGER DEG,IC,IP,IPL,IPU,IR,JCOL,JP,JPL,JPU
+C
+C INITIALIZATION BLOCK.
+C
+ DO 10 JP = 1, N
+ NDEG(JP) = 0
+ BWA(JP) = .FALSE.
+ 10 CONTINUE
+C
+C COMPUTE THE DEGREE SEQUENCE BY DETERMINING THE CONTRIBUTIONS
+C TO THE DEGREES FROM THE CURRENT(JCOL) COLUMN AND FURTHER
+C COLUMNS WHICH HAVE NOT YET BEEN CONSIDERED.
+C
+ IF (N .LT. 2) GO TO 90
+ DO 80 JCOL = 2, N
+ BWA(JCOL) = .TRUE.
+ DEG = 0
+C
+C DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND
+C TO NON-ZEROES IN THE MATRIX.
+C
+ JPL = JPNTR(JCOL)
+ JPU = JPNTR(JCOL+1) - 1
+ IF (JPU .LT. JPL) GO TO 50
+ DO 40 JP = JPL, JPU
+ IR = INDROW(JP)
+C
+C FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC)
+C WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX.
+C
+ IPL = IPNTR(IR)
+ IPU = IPNTR(IR+1) - 1
+ DO 30 IP = IPL, IPU
+ IC = INDCOL(IP)
+C
+C ARRAY BWA MARKS COLUMNS WHICH HAVE CONTRIBUTED TO
+C THE DEGREE COUNT OF COLUMN JCOL. UPDATE THE DEGREE
+C COUNTS OF THESE COLUMNS. ARRAY IWA RECORDS THE
+C MARKED COLUMNS.
+C
+ IF (BWA(IC)) GO TO 20
+ BWA(IC) = .TRUE.
+ NDEG(IC) = NDEG(IC) + 1
+ DEG = DEG + 1
+ IWA(DEG) = IC
+ 20 CONTINUE
+ 30 CONTINUE
+ 40 CONTINUE
+ 50 CONTINUE
+C
+C UN-MARK THE COLUMNS RECORDED BY IWA AND FINALIZE THE
+C DEGREE COUNT OF COLUMN JCOL.
+C
+ IF (DEG .LT. 1) GO TO 70
+ DO 60 JP = 1, DEG
+ IC = IWA(JP)
+ BWA(IC) = .FALSE.
+ 60 CONTINUE
+ NDEG(JCOL) = NDEG(JCOL) + DEG
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+ RETURN
+C
+C LAST CARD OF SUBROUTINE D7EGR.
+C
+ END
+ SUBROUTINE DRMNG(D, FX, G, IV, LIV, LV, N, V, X)
+C
+C *** CARRY OUT DMNG (UNCONSTRAINED MINIMIZATION) ITERATIONS, USING
+C *** DOUBLE-DOGLEG/BFGS STEPS.
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER LIV, LV, N
+ INTEGER IV(LIV)
+ DOUBLE PRECISION D(N), FX, G(N), V(LV), X(N)
+C
+C-------------------------- PARAMETER USAGE --------------------------
+C
+C D.... SCALE VECTOR.
+C FX... FUNCTION VALUE.
+C G.... GRADIENT VECTOR.
+C IV... INTEGER VALUE ARRAY.
+C LIV.. LENGTH OF IV (AT LEAST 60).
+C LV... LENGTH OF V (AT LEAST 71 + N*(N+13)/2).
+C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G).
+C V.... FLOATING-POINT VALUE ARRAY.
+C X.... VECTOR OF PARAMETERS TO BE OPTIMIZED.
+C
+C *** DISCUSSION ***
+C
+C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING
+C ONES TO DMNG (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE
+C THE PART OF V THAT DMNG USES FOR STORING G IS NOT NEEDED).
+C MOREOVER, COMPARED WITH DMNG, IV(1) MAY HAVE THE TWO ADDITIONAL
+C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE
+C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN
+C OUTPUT VALUE FROM DMNG (AND DMNF), IS NOT REFERENCED BY
+C DRMNG OR THE SUBROUTINES IT CALLS.
+C FX AND G NEED NOT HAVE BEEN INITIALIZED WHEN DRMNG IS CALLED
+C WITH IV(1) = 12, 13, OR 14.
+C
+C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE
+C AT X, AND CALL DRMNG AGAIN, HAVING CHANGED NONE OF THE
+C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE
+C (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN BECAUSE
+C OF AN OVERSIZED STEP. IN THIS CASE THE CALLER SHOULD SET
+C IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE DRMNG TO IG-
+C NORE FX AND TRY A SMALLER STEP. THE PARAMETER NF THAT
+C DMNG PASSES TO CALCF (FOR POSSIBLE USE BY CALCG) IS A
+C COPY OF IV(NFCALL) = IV(6).
+C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT VECTOR
+C OF F AT X, AND CALL DRMNG AGAIN, HAVING CHANGED NONE OF
+C THE OTHER PARAMETERS EXCEPT POSSIBLY THE SCALE VECTOR D
+C WHEN IV(DTYPE) = 0. THE PARAMETER NF THAT DMNG PASSES
+C TO CALCG IS IV(NFGCAL) = IV(7). IF G(X) CANNOT BE
+C EVALUATED, THEN THE CALLER MAY SET IV(TOOBIG) TO 0, IN
+C WHICH CASE DRMNG WILL RETURN WITH IV(1) = 65.
+C.
+C *** GENERAL ***
+C
+C CODED BY DAVID M. GAY (DECEMBER 1979). REVISED SEPT. 1982.
+C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
+C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
+C MCS-7600324 AND MCS-7906671.
+C
+C (SEE DMNG FOR REFERENCES.)
+C
+C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER DG1, DUMMY, G01, I, K, L, LSTGST, NWTST1, RSTRST, STEP1,
+ 1 TEMP1, W, X01, Z
+ DOUBLE PRECISION T
+C
+C *** CONSTANTS ***
+C
+ DOUBLE PRECISION HALF, NEGONE, ONE, ONEP2, ZERO
+C
+C *** NO INTRINSIC FUNCTIONS ***
+C
+C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
+C
+ LOGICAL STOPX
+ DOUBLE PRECISION DD7TPR, DRLDST, DV2NRM
+ EXTERNAL DA7SST,DD7DOG,DIVSET, DD7TPR,DITSUM, DL7ITV, DL7IVM,
+ 1 DL7TVM, DL7UPD,DL7VML,DPARCK, DRLDST, STOPX,DV2AXY,
+ 2 DV7CPY, DV7SCP, DV7VMP, DV2NRM, DW7ZBF
+C
+C DA7SST.... ASSESSES CANDIDATE STEP.
+C DD7DOG.... COMPUTES DOUBLE-DOGLEG (CANDIDATE) STEP.
+C DIVSET.... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS.
+C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
+C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
+C DL7ITV... MULTIPLIES INVERSE TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR.
+C DL7IVM... MULTIPLIES INVERSE OF LOWER TRIANGLE TIMES VECTOR.
+C DL7TVM... MULTIPLIES TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR.
+C LUPDT.... UPDATES CHOLESKY FACTOR OF HESSIAN APPROXIMATION.
+C DL7VML.... MULTIPLIES LOWER TRIANGLE TIMES VECTOR.
+C DPARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES.
+C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
+C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
+C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
+C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
+C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
+C DV7VMP... MULTIPLIES VECTOR BY VECTOR RAISED TO POWER (COMPONENTWISE).
+C DV2NRM... RETURNS THE 2-NORM OF A VECTOR.
+C DW7ZBF... COMPUTES W AND Z FOR DL7UPD CORRESPONDING TO BFGS UPDATE.
+C
+C *** SUBSCRIPTS FOR IV AND V ***
+C
+ INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, DST0, F, F0, FDIF,
+ 1 GTHG, GTSTEP, G0, INCFAC, INITH, IRC, KAGQT, LMAT, LMAX0,
+ 2 LMAXS, MODE, MODEL, MXFCAL, MXITER, NEXTV, NFCALL, NFGCAL,
+ 3 NGCALL, NITER, NREDUC, NWTSTP, PREDUC, RADFAC, RADINC,
+ 4 RADIUS, RAD0, RELDX, RESTOR, STEP, STGLIM, STLSTG, TOOBIG,
+ 5 TUNER4, TUNER5, VNEED, XIRC, X0
+C
+C *** IV SUBSCRIPT VALUES ***
+C
+ PARAMETER (CNVCOD=55, DG=37, G0=48, INITH=25, IRC=29, KAGQT=33,
+ 1 MODE=35, MODEL=5, MXFCAL=17, MXITER=18, NFCALL=6,
+ 2 NFGCAL=7, NGCALL=30, NITER=31, NWTSTP=34, RADINC=8,
+ 3 RESTOR=9, STEP=40, STGLIM=11, STLSTG=41, TOOBIG=2,
+ 4 VNEED=4, XIRC=13, X0=43)
+C
+C *** V SUBSCRIPT VALUES ***
+C
+ PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, DST0=3, F=10, F0=13,
+ 1 FDIF=11, GTHG=44, GTSTEP=4, INCFAC=23, LMAT=42,
+ 2 LMAX0=35, LMAXS=36, NEXTV=47, NREDUC=6, PREDUC=7,
+ 3 RADFAC=16, RADIUS=8, RAD0=9, RELDX=17, TUNER4=29,
+ 4 TUNER5=30)
+C
+ PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0,
+ 1 ZERO=0.D+0)
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ I = IV(1)
+ IF (I .EQ. 1) GO TO 50
+ IF (I .EQ. 2) GO TO 60
+C
+C *** CHECK VALIDITY OF IV AND V INPUT VALUES ***
+C
+ IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
+ IF (IV(1) .EQ. 12 .OR. IV(1) .EQ. 13)
+ 1 IV(VNEED) = IV(VNEED) + N*(N+13)/2
+ CALL DPARCK(2, D, IV, LIV, LV, N, V)
+ I = IV(1) - 2
+ IF (I .GT. 12) GO TO 999
+ GO TO (190, 190, 190, 190, 190, 190, 120, 90, 120, 10, 10, 20), I
+C
+C *** STORAGE ALLOCATION ***
+C
+ 10 L = IV(LMAT)
+ IV(X0) = L + N*(N+1)/2
+ IV(STEP) = IV(X0) + N
+ IV(STLSTG) = IV(STEP) + N
+ IV(G0) = IV(STLSTG) + N
+ IV(NWTSTP) = IV(G0) + N
+ IV(DG) = IV(NWTSTP) + N
+ IV(NEXTV) = IV(DG) + N
+ IF (IV(1) .NE. 13) GO TO 20
+ IV(1) = 14
+ GO TO 999
+C
+C *** INITIALIZATION ***
+C
+ 20 IV(NITER) = 0
+ IV(NFCALL) = 1
+ IV(NGCALL) = 1
+ IV(NFGCAL) = 1
+ IV(MODE) = -1
+ IV(MODEL) = 1
+ IV(STGLIM) = 1
+ IV(TOOBIG) = 0
+ IV(CNVCOD) = 0
+ IV(RADINC) = 0
+ V(RAD0) = ZERO
+ IF (V(DINIT) .GE. ZERO) CALL DV7SCP(N, D, V(DINIT))
+ IF (IV(INITH) .NE. 1) GO TO 40
+C
+C *** SET THE INITIAL HESSIAN APPROXIMATION TO DIAG(D)**-2 ***
+C
+ L = IV(LMAT)
+ CALL DV7SCP(N*(N+1)/2, V(L), ZERO)
+ K = L - 1
+ DO 30 I = 1, N
+ K = K + I
+ T = D(I)
+ IF (T .LE. ZERO) T = ONE
+ V(K) = T
+ 30 CONTINUE
+C
+C *** COMPUTE INITIAL FUNCTION VALUE ***
+C
+ 40 IV(1) = 1
+ GO TO 999
+C
+ 50 V(F) = FX
+ IF (IV(MODE) .GE. 0) GO TO 190
+ V(F0) = FX
+ IV(1) = 2
+ IF (IV(TOOBIG) .EQ. 0) GO TO 999
+ IV(1) = 63
+ GO TO 350
+C
+C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
+C
+ 60 IF (IV(TOOBIG) .EQ. 0) GO TO 70
+ IV(1) = 65
+ GO TO 350
+C
+ 70 DG1 = IV(DG)
+ CALL DV7VMP(N, V(DG1), G, D, -1)
+ V(DGNORM) = DV2NRM(N, V(DG1))
+C
+ IF (IV(CNVCOD) .NE. 0) GO TO 340
+ IF (IV(MODE) .EQ. 0) GO TO 300
+C
+C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) ***
+C
+ V(RADIUS) = V(LMAX0)
+C
+ IV(MODE) = 0
+C
+C
+C----------------------------- MAIN LOOP -----------------------------
+C
+C
+C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
+C
+ 80 CALL DITSUM(D, G, IV, LIV, LV, N, V, X)
+ 90 K = IV(NITER)
+ IF (K .LT. IV(MXITER)) GO TO 100
+ IV(1) = 10
+ GO TO 350
+C
+C *** UPDATE RADIUS ***
+C
+ 100 IV(NITER) = K + 1
+ IF (K .GT. 0) V(RADIUS) = V(RADFAC) * V(DSTNRM)
+C
+C *** INITIALIZE FOR START OF NEXT ITERATION ***
+C
+ G01 = IV(G0)
+ X01 = IV(X0)
+ V(F0) = V(F)
+ IV(IRC) = 4
+ IV(KAGQT) = -1
+C
+C *** COPY X TO X0, G TO G0 ***
+C
+ CALL DV7CPY(N, V(X01), X)
+ CALL DV7CPY(N, V(G01), G)
+C
+C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
+C
+ 110 IF (.NOT. STOPX(DUMMY)) GO TO 130
+ IV(1) = 11
+ GO TO 140
+C
+C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
+C
+ 120 IF (V(F) .GE. V(F0)) GO TO 130
+ V(RADFAC) = ONE
+ K = IV(NITER)
+ GO TO 100
+C
+ 130 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 150
+ IV(1) = 9
+ 140 IF (V(F) .GE. V(F0)) GO TO 350
+C
+C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
+C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
+C
+ IV(CNVCOD) = IV(1)
+ GO TO 290
+C
+C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
+C
+ 150 STEP1 = IV(STEP)
+ DG1 = IV(DG)
+ NWTST1 = IV(NWTSTP)
+ IF (IV(KAGQT) .GE. 0) GO TO 160
+ L = IV(LMAT)
+ CALL DL7IVM(N, V(NWTST1), V(L), G)
+ V(NREDUC) = HALF * DD7TPR(N, V(NWTST1), V(NWTST1))
+ CALL DL7ITV(N, V(NWTST1), V(L), V(NWTST1))
+ CALL DV7VMP(N, V(STEP1), V(NWTST1), D, 1)
+ V(DST0) = DV2NRM(N, V(STEP1))
+ CALL DV7VMP(N, V(DG1), V(DG1), D, -1)
+ CALL DL7TVM(N, V(STEP1), V(L), V(DG1))
+ V(GTHG) = DV2NRM(N, V(STEP1))
+ IV(KAGQT) = 0
+ 160 CALL DD7DOG(V(DG1), LV, N, V(NWTST1), V(STEP1), V)
+ IF (IV(IRC) .NE. 6) GO TO 170
+ IF (IV(RESTOR) .NE. 2) GO TO 190
+ RSTRST = 2
+ GO TO 200
+C
+C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
+C
+ 170 IV(TOOBIG) = 0
+ IF (V(DSTNRM) .LE. ZERO) GO TO 190
+ IF (IV(IRC) .NE. 5) GO TO 180
+ IF (V(RADFAC) .LE. ONE) GO TO 180
+ IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 180
+ IF (IV(RESTOR) .NE. 2) GO TO 190
+ RSTRST = 0
+ GO TO 200
+C
+C *** COMPUTE F(X0 + STEP) ***
+C
+ 180 X01 = IV(X0)
+ STEP1 = IV(STEP)
+ CALL DV2AXY(N, X, ONE, V(STEP1), V(X01))
+ IV(NFCALL) = IV(NFCALL) + 1
+ IV(1) = 1
+ GO TO 999
+C
+C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
+C
+ 190 RSTRST = 3
+ 200 X01 = IV(X0)
+ V(RELDX) = DRLDST(N, D, X, V(X01))
+ CALL DA7SST(IV, LIV, LV, V)
+ STEP1 = IV(STEP)
+ LSTGST = IV(STLSTG)
+ I = IV(RESTOR) + 1
+ GO TO (240, 210, 220, 230), I
+ 210 CALL DV7CPY(N, X, V(X01))
+ GO TO 240
+ 220 CALL DV7CPY(N, V(LSTGST), V(STEP1))
+ GO TO 240
+ 230 CALL DV7CPY(N, V(STEP1), V(LSTGST))
+ CALL DV2AXY(N, X, ONE, V(STEP1), V(X01))
+ V(RELDX) = DRLDST(N, D, X, V(X01))
+ IV(RESTOR) = RSTRST
+C
+ 240 K = IV(IRC)
+ GO TO (250,280,280,280,250,260,270,270,270,270,270,270,330,300), K
+C
+C *** RECOMPUTE STEP WITH CHANGED RADIUS ***
+C
+ 250 V(RADIUS) = V(RADFAC) * V(DSTNRM)
+ GO TO 110
+C
+C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST.
+C
+ 260 V(RADIUS) = V(LMAXS)
+ GO TO 150
+C
+C *** CONVERGENCE OR FALSE CONVERGENCE ***
+C
+ 270 IV(CNVCOD) = K - 4
+ IF (V(F) .GE. V(F0)) GO TO 340
+ IF (IV(XIRC) .EQ. 14) GO TO 340
+ IV(XIRC) = 14
+C
+C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
+C
+ 280 IF (IV(IRC) .NE. 3) GO TO 290
+ STEP1 = IV(STEP)
+ TEMP1 = IV(STLSTG)
+C
+C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS ***
+C
+ L = IV(LMAT)
+ CALL DL7TVM(N, V(TEMP1), V(L), V(STEP1))
+ CALL DL7VML(N, V(TEMP1), V(L), V(TEMP1))
+C
+C *** COMPUTE GRADIENT ***
+C
+ 290 IV(NGCALL) = IV(NGCALL) + 1
+ IV(1) = 2
+ GO TO 999
+C
+C *** INITIALIZATIONS -- G0 = G - G0, ETC. ***
+C
+ 300 G01 = IV(G0)
+ CALL DV2AXY(N, V(G01), NEGONE, V(G01), G)
+ STEP1 = IV(STEP)
+ TEMP1 = IV(STLSTG)
+ IF (IV(IRC) .NE. 3) GO TO 320
+C
+C *** SET V(RADFAC) BY GRADIENT TESTS ***
+C
+C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) ***
+C
+ CALL DV2AXY(N, V(TEMP1), NEGONE, V(G01), V(TEMP1))
+ CALL DV7VMP(N, V(TEMP1), V(TEMP1), D, -1)
+C
+C *** DO GRADIENT TESTS ***
+C
+ IF (DV2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4))
+ 1 GO TO 310
+ IF (DD7TPR(N, G, V(STEP1))
+ 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 320
+ 310 V(RADFAC) = V(INCFAC)
+C
+C *** UPDATE H, LOOP ***
+C
+ 320 W = IV(NWTSTP)
+ Z = IV(X0)
+ L = IV(LMAT)
+ CALL DW7ZBF(V(L), N, V(STEP1), V(W), V(G01), V(Z))
+C
+C ** USE THE N-VECTORS STARTING AT V(STEP1) AND V(G01) FOR SCRATCH..
+ CALL DL7UPD(V(TEMP1), V(STEP1), V(L), V(G01), V(L), N, V(W), V(Z))
+ IV(1) = 2
+ GO TO 80
+C
+C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
+C
+C *** BAD PARAMETERS TO ASSESS ***
+C
+ 330 IV(1) = 64
+ GO TO 350
+C
+C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
+C
+ 340 IV(1) = IV(CNVCOD)
+ IV(CNVCOD) = 0
+ 350 CALL DITSUM(D, G, IV, LIV, LV, N, V, X)
+C
+ 999 RETURN
+C
+C *** LAST LINE OF DRMNG FOLLOWS ***
+ END
+ SUBROUTINE I7DO(M,N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST,
+ * MAXCLQ,IWA1,IWA2,IWA3,IWA4,BWA)
+ INTEGER M,N,MAXCLQ
+ INTEGER INDROW(1),JPNTR(1),INDCOL(1),IPNTR(1),NDEG(N),LIST(N),
+ * IWA1(N),IWA2(N),IWA3(N),IWA4(N)
+ LOGICAL BWA(N)
+C **********
+C
+C SUBROUTINE I7DO
+C
+C GIVEN THE SPARSITY PATTERN OF AN M BY N MATRIX A, THIS
+C SUBROUTINE DETERMINES AN INCIDENCE-DEGREE ORDERING OF THE
+C COLUMNS OF A.
+C
+C THE INCIDENCE-DEGREE ORDERING IS DEFINED FOR THE LOOPLESS
+C GRAPH G WITH VERTICES A(J), J = 1,2,...,N WHERE A(J) IS THE
+C J-TH COLUMN OF A AND WITH EDGE (A(I),A(J)) IF AND ONLY IF
+C COLUMNS I AND J HAVE A NON-ZERO IN THE SAME ROW POSITION.
+C
+C AT EACH STAGE OF I7DO, A COLUMN OF MAXIMAL INCIDENCE IS
+C CHOSEN AND ORDERED. IF JCOL IS AN UN-ORDERED COLUMN, THEN
+C THE INCIDENCE OF JCOL IS THE NUMBER OF ORDERED COLUMNS
+C ADJACENT TO JCOL IN THE GRAPH G. AMONG ALL THE COLUMNS OF
+C MAXIMAL INCIDENCE,I7DO CHOOSES A COLUMN OF MAXIMAL DEGREE.
+C
+C THE SUBROUTINE STATEMENT IS
+C
+C SUBROUTINE I7DO(M,N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST,
+C MAXCLQ,IWA1,IWA2,IWA3,IWA4,BWA)
+C
+C WHERE
+C
+C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C OF ROWS OF A.
+C
+C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C OF COLUMNS OF A.
+C
+C INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW
+C INDICES FOR THE NON-ZEROES IN THE MATRIX A.
+C
+C JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH
+C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW.
+C THE ROW INDICES FOR COLUMN J ARE
+C
+C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1.
+C
+C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO
+C ELEMENTS OF THE MATRIX A.
+C
+C INDCOL IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE
+C COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A.
+C
+C IPNTR IS AN INTEGER INPUT ARRAY OF LENGTH M + 1 WHICH
+C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL.
+C THE COLUMN INDICES FOR ROW I ARE
+C
+C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1.
+C
+C NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO
+C ELEMENTS OF THE MATRIX A.
+C
+C NDEG IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH SPECIFIES
+C THE DEGREE SEQUENCE. THE DEGREE OF THE J-TH COLUMN
+C OF A IS NDEG(J).
+C
+C LIST IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH SPECIFIES
+C THE INCIDENCE-DEGREE ORDERING OF THE COLUMNS OF A. THE J-TH
+C COLUMN IN THIS ORDER IS LIST(J).
+C
+C MAXCLQ IS AN INTEGER OUTPUT VARIABLE SET TO THE SIZE
+C OF THE LARGEST CLIQUE FOUND DURING THE ORDERING.
+C
+C IWA1,IWA2,IWA3, AND IWA4 ARE INTEGER WORK ARRAYS OF LENGTH N.
+C
+C BWA IS A LOGICAL WORK ARRAY OF LENGTH N.
+C
+C SUBPROGRAMS CALLED
+C
+C MINPACK-SUPPLIED ... N7MSRT
+C
+C FORTRAN-SUPPLIED ... MAX0
+C
+C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982.
+C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE
+C
+C **********
+ INTEGER DEG,HEAD,IC,IP,IPL,IPU,IR,JCOL,JP,JPL,JPU,L,MAXINC,
+ * MAXLST,NCOMP,NUMINC,NUMLST,NUMORD,NUMWGT
+C
+C SORT THE DEGREE SEQUENCE.
+C
+ CALL N7MSRT(N,N-1,NDEG,-1,IWA4,IWA1,IWA3)
+C
+C INITIALIZATION BLOCK.
+C
+C CREATE A DOUBLY-LINKED LIST TO ACCESS THE INCIDENCES OF THE
+C COLUMNS. THE POINTERS FOR THE LINKED LIST ARE AS FOLLOWS.
+C
+C EACH UN-ORDERED COLUMN JCOL IS IN A LIST (THE INCIDENCE LIST)
+C OF COLUMNS WITH THE SAME INCIDENCE.
+C
+C IWA1(NUMINC+1) IS THE FIRST COLUMN IN THE NUMINC LIST
+C UNLESS IWA1(NUMINC+1) = 0. IN THIS CASE THERE ARE
+C NO COLUMNS IN THE NUMINC LIST.
+C
+C IWA2(JCOL) IS THE COLUMN BEFORE JCOL IN THE INCIDENCE LIST
+C UNLESS IWA2(JCOL) = 0. IN THIS CASE JCOL IS THE FIRST
+C COLUMN IN THIS INCIDENCE LIST.
+C
+C IWA3(JCOL) IS THE COLUMN AFTER JCOL IN THE INCIDENCE LIST
+C UNLESS IWA3(JCOL) = 0. IN THIS CASE JCOL IS THE LAST
+C COLUMN IN THIS INCIDENCE LIST.
+C
+C IF JCOL IS AN UN-ORDERED COLUMN, THEN LIST(JCOL) IS THE
+C INCIDENCE OF JCOL IN THE GRAPH. IF JCOL IS AN ORDERED COLUMN,
+C THEN LIST(JCOL) IS THE INCIDENCE-DEGREE ORDER OF COLUMN JCOL.
+C
+ MAXINC = 0
+ DO 10 JP = 1, N
+ LIST(JP) = 0
+ BWA(JP) = .FALSE.
+ IWA1(JP) = 0
+ L = IWA4(JP)
+ IF (JP .NE. 1) IWA2(L) = IWA4(JP-1)
+ IF (JP .NE. N) IWA3(L) = IWA4(JP+1)
+ 10 CONTINUE
+ IWA1(1) = IWA4(1)
+ L = IWA4(1)
+ IWA2(L) = 0
+ L = IWA4(N)
+ IWA3(L) = 0
+C
+C DETERMINE THE MAXIMAL SEARCH LENGTH FOR THE LIST
+C OF COLUMNS OF MAXIMAL INCIDENCE.
+C
+ MAXLST = 0
+ DO 20 IR = 1, M
+ MAXLST = MAXLST + (IPNTR(IR+1) - IPNTR(IR))**2
+ 20 CONTINUE
+ MAXLST = MAXLST/N
+ MAXCLQ = 1
+C
+C BEGINNING OF ITERATION LOOP.
+C
+ DO 140 NUMORD = 1, N
+C
+C CHOOSE A COLUMN JCOL OF MAXIMAL DEGREE AMONG THE
+C COLUMNS OF MAXIMAL INCIDENCE.
+C
+ JP = IWA1(MAXINC+1)
+ NUMLST = 1
+ NUMWGT = -1
+ 30 CONTINUE
+ IF (NDEG(JP) .LE. NUMWGT) GO TO 40
+ NUMWGT = NDEG(JP)
+ JCOL = JP
+ 40 CONTINUE
+ JP = IWA3(JP)
+ NUMLST = NUMLST + 1
+ IF (JP .GT. 0 .AND. NUMLST .LE. MAXLST) GO TO 30
+ LIST(JCOL) = NUMORD
+C
+C DELETE COLUMN JCOL FROM THE LIST OF COLUMNS OF
+C MAXIMAL INCIDENCE.
+C
+ L = IWA2(JCOL)
+ IF (L .EQ. 0) IWA1(MAXINC+1) = IWA3(JCOL)
+ IF (L .GT. 0) IWA3(L) = IWA3(JCOL)
+ L = IWA3(JCOL)
+ IF (L .GT. 0) IWA2(L) = IWA2(JCOL)
+C
+C UPDATE THE SIZE OF THE LARGEST CLIQUE
+C FOUND DURING THE ORDERING.
+C
+ IF (MAXINC .EQ. 0) NCOMP = 0
+ NCOMP = NCOMP + 1
+ IF (MAXINC + 1 .EQ. NCOMP) MAXCLQ = MAX0(MAXCLQ,NCOMP)
+C
+C UPDATE THE MAXIMAL INCIDENCE COUNT.
+C
+ 50 CONTINUE
+ IF (IWA1(MAXINC+1) .GT. 0) GO TO 60
+ MAXINC = MAXINC - 1
+ IF (MAXINC .GE. 0) GO TO 50
+ 60 CONTINUE
+C
+C FIND ALL COLUMNS ADJACENT TO COLUMN JCOL.
+C
+ BWA(JCOL) = .TRUE.
+ DEG = 0
+C
+C DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND
+C TO NON-ZEROES IN THE MATRIX.
+C
+ JPL = JPNTR(JCOL)
+ JPU = JPNTR(JCOL+1) - 1
+ IF (JPU .LT. JPL) GO TO 100
+ DO 90 JP = JPL, JPU
+ IR = INDROW(JP)
+C
+C FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC)
+C WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX.
+C
+ IPL = IPNTR(IR)
+ IPU = IPNTR(IR+1) - 1
+ DO 80 IP = IPL, IPU
+ IC = INDCOL(IP)
+C
+C ARRAY BWA MARKS COLUMNS WHICH ARE ADJACENT TO
+C COLUMN JCOL. ARRAY IWA4 RECORDS THE MARKED COLUMNS.
+C
+ IF (BWA(IC)) GO TO 70
+ BWA(IC) = .TRUE.
+ DEG = DEG + 1
+ IWA4(DEG) = IC
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+ 100 CONTINUE
+C
+C UPDATE THE POINTERS TO THE INCIDENCE LISTS.
+C
+ IF (DEG .LT. 1) GO TO 130
+ DO 120 JP = 1, DEG
+ IC = IWA4(JP)
+ IF (LIST(IC) .GT. 0) GO TO 110
+ NUMINC = -LIST(IC) + 1
+ LIST(IC) = -NUMINC
+ MAXINC = MAX0(MAXINC,NUMINC)
+C
+C DELETE COLUMN IC FROM THE NUMINC-1 LIST.
+C
+ L = IWA2(IC)
+ IF (L .EQ. 0) IWA1(NUMINC) = IWA3(IC)
+ IF (L .GT. 0) IWA3(L) = IWA3(IC)
+ L = IWA3(IC)
+ IF (L .GT. 0) IWA2(L) = IWA2(IC)
+C
+C ADD COLUMN IC TO THE NUMINC LIST.
+C
+ HEAD = IWA1(NUMINC+1)
+ IWA1(NUMINC+1) = IC
+ IWA2(IC) = 0
+ IWA3(IC) = HEAD
+ IF (HEAD .GT. 0) IWA2(HEAD) = IC
+ 110 CONTINUE
+C
+C UN-MARK COLUMN IC IN THE ARRAY BWA.
+C
+ BWA(IC) = .FALSE.
+ 120 CONTINUE
+ 130 CONTINUE
+ BWA(JCOL) = .FALSE.
+C
+C END OF ITERATION LOOP.
+C
+ 140 CONTINUE
+C
+C INVERT THE ARRAY LIST.
+C
+ DO 150 JCOL = 1, N
+ NUMORD = LIST(JCOL)
+ IWA1(NUMORD) = JCOL
+ 150 CONTINUE
+ DO 160 JP = 1, N
+ LIST(JP) = IWA1(JP)
+ 160 CONTINUE
+ RETURN
+C
+C LAST CARD OF SUBROUTINE I7DO.
+C
+ END
+ SUBROUTINE M7SLO(N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST,
+ * MAXCLQ,IWA1,IWA2,IWA3,IWA4,BWA)
+ INTEGER N,MAXCLQ
+ INTEGER INDROW(1),JPNTR(1),INDCOL(1),IPNTR(1),NDEG(N),
+ * LIST(N),IWA1(N),IWA2(N),IWA3(N),IWA4(N)
+ LOGICAL BWA(N)
+C **********
+C
+C SUBROUTINE M7SLO
+C
+C GIVEN THE SPARSITY PATTERN OF AN M BY N MATRIX A, THIS
+C SUBROUTINE DETERMINES THE SMALLEST-LAST ORDERING OF THE
+C COLUMNS OF A.
+C
+C THE SMALLEST-LAST ORDERING IS DEFINED FOR THE LOOPLESS
+C GRAPH G WITH VERTICES A(J), J = 1,2,...,N WHERE A(J) IS THE
+C J-TH COLUMN OF A AND WITH EDGE (A(I),A(J)) IF AND ONLY IF
+C COLUMNS I AND J HAVE A NON-ZERO IN THE SAME ROW POSITION.
+C
+C THE SMALLEST-LAST ORDERING IS DETERMINED RECURSIVELY BY
+C LETTING LIST(K), K = N,...,1 BE A COLUMN WITH LEAST DEGREE
+C IN THE SUBGRAPH SPANNED BY THE UN-ORDERED COLUMNS.
+C
+C NOTE THAT THE VALUE OF M IS NOT NEEDED BY M7SLO AND IS
+C THEREFORE NOT PRESENT IN THE SUBROUTINE STATEMENT.
+C
+C THE SUBROUTINE STATEMENT IS
+C
+C SUBROUTINE M7SLO(N,INDROW,JPNTR,INDCOL,IPNTR,NDEG,LIST,
+C MAXCLQ,IWA1,IWA2,IWA3,IWA4,BWA)
+C
+C WHERE
+C
+C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C OF COLUMNS OF A.
+C
+C INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW
+C INDICES FOR THE NON-ZEROES IN THE MATRIX A.
+C
+C JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH
+C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW.
+C THE ROW INDICES FOR COLUMN J ARE
+C
+C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1.
+C
+C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO
+C ELEMENTS OF THE MATRIX A.
+C
+C INDCOL IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE
+C COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A.
+C
+C IPNTR IS AN INTEGER INPUT ARRAY OF LENGTH M + 1 WHICH
+C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL.
+C THE COLUMN INDICES FOR ROW I ARE
+C
+C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1.
+C
+C NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO
+C ELEMENTS OF THE MATRIX A.
+C
+C NDEG IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH SPECIFIES
+C THE DEGREE SEQUENCE. THE DEGREE OF THE J-TH COLUMN
+C OF A IS NDEG(J).
+C
+C LIST IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH SPECIFIES
+C THE SMALLEST-LAST ORDERING OF THE COLUMNS OF A. THE J-TH
+C COLUMN IN THIS ORDER IS LIST(J).
+C
+C MAXCLQ IS AN INTEGER OUTPUT VARIABLE SET TO THE SIZE
+C OF THE LARGEST CLIQUE FOUND DURING THE ORDERING.
+C
+C IWA1,IWA2,IWA3, AND IWA4 ARE INTEGER WORK ARRAYS OF LENGTH N.
+C
+C BWA IS A LOGICAL WORK ARRAY OF LENGTH N.
+C
+C SUBPROGRAMS CALLED
+C
+C FORTRAN-SUPPLIED ... MIN0
+C
+C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982.
+C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE
+C
+C **********
+ INTEGER DEG,HEAD,IC,IP,IPL,IPU,IR,JCOL,JP,JPL,JPU,
+ * L,MINDEG,NUMDEG,NUMORD
+C
+C INITIALIZATION BLOCK.
+C
+ MINDEG = N
+ DO 10 JP = 1, N
+ IWA1(JP) = 0
+ BWA(JP) = .FALSE.
+ LIST(JP) = NDEG(JP)
+ MINDEG = MIN0(MINDEG,NDEG(JP))
+ 10 CONTINUE
+C
+C CREATE A DOUBLY-LINKED LIST TO ACCESS THE DEGREES OF THE
+C COLUMNS. THE POINTERS FOR THE LINKED LIST ARE AS FOLLOWS.
+C
+C EACH UN-ORDERED COLUMN JCOL IS IN A LIST (THE DEGREE
+C LIST) OF COLUMNS WITH THE SAME DEGREE.
+C
+C IWA1(NUMDEG+1) IS THE FIRST COLUMN IN THE NUMDEG LIST
+C UNLESS IWA1(NUMDEG+1) = 0. IN THIS CASE THERE ARE
+C NO COLUMNS IN THE NUMDEG LIST.
+C
+C IWA2(JCOL) IS THE COLUMN BEFORE JCOL IN THE DEGREE LIST
+C UNLESS IWA2(JCOL) = 0. IN THIS CASE JCOL IS THE FIRST
+C COLUMN IN THIS DEGREE LIST.
+C
+C IWA3(JCOL) IS THE COLUMN AFTER JCOL IN THE DEGREE LIST
+C UNLESS IWA3(JCOL) = 0. IN THIS CASE JCOL IS THE LAST
+C COLUMN IN THIS DEGREE LIST.
+C
+C IF JCOL IS AN UN-ORDERED COLUMN, THEN LIST(JCOL) IS THE
+C DEGREE OF JCOL IN THE GRAPH INDUCED BY THE UN-ORDERED
+C COLUMNS. IF JCOL IS AN ORDERED COLUMN, THEN LIST(JCOL)
+C IS THE SMALLEST-LAST ORDER OF COLUMN JCOL.
+C
+ DO 20 JP = 1, N
+ NUMDEG = NDEG(JP)
+ HEAD = IWA1(NUMDEG+1)
+ IWA1(NUMDEG+1) = JP
+ IWA2(JP) = 0
+ IWA3(JP) = HEAD
+ IF (HEAD .GT. 0) IWA2(HEAD) = JP
+ 20 CONTINUE
+ MAXCLQ = 0
+ NUMORD = N
+C
+C BEGINNING OF ITERATION LOOP.
+C
+ 30 CONTINUE
+C
+C MARK THE SIZE OF THE LARGEST CLIQUE
+C FOUND DURING THE ORDERING.
+C
+ IF (MINDEG + 1 .EQ. NUMORD .AND. MAXCLQ .EQ. 0)
+ * MAXCLQ = NUMORD
+C
+C CHOOSE A COLUMN JCOL OF MINIMAL DEGREE MINDEG.
+C
+ 40 CONTINUE
+ JCOL = IWA1(MINDEG+1)
+ IF (JCOL .GT. 0) GO TO 50
+ MINDEG = MINDEG + 1
+ GO TO 40
+ 50 CONTINUE
+ LIST(JCOL) = NUMORD
+ NUMORD = NUMORD - 1
+C
+C TERMINATION TEST.
+C
+ IF (NUMORD .EQ. 0) GO TO 120
+C
+C DELETE COLUMN JCOL FROM THE MINDEG LIST.
+C
+ L = IWA3(JCOL)
+ IWA1(MINDEG+1) = L
+ IF (L .GT. 0) IWA2(L) = 0
+C
+C FIND ALL COLUMNS ADJACENT TO COLUMN JCOL.
+C
+ BWA(JCOL) = .TRUE.
+ DEG = 0
+C
+C DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND
+C TO NON-ZEROES IN THE MATRIX.
+C
+ JPL = JPNTR(JCOL)
+ JPU = JPNTR(JCOL+1) - 1
+ IF (JPU .LT. JPL) GO TO 90
+ DO 80 JP = JPL, JPU
+ IR = INDROW(JP)
+C
+C FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC)
+C WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX.
+C
+ IPL = IPNTR(IR)
+ IPU = IPNTR(IR+1) - 1
+ DO 70 IP = IPL, IPU
+ IC = INDCOL(IP)
+C
+C ARRAY BWA MARKS COLUMNS WHICH ARE ADJACENT TO
+C COLUMN JCOL. ARRAY IWA4 RECORDS THE MARKED COLUMNS.
+C
+ IF (BWA(IC)) GO TO 60
+ BWA(IC) = .TRUE.
+ DEG = DEG + 1
+ IWA4(DEG) = IC
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+C
+C UPDATE THE POINTERS TO THE CURRENT DEGREE LISTS.
+C
+ IF (DEG .LT. 1) GO TO 110
+ DO 100 JP = 1, DEG
+ IC = IWA4(JP)
+ NUMDEG = LIST(IC)
+ LIST(IC) = LIST(IC) - 1
+ MINDEG = MIN0(MINDEG,LIST(IC))
+C
+C DELETE COLUMN IC FROM THE NUMDEG LIST.
+C
+ L = IWA2(IC)
+ IF (L .EQ. 0) IWA1(NUMDEG+1) = IWA3(IC)
+ IF (L .GT. 0) IWA3(L) = IWA3(IC)
+ L = IWA3(IC)
+ IF (L .GT. 0) IWA2(L) = IWA2(IC)
+C
+C ADD COLUMN IC TO THE NUMDEG-1 LIST.
+C
+ HEAD = IWA1(NUMDEG)
+ IWA1(NUMDEG) = IC
+ IWA2(IC) = 0
+ IWA3(IC) = HEAD
+ IF (HEAD .GT. 0) IWA2(HEAD) = IC
+C
+C UN-MARK COLUMN IC IN THE ARRAY BWA.
+C
+ BWA(IC) = .FALSE.
+ 100 CONTINUE
+ 110 CONTINUE
+C
+C END OF ITERATION LOOP.
+C
+ GO TO 30
+ 120 CONTINUE
+C
+C INVERT THE ARRAY LIST.
+C
+ DO 130 JCOL = 1, N
+ NUMORD = LIST(JCOL)
+ IWA1(NUMORD) = JCOL
+ 130 CONTINUE
+ DO 140 JP = 1, N
+ LIST(JP) = IWA1(JP)
+ 140 CONTINUE
+ RETURN
+C
+C LAST CARD OF SUBROUTINE M7SLO.
+C
+ END
+ SUBROUTINE DS7DMP(N, X, Y, Z, K)
+C
+C *** SET X = DIAG(Z)**K * Y * DIAG(Z)**K
+C *** FOR X, Y = COMPACTLY STORED LOWER TRIANG. MATRICES
+C *** K = 1 OR -1.
+C
+ INTEGER N, K
+ DOUBLE PRECISION X(*), Y(*), Z(N)
+ INTEGER I, J, L
+ DOUBLE PRECISION ONE, T
+ DATA ONE/1.D+0/
+C
+ L = 1
+ IF (K .GE. 0) GO TO 30
+ DO 20 I = 1, N
+ T = ONE / Z(I)
+ DO 10 J = 1, I
+ X(L) = T * Y(L) / Z(J)
+ L = L + 1
+ 10 CONTINUE
+ 20 CONTINUE
+ GO TO 999
+C
+ 30 DO 50 I = 1, N
+ T = Z(I)
+ DO 40 J = 1, I
+ X(L) = T * Y(L) * Z(J)
+ L = L + 1
+ 40 CONTINUE
+ 50 CONTINUE
+ 999 RETURN
+C *** LAST CARD OF DS7DMP FOLLOWS ***
+ END
+ SUBROUTINE DS7BQN(B, D, DST, IPIV, IPIV1, IPIV2, KB, L, LV, NS,
+ 1 P, P1, STEP, TD, TG, V, W, X, X0)
+C
+C *** COMPUTE BOUNDED MODIFIED NEWTON STEP ***
+C
+ INTEGER KB, LV, NS, P, P1
+ INTEGER IPIV(P), IPIV1(P), IPIV2(P)
+ DOUBLE PRECISION B(2,P), D(P), DST(P), L(*),
+ 1 STEP(P), TD(P), TG(P), V(LV), W(P), X(P),
+ 2 X0(P)
+C DIMENSION L(P*(P+1)/2)
+C
+ DOUBLE PRECISION DD7TPR, DR7MDC, DV2NRM
+ EXTERNAL DD7TPR, I7SHFT, DL7ITV, DL7IVM, DQ7RSH, DR7MDC, DV2NRM,
+ 1 DV2AXY,DV7CPY, DV7IPR, DV7SCP, DV7SHF
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER I, J, K, P0, P1M1
+ DOUBLE PRECISION ALPHA, DST0, DST1, DSTMAX, DSTMIN, DX, GTS, T,
+ 1 TI, T1, XI
+ DOUBLE PRECISION FUDGE, HALF, MEPS2, ONE, TWO, ZERO
+C
+C *** V SUBSCRIPTS ***
+C
+ INTEGER DSTNRM, GTSTEP, PHMNFC, PHMXFC, PREDUC, RADIUS, STPPAR
+C
+ PARAMETER (DSTNRM=2, GTSTEP=4, PHMNFC=20, PHMXFC=21, PREDUC=7,
+ 1 RADIUS=8, STPPAR=5)
+ SAVE MEPS2
+C
+ DATA FUDGE/1.0001D+0/, HALF/0.5D+0/, MEPS2/0.D+0/,
+ 1 ONE/1.0D+0/, TWO/2.D+0/, ZERO/0.D+0/
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ DSTMAX = FUDGE * (ONE + V(PHMXFC)) * V(RADIUS)
+ DSTMIN = (ONE + V(PHMNFC)) * V(RADIUS)
+ DST1 = ZERO
+ IF (MEPS2 .LE. ZERO) MEPS2 = TWO * DR7MDC(3)
+ P0 = P1
+ NS = 0
+ DO 10 I = 1, P
+ IPIV1(I) = I
+ IPIV2(I) = I
+ 10 CONTINUE
+ DO 20 I = 1, P1
+ 20 W(I) = -STEP(I) * TD(I)
+ ALPHA = DABS(V(STPPAR))
+ V(PREDUC) = ZERO
+ GTS = -V(GTSTEP)
+ IF (KB .LT. 0) CALL DV7SCP(P, DST, ZERO)
+ KB = 1
+C
+C *** -W = D TIMES RESTRICTED NEWTON STEP FROM X + DST/D.
+C
+C *** FIND T SUCH THAT X - T*W IS STILL FEASIBLE.
+C
+ 30 T = ONE
+ K = 0
+ DO 60 I = 1, P1
+ J = IPIV(I)
+ DX = W(I) / D(J)
+ XI = X(J) - DX
+ IF (XI .LT. B(1,J)) GO TO 40
+ IF (XI .LE. B(2,J)) GO TO 60
+ TI = ( X(J) - B(2,J) ) / DX
+ K = I
+ GO TO 50
+ 40 TI = ( X(J) - B(1,J) ) / DX
+ K = -I
+ 50 IF (T .LE. TI) GO TO 60
+ T = TI
+ 60 CONTINUE
+C
+ IF (P .GT. P1) CALL DV7CPY(P-P1, STEP(P1+1), DST(P1+1))
+ CALL DV2AXY(P1, STEP, -T, W, DST)
+ DST0 = DST1
+ DST1 = DV2NRM(P, STEP)
+C
+C *** CHECK FOR OVERSIZE STEP ***
+C
+ IF (DST1 .LE. DSTMAX) GO TO 80
+ IF (P1 .GE. P0) GO TO 70
+ IF (DST0 .LT. DSTMIN) KB = 0
+ GO TO 110
+C
+ 70 K = 0
+C
+C *** UPDATE DST, TG, AND V(PREDUC) ***
+C
+ 80 V(DSTNRM) = DST1
+ CALL DV7CPY(P1, DST, STEP)
+ T1 = ONE - T
+ DO 90 I = 1, P1
+ 90 TG(I) = T1 * TG(I)
+ IF (ALPHA .GT. ZERO) CALL DV2AXY(P1, TG, T*ALPHA, W, TG)
+ V(PREDUC) = V(PREDUC) + T*((ONE - HALF*T)*GTS +
+ 1 HALF*ALPHA*T*DD7TPR(P1,W,W))
+ IF (K .EQ. 0) GO TO 110
+C
+C *** PERMUTE L, ETC. IF NECESSARY ***
+C
+ P1M1 = P1 - 1
+ J = IABS(K)
+ IF (J .EQ. P1) GO TO 100
+ NS = NS + 1
+ IPIV2(P1) = J
+ CALL DQ7RSH(J, P1, .FALSE., TG, L, W)
+ CALL I7SHFT(P1, J, IPIV)
+ CALL I7SHFT(P1, J, IPIV1)
+ CALL DV7SHF(P1, J, TG)
+ CALL DV7SHF(P1, J, DST)
+ 100 IF (K .LT. 0) IPIV(P1) = -IPIV(P1)
+ P1 = P1M1
+ IF (P1 .LE. 0) GO TO 110
+ CALL DL7IVM(P1, W, L, TG)
+ GTS = DD7TPR(P1, W, W)
+ CALL DL7ITV(P1, W, L, W)
+ GO TO 30
+C
+C *** UNSCALE STEP ***
+C
+ 110 DO 120 I = 1, P
+ J = IABS(IPIV(I))
+ STEP(J) = DST(I) / D(J)
+ 120 CONTINUE
+C
+C *** FUDGE STEP TO ENSURE THAT IT FORCES APPROPRIATE COMPONENTS
+C *** TO THEIR BOUNDS ***
+C
+ IF (P1 .GE. P0) GO TO 150
+ K = P1 + 1
+ DO 140 I = K, P0
+ J = IPIV(I)
+ T = MEPS2
+ IF (J .GT. 0) GO TO 130
+ T = -T
+ J = -J
+ IPIV(I) = J
+ 130 T = T * DMAX1(DABS(X(J)), DABS(X0(J)))
+ STEP(J) = STEP(J) + T
+ 140 CONTINUE
+C
+ 150 CALL DV2AXY(P, X, ONE, STEP, X0)
+ IF (NS .GT. 0) CALL DV7IPR(P0, IPIV1, TD)
+ RETURN
+C *** LAST LINE OF DS7BQN FOLLOWS ***
+ END
+ SUBROUTINE N7MSRT(N,NMAX,NUM,MODE,INDEX,LAST,NEXT)
+ INTEGER N,NMAX,MODE
+ INTEGER NUM(N),INDEX(N),LAST(1),NEXT(N)
+C **********.
+C
+C SUBROUTINE N7MSRT
+C
+C GIVEN A SEQUENCE OF INTEGERS, THIS SUBROUTINE GROUPS
+C TOGETHER THOSE INDICES WITH THE SAME SEQUENCE VALUE
+C AND, OPTIONALLY, SORTS THE SEQUENCE INTO EITHER
+C ASCENDING OR DESCENDING ORDER.
+C
+C THE SEQUENCE OF INTEGERS IS DEFINED BY THE ARRAY NUM,
+C AND IT IS ASSUMED THAT THE INTEGERS ARE EACH FROM THE SET
+C 0,1,...,NMAX. ON OUTPUT THE INDICES K SUCH THAT NUM(K) = L
+C FOR ANY L = 0,1,...,NMAX CAN BE OBTAINED FROM THE ARRAYS
+C LAST AND NEXT AS FOLLOWS.
+C
+C K = LAST(L+1)
+C WHILE (K .NE. 0) K = NEXT(K)
+C
+C OPTIONALLY, THE SUBROUTINE PRODUCES AN ARRAY INDEX SO THAT
+C THE SEQUENCE NUM(INDEX(I)), I = 1,2,...,N IS SORTED.
+C
+C THE SUBROUTINE STATEMENT IS
+C
+C SUBROUTINE N7MSRT(N,NMAX,NUM,MODE,INDEX,LAST,NEXT)
+C
+C WHERE
+C
+C N IS A POSITIVE INTEGER INPUT VARIABLE.
+C
+C NMAX IS A POSITIVE INTEGER INPUT VARIABLE.
+C
+C NUM IS AN INPUT ARRAY OF LENGTH N WHICH CONTAINS THE
+C SEQUENCE OF INTEGERS TO BE GROUPED AND SORTED. IT
+C IS ASSUMED THAT THE INTEGERS ARE EACH FROM THE SET
+C 0,1,...,NMAX.
+C
+C MODE IS AN INTEGER INPUT VARIABLE. THE SEQUENCE NUM IS
+C SORTED IN ASCENDING ORDER IF MODE IS POSITIVE AND IN
+C DESCENDING ORDER IF MODE IS NEGATIVE. IF MODE IS 0,
+C NO SORTING IS DONE.
+C
+C INDEX IS AN INTEGER OUTPUT ARRAY OF LENGTH N SET SO
+C THAT THE SEQUENCE
+C
+C NUM(INDEX(I)), I = 1,2,...,N
+C
+C IS SORTED ACCORDING TO THE SETTING OF MODE. IF MODE
+C IS 0, INDEX IS NOT REFERENCED.
+C
+C LAST IS AN INTEGER OUTPUT ARRAY OF LENGTH NMAX + 1. THE
+C INDEX OF NUM FOR THE LAST OCCURRENCE OF L IS LAST(L+1)
+C FOR ANY L = 0,1,...,NMAX UNLESS LAST(L+1) = 0. IN
+C THIS CASE L DOES NOT APPEAR IN NUM.
+C
+C NEXT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IF
+C NUM(K) = L, THEN THE INDEX OF NUM FOR THE PREVIOUS
+C OCCURRENCE OF L IS NEXT(K) FOR ANY L = 0,1,...,NMAX
+C UNLESS NEXT(K) = 0. IN THIS CASE THERE IS NO PREVIOUS
+C OCCURRENCE OF L IN NUM.
+C
+C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982.
+C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE
+C
+C **********
+ INTEGER I,J,JP,K,L,NMAXP1,NMAXP2
+C
+C DETERMINE THE ARRAYS NEXT AND LAST.
+C
+ NMAXP1 = NMAX + 1
+ DO 10 I = 1, NMAXP1
+ LAST(I) = 0
+ 10 CONTINUE
+ DO 20 K = 1, N
+ L = NUM(K)
+ NEXT(K) = LAST(L+1)
+ LAST(L+1) = K
+ 20 CONTINUE
+ IF (MODE .EQ. 0) GO TO 60
+C
+C STORE THE POINTERS TO THE SORTED ARRAY IN INDEX.
+C
+ I = 1
+ NMAXP2 = NMAXP1 + 1
+ DO 50 J = 1, NMAXP1
+ JP = J
+ IF (MODE .LT. 0) JP = NMAXP2 - J
+ K = LAST(JP)
+ 30 CONTINUE
+ IF (K .EQ. 0) GO TO 40
+ INDEX(I) = K
+ I = I + 1
+ K = NEXT(K)
+ GO TO 30
+ 40 CONTINUE
+ 50 CONTINUE
+ 60 CONTINUE
+ RETURN
+C
+C LAST CARD OF SUBROUTINE N7MSRT.
+C
+ END
+ SUBROUTINE DG7LIT(D, G, IV, LIV, LV, P, PS, V, X, Y)
+C
+C *** CARRY OUT NL2SOL-LIKE ITERATIONS FOR GENERALIZED LINEAR ***
+C *** REGRESSION PROBLEMS (AND OTHERS OF SIMILAR STRUCTURE) ***
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER LIV, LV, P, PS
+ INTEGER IV(LIV)
+ DOUBLE PRECISION D(P), G(P), V(LV), X(P), Y(P)
+C
+C-------------------------- PARAMETER USAGE --------------------------
+C
+C D.... SCALE VECTOR.
+C IV... INTEGER VALUE ARRAY.
+C LIV.. LENGTH OF IV. MUST BE AT LEAST 82.
+C LH... LENGTH OF H = P*(P+1)/2.
+C LV... LENGTH OF V. MUST BE AT LEAST P*(3*P + 19)/2 + 7.
+C G.... GRADIENT AT X (WHEN IV(1) = 2).
+C P.... NUMBER OF PARAMETERS (COMPONENTS IN X).
+C PS... NUMBER OF NONZERO ROWS AND COLUMNS IN S.
+C V.... FLOATING-POINT VALUE ARRAY.
+C X.... PARAMETER VECTOR.
+C Y.... PART OF YIELD VECTOR (WHEN IV(1)= 2, SCRATCH OTHERWISE).
+C
+C *** DISCUSSION ***
+C
+C DG7LIT PERFORMS NL2SOL-LIKE ITERATIONS FOR A VARIETY OF
+C REGRESSION PROBLEMS THAT ARE SIMILAR TO NONLINEAR LEAST-SQUARES
+C IN THAT THE HESSIAN IS THE SUM OF TWO TERMS, A READILY-COMPUTED
+C FIRST-ORDER TERM AND A SECOND-ORDER TERM. THE CALLER SUPPLIES
+C THE FIRST-ORDER TERM OF THE HESSIAN IN HC (LOWER TRIANGLE, STORED
+C COMPACTLY BY ROWS IN V, STARTING AT IV(HC)), AND DG7LIT BUILDS AN
+C APPROXIMATION, S, TO THE SECOND-ORDER TERM. THE CALLER ALSO
+C PROVIDES THE FUNCTION VALUE, GRADIENT, AND PART OF THE YIELD
+C VECTOR USED IN UPDATING S. DG7LIT DECIDES DYNAMICALLY WHETHER OR
+C NOT TO USE S WHEN CHOOSING THE NEXT STEP TO TRY... THE HESSIAN
+C APPROXIMATION USED IS EITHER HC ALONE (GAUSS-NEWTON MODEL) OR
+C HC + S (AUGMENTED MODEL).
+C
+C IF PS .LT. P, THEN ROWS AND COLUMNS PS+1...P OF S ARE KEPT
+C CONSTANT. THEY WILL BE ZERO UNLESS THE CALLER SETS IV(INITS) TO
+C 1 OR 2 AND SUPPLIES NONZERO VALUES FOR THEM, OR THE CALLER SETS
+C IV(INITS) TO 3 OR 4 AND THE FINITE-DIFFERENCE INITIAL S THEN
+C COMPUTED HAS NONZERO VALUES IN THESE ROWS.
+C
+C IF IV(INITS) IS 3 OR 4, THEN THE INITIAL S IS COMPUTED BY
+C FINITE DIFFERENCES. 3 MEANS USE FUNCTION DIFFERENCES, 4 MEANS
+C USE GRADIENT DIFFERENCES. FINITE DIFFERENCING IS DONE THE SAME
+C WAY AS IN COMPUTING A COVARIANCE MATRIX (WITH IV(COVREQ) = -1, -2,
+C 1, OR 2).
+C
+C FOR UPDATING S,DG7LIT ASSUMES THAT THE GRADIENT HAS THE FORM
+C OF A SUM OVER I OF RHO(I,X)*GRAD(R(I,X)), WHERE GRAD DENOTES THE
+C GRADIENT WITH RESPECT TO X. THE TRUE SECOND-ORDER TERM THEN IS
+C THE SUM OVER I OF RHO(I,X)*HESSIAN(R(I,X)). IF X = X0 + STEP,
+C THEN WE WISH TO UPDATE S SO THAT S*STEP IS THE SUM OVER I OF
+C RHO(I,X)*(GRAD(R(I,X)) - GRAD(R(I,X0))). THE CALLER MUST SUPPLY
+C PART OF THIS IN Y, NAMELY THE SUM OVER I OF
+C RHO(I,X)*GRAD(R(I,X0)), WHEN CALLING DG7LIT WITH IV(1) = 2 AND
+C IV(MODE) = 0 (WHERE MODE = 38). G THEN CONTANS THE OTHER PART,
+C SO THAT THE DESIRED YIELD VECTOR IS G - Y. IF PS .LT. P, THEN
+C THE ABOVE DISCUSSION APPLIES ONLY TO THE FIRST PS COMPONENTS OF
+C GRAD(R(I,X)), STEP, AND Y.
+C
+C PARAMETERS IV, P, V, AND X ARE THE SAME AS THE CORRESPONDING
+C ONES TO NL2SOL (WHICH SEE), EXCEPT THAT V CAN BE SHORTER
+C (SINCE THE PART OF V THAT NL2SOL USES FOR STORING D, J, AND R IS
+C NOT NEEDED). MOREOVER, COMPARED WITH NL2SOL, IV(1) MAY HAVE THE
+C TWO ADDITIONAL OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW,
+C AS IS THE USE OF IV(TOOBIG) AND IV(NFGCAL). THE VALUES IV(D),
+C IV(J), AND IV(R), WHICH ARE OUTPUT VALUES FROM NL2SOL (AND
+C NL2SNO), ARE NOT REFERENCED BY DG7LIT OR THE SUBROUTINES IT CALLS.
+C
+C WHEN DG7LIT IS FIRST CALLED, I.E., WHEN DG7LIT IS CALLED WITH
+C IV(1) = 0 OR 12, V(F), G, AND HC NEED NOT BE INITIALIZED. TO
+C OBTAIN THESE STARTING VALUES,DG7LIT RETURNS FIRST WITH IV(1) = 1,
+C THEN WITH IV(1) = 2, WITH IV(MODE) = -1 IN BOTH CASES. ON
+C SUBSEQUENT RETURNS WITH IV(1) = 2, IV(MODE) = 0 IMPLIES THAT
+C Y MUST ALSO BE SUPPLIED. (NOTE THAT Y IS USED FOR SCRATCH -- ITS
+C INPUT CONTENTS ARE LOST. BY CONTRAST, HC IS NEVER CHANGED.)
+C ONCE CONVERGENCE HAS BEEN OBTAINED, IV(RDREQ) AND IV(COVREQ) MAY
+C IMPLY THAT A FINITE-DIFFERENCE HESSIAN SHOULD BE COMPUTED FOR USE
+C IN COMPUTING A COVARIANCE MATRIX. IN THIS CASE DG7LIT WILL MAKE A
+C NUMBER OF RETURNS WITH IV(1) = 1 OR 2 AND IV(MODE) POSITIVE.
+C WHEN IV(MODE) IS POSITIVE, Y SHOULD NOT BE CHANGED.
+C
+C IV(1) = 1 MEANS THE CALLER SHOULD SET V(F) (I.E., V(10)) TO F(X), THE
+C FUNCTION VALUE AT X, AND CALL DG7LIT AGAIN, HAVING CHANGED
+C NONE OF THE OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X)
+C CANNOT BE EVALUATED (E.G. IF OVERFLOW WOULD OCCUR), WHICH
+C MAY HAPPEN BECAUSE OF AN OVERSIZED STEP. IN THIS CASE
+C THE CALLER SHOULD SET IV(TOOBIG) = IV(2) TO 1, WHICH WILL
+C CAUSE DG7LIT TO IGNORE V(F) AND TRY A SMALLER STEP. NOTE
+C THAT THE CURRENT FUNCTION EVALUATION COUNT IS AVAILABLE
+C IN IV(NFCALL) = IV(6). THIS MAY BE USED TO IDENTIFY
+C WHICH COPY OF SAVED INFORMATION SHOULD BE USED IN COM-
+C PUTING G, HC, AND Y THE NEXT TIME DG7LIT RETURNS WITH
+C IV(1) = 2. SEE MLPIT FOR AN EXAMPLE OF THIS.
+C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT OF F AT
+C X. THE CALLER SHOULD ALSO SET HC TO THE GAUSS-NEWTON
+C HESSIAN AT X. IF IV(MODE) = 0, THEN THE CALLER SHOULD
+C ALSO COMPUTE THE PART OF THE YIELD VECTOR DESCRIBED ABOVE.
+C THE CALLER SHOULD THEN CALL DG7LIT AGAIN (WITH IV(1) = 2).
+C THE CALLER MAY ALSO CHANGE D AT THIS TIME, BUT SHOULD NOT
+C CHANGE X. NOTE THAT IV(NFGCAL) = IV(7) CONTAINS THE
+C VALUE THAT IV(NFCALL) HAD DURING THE RETURN WITH
+C IV(1) = 1 IN WHICH X HAD THE SAME VALUE AS IT NOW HAS.
+C IV(NFGCAL) IS EITHER IV(NFCALL) OR IV(NFCALL) - 1. MLPIT
+C IS AN EXAMPLE WHERE THIS INFORMATION IS USED. IF G OR HC
+C CANNOT BE EVALUATED AT X, THEN THE CALLER MAY SET
+C IV(TOOBIG) TO 1, IN WHICH CASE DG7LIT WILL RETURN WITH
+C IV(1) = 15.
+C
+C *** GENERAL ***
+C
+C CODED BY DAVID M. GAY.
+C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
+C SUPPORTED IN PART BY D.O.E. GRANT EX-76-A-01-2295 TO MIT/CCREMS.
+C
+C (SEE NL2SOL FOR REFERENCES.)
+C
+C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER DUMMY, DIG1, G01, H1, HC1, I, IPIV1, J, K, L, LMAT1,
+ 1 LSTGST, PP1O2, QTR1, RMAT1, RSTRST, STEP1, STPMOD, S1,
+ 2 TEMP1, TEMP2, W1, X01
+ DOUBLE PRECISION E, STTSST, T, T1
+C
+C *** CONSTANTS ***
+C
+ DOUBLE PRECISION HALF, NEGONE, ONE, ONEP2, ZERO
+C
+C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
+C
+ LOGICAL STOPX
+ DOUBLE PRECISION DD7TPR, DL7SVX, DL7SVN, DRLDST, DR7MDC, DV2NRM
+ EXTERNAL DA7SST, DD7TPR,DF7HES,DG7QTS,DITSUM, DL7MST,DL7SRT,
+ 1 DL7SQR, DL7SVX, DL7SVN, DL7TVM,DL7VML,DPARCK, DRLDST,
+ 2 DR7MDC, DS7LUP, DS7LVM, STOPX,DV2AXY,DV7CPY, DV7SCP,
+ 3 DV2NRM
+C
+C DA7SST.... ASSESSES CANDIDATE STEP.
+C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
+C DF7HES.... COMPUTE FINITE-DIFFERENCE HESSIAN (FOR COVARIANCE).
+C DG7QTS.... COMPUTES GOLDFELD-QUANDT-TROTTER STEP (AUGMENTED MODEL).
+C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
+C DL7MST... COMPUTES LEVENBERG-MARQUARDT STEP (GAUSS-NEWTON MODEL).
+C DL7SRT.... COMPUTES CHOLESKY FACTOR OF (LOWER TRIANG. OF) SYM. MATRIX.
+C DL7SQR... COMPUTES L * L**T FROM LOWER TRIANGULAR MATRIX L.
+C DL7TVM... COMPUTES L**T * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
+C DL7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX.
+C DL7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX.
+C DL7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
+C DPARCK.... CHECK VALIDITY OF IV AND V INPUT COMPONENTS.
+C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
+C DR7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS.
+C DS7LUP... PERFORMS QUASI-NEWTON UPDATE ON COMPACTLY STORED LOWER TRI-
+C ANGLE OF A SYMMETRIC MATRIX.
+C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
+C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
+C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
+C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
+C DV2NRM... RETURNS THE 2-NORM OF A VECTOR.
+C
+C *** SUBSCRIPTS FOR IV AND V ***
+C
+ INTEGER CNVCOD, COSMIN, COVMAT, COVREQ, DGNORM, DIG, DSTNRM, F,
+ 1 FDH, FDIF, FUZZ, F0, GTSTEP, H, HC, IERR, INCFAC, INITS,
+ 2 IPIVOT, IRC, KAGQT, KALM, LMAT, LMAX0, LMAXS, MODE, MODEL,
+ 3 MXFCAL, MXITER, NEXTV, NFCALL, NFGCAL, NFCOV, NGCOV,
+ 4 NGCALL, NITER, NVSAVE, PHMXFC, PREDUC, QTR, RADFAC,
+ 5 RADINC, RADIUS, RAD0, RCOND, RDREQ, REGD, RELDX, RESTOR,
+ 6 RMAT, S, SIZE, STEP, STGLIM, STLSTG, STPPAR, SUSED,
+ 7 SWITCH, TOOBIG, TUNER4, TUNER5, VNEED, VSAVE, W, WSCALE,
+ 8 XIRC, X0
+C
+C *** IV SUBSCRIPT VALUES ***
+C
+ PARAMETER (CNVCOD=55, COVMAT=26, COVREQ=15, DIG=37, FDH=74, H=56,
+ 1 HC=71, IERR=75, INITS=25, IPIVOT=76, IRC=29, KAGQT=33,
+ 2 KALM=34, LMAT=42, MODE=35, MODEL=5, MXFCAL=17,
+ 3 MXITER=18, NEXTV=47, NFCALL=6, NFGCAL=7, NFCOV=52,
+ 4 NGCOV=53, NGCALL=30, NITER=31, QTR=77, RADINC=8,
+ 5 RDREQ=57, REGD=67, RESTOR=9, RMAT=78, S=62, STEP=40,
+ 6 STGLIM=11, STLSTG=41, SUSED=64, SWITCH=12, TOOBIG=2,
+ 7 VNEED=4, VSAVE=60, W=65, XIRC=13, X0=43)
+C
+C *** V SUBSCRIPT VALUES ***
+C
+ PARAMETER (COSMIN=47, DGNORM=1, DSTNRM=2, F=10, FDIF=11, FUZZ=45,
+ 1 F0=13, GTSTEP=4, INCFAC=23, LMAX0=35, LMAXS=36,
+ 2 NVSAVE=9, PHMXFC=21, PREDUC=7, RADFAC=16, RADIUS=8,
+ 3 RAD0=9, RCOND=53, RELDX=17, SIZE=55, STPPAR=5,
+ 4 TUNER4=29, TUNER5=30, WSCALE=56)
+C
+C
+ PARAMETER (HALF=0.5D+0, NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0,
+ 1 ZERO=0.D+0)
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ I = IV(1)
+ IF (I .EQ. 1) GO TO 40
+ IF (I .EQ. 2) GO TO 50
+C
+ IF (I .EQ. 12 .OR. I .EQ. 13)
+ 1 IV(VNEED) = IV(VNEED) + P*(3*P + 19)/2 + 7
+ CALL DPARCK(1, D, IV, LIV, LV, P, V)
+ I = IV(1) - 2
+ IF (I .GT. 12) GO TO 999
+ GO TO (290, 290, 290, 290, 290, 290, 170, 120, 170, 10, 10, 20), I
+C
+C *** STORAGE ALLOCATION ***
+C
+ 10 PP1O2 = P * (P + 1) / 2
+ IV(S) = IV(LMAT) + PP1O2
+ IV(X0) = IV(S) + PP1O2
+ IV(STEP) = IV(X0) + P
+ IV(STLSTG) = IV(STEP) + P
+ IV(DIG) = IV(STLSTG) + P
+ IV(W) = IV(DIG) + P
+ IV(H) = IV(W) + 4*P + 7
+ IV(NEXTV) = IV(H) + PP1O2
+ IF (IV(1) .NE. 13) GO TO 20
+ IV(1) = 14
+ GO TO 999
+C
+C *** INITIALIZATION ***
+C
+ 20 IV(NITER) = 0
+ IV(NFCALL) = 1
+ IV(NGCALL) = 1
+ IV(NFGCAL) = 1
+ IV(MODE) = -1
+ IV(STGLIM) = 2
+ IV(TOOBIG) = 0
+ IV(CNVCOD) = 0
+ IV(COVMAT) = 0
+ IV(NFCOV) = 0
+ IV(NGCOV) = 0
+ IV(RADINC) = 0
+ IV(RESTOR) = 0
+ IV(FDH) = 0
+ V(RAD0) = ZERO
+ V(STPPAR) = ZERO
+ V(RADIUS) = V(LMAX0) / (ONE + V(PHMXFC))
+C
+C *** SET INITIAL MODEL AND S MATRIX ***
+C
+ IV(MODEL) = 1
+ IF (IV(S) .LT. 0) GO TO 999
+ IF (IV(INITS) .GT. 1) IV(MODEL) = 2
+ S1 = IV(S)
+ IF (IV(INITS) .EQ. 0 .OR. IV(INITS) .GT. 2)
+ 1 CALL DV7SCP(P*(P+1)/2, V(S1), ZERO)
+ IV(1) = 1
+ J = IV(IPIVOT)
+ IF (J .LE. 0) GO TO 999
+ DO 30 I = 1, P
+ IV(J) = I
+ J = J + 1
+ 30 CONTINUE
+ GO TO 999
+C
+C *** NEW FUNCTION VALUE ***
+C
+ 40 IF (IV(MODE) .EQ. 0) GO TO 290
+ IF (IV(MODE) .GT. 0) GO TO 520
+C
+ IV(1) = 2
+ IF (IV(TOOBIG) .EQ. 0) GO TO 999
+ IV(1) = 63
+ GO TO 999
+C
+C *** NEW GRADIENT ***
+C
+ 50 IV(KALM) = -1
+ IV(KAGQT) = -1
+ IV(FDH) = 0
+ IF (IV(MODE) .GT. 0) GO TO 520
+C
+C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
+C
+ IF (IV(TOOBIG) .EQ. 0) GO TO 60
+ IV(1) = 65
+ GO TO 999
+ 60 IF (IV(HC) .LE. 0 .AND. IV(RMAT) .LE. 0) GO TO 610
+C
+C *** COMPUTE D**-1 * GRADIENT ***
+C
+ DIG1 = IV(DIG)
+ K = DIG1
+ DO 70 I = 1, P
+ V(K) = G(I) / D(I)
+ K = K + 1
+ 70 CONTINUE
+ V(DGNORM) = DV2NRM(P, V(DIG1))
+C
+ IF (IV(CNVCOD) .NE. 0) GO TO 510
+ IF (IV(MODE) .EQ. 0) GO TO 440
+ IV(MODE) = 0
+ V(F0) = V(F)
+ IF (IV(INITS) .LE. 2) GO TO 100
+C
+C *** ARRANGE FOR FINITE-DIFFERENCE INITIAL S ***
+C
+ IV(XIRC) = IV(COVREQ)
+ IV(COVREQ) = -1
+ IF (IV(INITS) .GT. 3) IV(COVREQ) = 1
+ IV(CNVCOD) = 70
+ GO TO 530
+C
+C *** COME TO NEXT STMT AFTER COMPUTING F.D. HESSIAN FOR INIT. S ***
+C
+ 80 IV(CNVCOD) = 0
+ IV(MODE) = 0
+ IV(NFCOV) = 0
+ IV(NGCOV) = 0
+ IV(COVREQ) = IV(XIRC)
+ S1 = IV(S)
+ PP1O2 = PS * (PS + 1) / 2
+ HC1 = IV(HC)
+ IF (HC1 .LE. 0) GO TO 90
+ CALL DV2AXY(PP1O2, V(S1), NEGONE, V(HC1), V(H1))
+ GO TO 100
+ 90 RMAT1 = IV(RMAT)
+ CALL DL7SQR(PS, V(S1), V(RMAT1))
+ CALL DV2AXY(PP1O2, V(S1), NEGONE, V(S1), V(H1))
+ 100 IV(1) = 2
+C
+C
+C----------------------------- MAIN LOOP -----------------------------
+C
+C
+C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
+C
+ 110 CALL DITSUM(D, G, IV, LIV, LV, P, V, X)
+ 120 K = IV(NITER)
+ IF (K .LT. IV(MXITER)) GO TO 130
+ IV(1) = 10
+ GO TO 999
+ 130 IV(NITER) = K + 1
+C
+C *** UPDATE RADIUS ***
+C
+ IF (K .EQ. 0) GO TO 150
+ STEP1 = IV(STEP)
+ DO 140 I = 1, P
+ V(STEP1) = D(I) * V(STEP1)
+ STEP1 = STEP1 + 1
+ 140 CONTINUE
+ STEP1 = IV(STEP)
+ T = V(RADFAC) * DV2NRM(P, V(STEP1))
+ IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T
+C
+C *** INITIALIZE FOR START OF NEXT ITERATION ***
+C
+ 150 X01 = IV(X0)
+ V(F0) = V(F)
+ IV(IRC) = 4
+ IV(H) = -IABS(IV(H))
+ IV(SUSED) = IV(MODEL)
+C
+C *** COPY X TO X0 ***
+C
+ CALL DV7CPY(P, V(X01), X)
+C
+C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
+C
+ 160 IF (.NOT. STOPX(DUMMY)) GO TO 180
+ IV(1) = 11
+ GO TO 190
+C
+C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
+C
+ 170 IF (V(F) .GE. V(F0)) GO TO 180
+ V(RADFAC) = ONE
+ K = IV(NITER)
+ GO TO 130
+C
+ 180 IF (IV(NFCALL) .LT. IV(MXFCAL) + IV(NFCOV)) GO TO 200
+ IV(1) = 9
+ 190 IF (V(F) .GE. V(F0)) GO TO 999
+C
+C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
+C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
+C
+ IV(CNVCOD) = IV(1)
+ GO TO 430
+C
+C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
+C
+ 200 STEP1 = IV(STEP)
+ W1 = IV(W)
+ H1 = IV(H)
+ T1 = ONE
+ IF (IV(MODEL) .EQ. 2) GO TO 210
+ T1 = ZERO
+C
+C *** COMPUTE LEVENBERG-MARQUARDT STEP IF POSSIBLE...
+C
+ RMAT1 = IV(RMAT)
+ IF (RMAT1 .LE. 0) GO TO 210
+ QTR1 = IV(QTR)
+ IF (QTR1 .LE. 0) GO TO 210
+ IPIV1 = IV(IPIVOT)
+ CALL DL7MST(D, G, IV(IERR), IV(IPIV1), IV(KALM), P, V(QTR1),
+ 1 V(RMAT1), V(STEP1), V, V(W1))
+C *** H IS STORED IN THE END OF W AND HAS JUST BEEN OVERWRITTEN,
+C *** SO WE MARK IT INVALID...
+ IV(H) = -IABS(H1)
+C *** EVEN IF H WERE STORED ELSEWHERE, IT WOULD BE NECESSARY TO
+C *** MARK INVALID THE INFORMATION DG7QTS MAY HAVE STORED IN V...
+ IV(KAGQT) = -1
+ GO TO 260
+C
+ 210 IF (H1 .GT. 0) GO TO 250
+C
+C *** SET H TO D**-1 * (HC + T1*S) * D**-1. ***
+C
+ H1 = -H1
+ IV(H) = H1
+ IV(FDH) = 0
+ J = IV(HC)
+ IF (J .GT. 0) GO TO 220
+ J = H1
+ RMAT1 = IV(RMAT)
+ CALL DL7SQR(P, V(H1), V(RMAT1))
+ 220 S1 = IV(S)
+ DO 240 I = 1, P
+ T = ONE / D(I)
+ DO 230 K = 1, I
+ V(H1) = T * (V(J) + T1*V(S1)) / D(K)
+ J = J + 1
+ H1 = H1 + 1
+ S1 = S1 + 1
+ 230 CONTINUE
+ 240 CONTINUE
+ H1 = IV(H)
+ IV(KAGQT) = -1
+C
+C *** COMPUTE ACTUAL GOLDFELD-QUANDT-TROTTER STEP ***
+C
+ 250 DIG1 = IV(DIG)
+ LMAT1 = IV(LMAT)
+ CALL DG7QTS(D, V(DIG1), V(H1), IV(KAGQT), V(LMAT1), P, V(STEP1),
+ 1 V, V(W1))
+ IF (IV(KALM) .GT. 0) IV(KALM) = 0
+C
+ 260 IF (IV(IRC) .NE. 6) GO TO 270
+ IF (IV(RESTOR) .NE. 2) GO TO 290
+ RSTRST = 2
+ GO TO 300
+C
+C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
+C
+ 270 IV(TOOBIG) = 0
+ IF (V(DSTNRM) .LE. ZERO) GO TO 290
+ IF (IV(IRC) .NE. 5) GO TO 280
+ IF (V(RADFAC) .LE. ONE) GO TO 280
+ IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 280
+ STEP1 = IV(STEP)
+ X01 = IV(X0)
+ CALL DV2AXY(P, V(STEP1), NEGONE, V(X01), X)
+ IF (IV(RESTOR) .NE. 2) GO TO 290
+ RSTRST = 0
+ GO TO 300
+C
+C *** COMPUTE F(X0 + STEP) ***
+C
+ 280 X01 = IV(X0)
+ STEP1 = IV(STEP)
+ CALL DV2AXY(P, X, ONE, V(STEP1), V(X01))
+ IV(NFCALL) = IV(NFCALL) + 1
+ IV(1) = 1
+ GO TO 999
+C
+C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
+C
+ 290 RSTRST = 3
+ 300 X01 = IV(X0)
+ V(RELDX) = DRLDST(P, D, X, V(X01))
+ CALL DA7SST(IV, LIV, LV, V)
+ STEP1 = IV(STEP)
+ LSTGST = IV(STLSTG)
+ I = IV(RESTOR) + 1
+ GO TO (340, 310, 320, 330), I
+ 310 CALL DV7CPY(P, X, V(X01))
+ GO TO 340
+ 320 CALL DV7CPY(P, V(LSTGST), V(STEP1))
+ GO TO 340
+ 330 CALL DV7CPY(P, V(STEP1), V(LSTGST))
+ CALL DV2AXY(P, X, ONE, V(STEP1), V(X01))
+ V(RELDX) = DRLDST(P, D, X, V(X01))
+ IV(RESTOR) = RSTRST
+C
+C *** IF NECESSARY, SWITCH MODELS ***
+C
+ 340 IF (IV(SWITCH) .EQ. 0) GO TO 350
+ IV(H) = -IABS(IV(H))
+ IV(SUSED) = IV(SUSED) + 2
+ L = IV(VSAVE)
+ CALL DV7CPY(NVSAVE, V, V(L))
+ 350 L = IV(IRC) - 4
+ STPMOD = IV(MODEL)
+ IF (L .GT. 0) GO TO (370,380,390,390,390,390,390,390,500,440), L
+C
+C *** DECIDE WHETHER TO CHANGE MODELS ***
+C
+ E = V(PREDUC) - V(FDIF)
+ S1 = IV(S)
+ CALL DS7LVM(PS, Y, V(S1), V(STEP1))
+ STTSST = HALF * DD7TPR(PS, V(STEP1), Y)
+ IF (IV(MODEL) .EQ. 1) STTSST = -STTSST
+ IF (DABS(E + STTSST) * V(FUZZ) .GE. DABS(E)) GO TO 360
+C
+C *** SWITCH MODELS ***
+C
+ IV(MODEL) = 3 - IV(MODEL)
+ IF (-2 .LT. L) GO TO 400
+ IV(H) = -IABS(IV(H))
+ IV(SUSED) = IV(SUSED) + 2
+ L = IV(VSAVE)
+ CALL DV7CPY(NVSAVE, V(L), V)
+ GO TO 160
+C
+ 360 IF (-3 .LT. L) GO TO 400
+C
+C *** RECOMPUTE STEP WITH NEW RADIUS ***
+C
+ 370 V(RADIUS) = V(RADFAC) * V(DSTNRM)
+ GO TO 160
+C
+C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST
+C
+ 380 V(RADIUS) = V(LMAXS)
+ GO TO 200
+C
+C *** CONVERGENCE OR FALSE CONVERGENCE ***
+C
+ 390 IV(CNVCOD) = L
+ IF (V(F) .GE. V(F0)) GO TO 510
+ IF (IV(XIRC) .EQ. 14) GO TO 510
+ IV(XIRC) = 14
+C
+C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
+C
+ 400 IV(COVMAT) = 0
+ IV(REGD) = 0
+C
+C *** SEE WHETHER TO SET V(RADFAC) BY GRADIENT TESTS ***
+C
+ IF (IV(IRC) .NE. 3) GO TO 430
+ STEP1 = IV(STEP)
+ TEMP1 = IV(STLSTG)
+ TEMP2 = IV(W)
+C
+C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS ***
+C
+ HC1 = IV(HC)
+ IF (HC1 .LE. 0) GO TO 410
+ CALL DS7LVM(P, V(TEMP1), V(HC1), V(STEP1))
+ GO TO 420
+ 410 RMAT1 = IV(RMAT)
+ CALL DL7TVM(P, V(TEMP1), V(RMAT1), V(STEP1))
+ CALL DL7VML(P, V(TEMP1), V(RMAT1), V(TEMP1))
+C
+ 420 IF (STPMOD .EQ. 1) GO TO 430
+ S1 = IV(S)
+ CALL DS7LVM(PS, V(TEMP2), V(S1), V(STEP1))
+ CALL DV2AXY(PS, V(TEMP1), ONE, V(TEMP2), V(TEMP1))
+C
+C *** SAVE OLD GRADIENT AND COMPUTE NEW ONE ***
+C
+ 430 IV(NGCALL) = IV(NGCALL) + 1
+ G01 = IV(W)
+ CALL DV7CPY(P, V(G01), G)
+ IV(1) = 2
+ IV(TOOBIG) = 0
+ GO TO 999
+C
+C *** INITIALIZATIONS -- G0 = G - G0, ETC. ***
+C
+ 440 G01 = IV(W)
+ CALL DV2AXY(P, V(G01), NEGONE, V(G01), G)
+ STEP1 = IV(STEP)
+ TEMP1 = IV(STLSTG)
+ TEMP2 = IV(W)
+ IF (IV(IRC) .NE. 3) GO TO 470
+C
+C *** SET V(RADFAC) BY GRADIENT TESTS ***
+C
+C *** SET TEMP1 = D**-1 * (HESSIAN * STEP + (G(X0) - G(X))) ***
+C
+ K = TEMP1
+ L = G01
+ DO 450 I = 1, P
+ V(K) = (V(K) - V(L)) / D(I)
+ K = K + 1
+ L = L + 1
+ 450 CONTINUE
+C
+C *** DO GRADIENT TESTS ***
+C
+ IF (DV2NRM(P, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4)) GO TO 460
+ IF (DD7TPR(P, G, V(STEP1))
+ 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 470
+ 460 V(RADFAC) = V(INCFAC)
+C
+C *** COMPUTE Y VECTOR NEEDED FOR UPDATING S ***
+C
+ 470 CALL DV2AXY(PS, Y, NEGONE, Y, G)
+C
+C *** DETERMINE SIZING FACTOR V(SIZE) ***
+C
+C *** SET TEMP1 = S * STEP ***
+ S1 = IV(S)
+ CALL DS7LVM(PS, V(TEMP1), V(S1), V(STEP1))
+C
+ T1 = DABS(DD7TPR(PS, V(STEP1), V(TEMP1)))
+ T = DABS(DD7TPR(PS, V(STEP1), Y))
+ V(SIZE) = ONE
+ IF (T .LT. T1) V(SIZE) = T / T1
+C
+C *** SET G0 TO WCHMTD CHOICE OF FLETCHER AND AL-BAALI ***
+C
+ HC1 = IV(HC)
+ IF (HC1 .LE. 0) GO TO 480
+ CALL DS7LVM(PS, V(G01), V(HC1), V(STEP1))
+ GO TO 490
+C
+ 480 RMAT1 = IV(RMAT)
+ CALL DL7TVM(PS, V(G01), V(RMAT1), V(STEP1))
+ CALL DL7VML(PS, V(G01), V(RMAT1), V(G01))
+C
+ 490 CALL DV2AXY(PS, V(G01), ONE, Y, V(G01))
+C
+C *** UPDATE S ***
+C
+ CALL DS7LUP(V(S1), V(COSMIN), PS, V(SIZE), V(STEP1), V(TEMP1),
+ 1 V(TEMP2), V(G01), V(WSCALE), Y)
+ IV(1) = 2
+ GO TO 110
+C
+C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
+C
+C *** BAD PARAMETERS TO ASSESS ***
+C
+ 500 IV(1) = 64
+ GO TO 999
+C
+C
+C *** CONVERGENCE OBTAINED -- SEE WHETHER TO COMPUTE COVARIANCE ***
+C
+ 510 IF (IV(RDREQ) .EQ. 0) GO TO 600
+ IF (IV(FDH) .NE. 0) GO TO 600
+ IF (IV(CNVCOD) .GE. 7) GO TO 600
+ IF (IV(REGD) .GT. 0) GO TO 600
+ IF (IV(COVMAT) .GT. 0) GO TO 600
+ IF (IABS(IV(COVREQ)) .GE. 3) GO TO 560
+ IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2
+ GO TO 530
+C
+C *** COMPUTE FINITE-DIFFERENCE HESSIAN FOR COMPUTING COVARIANCE ***
+C
+ 520 IV(RESTOR) = 0
+ 530 CALL DF7HES(D, G, I, IV, LIV, LV, P, V, X)
+ GO TO (540, 550, 580), I
+ 540 IV(NFCOV) = IV(NFCOV) + 1
+ IV(NFCALL) = IV(NFCALL) + 1
+ IV(1) = 1
+ GO TO 999
+C
+ 550 IV(NGCOV) = IV(NGCOV) + 1
+ IV(NGCALL) = IV(NGCALL) + 1
+ IV(NFGCAL) = IV(NFCALL) + IV(NGCOV)
+ IV(1) = 2
+ GO TO 999
+C
+ 560 H1 = IABS(IV(H))
+ IV(H) = -H1
+ PP1O2 = P * (P + 1) / 2
+ RMAT1 = IV(RMAT)
+ IF (RMAT1 .LE. 0) GO TO 570
+ LMAT1 = IV(LMAT)
+ CALL DV7CPY(PP1O2, V(LMAT1), V(RMAT1))
+ V(RCOND) = ZERO
+ GO TO 590
+ 570 HC1 = IV(HC)
+ IV(FDH) = H1
+ CALL DV7CPY(P*(P+1)/2, V(H1), V(HC1))
+C
+C *** COMPUTE CHOLESKY FACTOR OF FINITE-DIFFERENCE HESSIAN
+C *** FOR USE IN CALLER*S COVARIANCE CALCULATION...
+C
+ 580 LMAT1 = IV(LMAT)
+ H1 = IV(FDH)
+ IF (H1 .LE. 0) GO TO 600
+ IF (IV(CNVCOD) .EQ. 70) GO TO 80
+ CALL DL7SRT(1, P, V(LMAT1), V(H1), I)
+ IV(FDH) = -1
+ V(RCOND) = ZERO
+ IF (I .NE. 0) GO TO 600
+C
+ 590 IV(FDH) = -1
+ STEP1 = IV(STEP)
+ T = DL7SVN(P, V(LMAT1), V(STEP1), V(STEP1))
+ IF (T .LE. ZERO) GO TO 600
+ T = T / DL7SVX(P, V(LMAT1), V(STEP1), V(STEP1))
+ IF (T .GT. DR7MDC(4)) IV(FDH) = H1
+ V(RCOND) = T
+C
+ 600 IV(MODE) = 0
+ IV(1) = IV(CNVCOD)
+ IV(CNVCOD) = 0
+ GO TO 999
+C
+C *** SPECIAL RETURN FOR MISSING HESSIAN INFORMATION -- BOTH
+C *** IV(HC) .LE. 0 AND IV(RMAT) .LE. 0
+C
+ 610 IV(1) = 1400
+C
+ 999 RETURN
+C
+C *** LAST LINE OF DG7LIT FOLLOWS ***
+ END
+ SUBROUTINE DL7MSB(B, D, G, IERR, IPIV, IPIV1, IPIV2, KA, LMAT,
+ 1 LV, P, P0, PC, QTR, RMAT, STEP, TD, TG, V,
+ 2 W, WLM, X, X0)
+C
+C *** COMPUTE HEURISTIC BOUNDED NEWTON STEP ***
+C
+ INTEGER IERR, KA, LV, P, P0, PC
+ INTEGER IPIV(P), IPIV1(P), IPIV2(P)
+ DOUBLE PRECISION B(2,P), D(P), G(P), LMAT(*), QTR(P), RMAT(*),
+ 1 STEP(P,3), TD(P), TG(P), V(LV), W(P), WLM(*),
+ 2 X0(P), X(P)
+C DIMENSION LMAT(P*(P+1)/2), RMAT(P*(P+1)/2), WLM(P*(P+5)/2 + 4)
+C
+ DOUBLE PRECISION DD7TPR
+ EXTERNAL DD7MLP, DD7TPR, DL7MST, DL7TVM, DQ7RSH, DS7BQN,
+ 1 DV2AXY,DV7CPY, DV7IPR, DV7SCP, DV7VMP
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER I, J, K, K0, KB, KINIT, L, NS, P1, P10, P11
+ DOUBLE PRECISION DS0, NRED, PRED, RAD
+ DOUBLE PRECISION ONE, ZERO
+C
+C *** V SUBSCRIPTS ***
+C
+ INTEGER DST0, DSTNRM, GTSTEP, NREDUC, PREDUC, RADIUS
+C
+ PARAMETER (DST0=3, DSTNRM=2, GTSTEP=4, NREDUC=6, PREDUC=7,
+ 1 RADIUS=8)
+ DATA ONE/1.D+0/, ZERO/0.D+0/
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ P1 = PC
+ IF (KA .LT. 0) GO TO 10
+ NRED = V(NREDUC)
+ DS0 = V(DST0)
+ GO TO 20
+ 10 P0 = 0
+ KA = -1
+C
+ 20 KINIT = -1
+ IF (P0 .EQ. P1) KINIT = KA
+ CALL DV7CPY(P, X, X0)
+ CALL DV7CPY(P, TD, D)
+C *** USE STEP(1,3) AS TEMP. COPY OF QTR ***
+ CALL DV7CPY(P, STEP(1,3), QTR)
+ CALL DV7IPR(P, IPIV, TD)
+ PRED = ZERO
+ RAD = V(RADIUS)
+ KB = -1
+ V(DSTNRM) = ZERO
+ IF (P1 .GT. 0) GO TO 30
+ NRED = ZERO
+ DS0 = ZERO
+ CALL DV7SCP(P, STEP, ZERO)
+ GO TO 90
+C
+ 30 CALL DV7VMP(P, TG, G, D, -1)
+ CALL DV7IPR(P, IPIV, TG)
+ P10 = P1
+ 40 K = KINIT
+ KINIT = -1
+ V(RADIUS) = RAD - V(DSTNRM)
+ CALL DV7VMP(P1, TG, TG, TD, 1)
+ DO 50 I = 1, P1
+ 50 IPIV1(I) = I
+ K0 = MAX0(0, K)
+ CALL DL7MST(TD, TG, IERR, IPIV1, K, P1, STEP(1,3), RMAT, STEP,
+ 1 V, WLM)
+ CALL DV7VMP(P1, TG, TG, TD, -1)
+ P0 = P1
+ IF (KA .GE. 0) GO TO 60
+ NRED = V(NREDUC)
+ DS0 = V(DST0)
+C
+ 60 KA = K
+ V(RADIUS) = RAD
+ L = P1 + 5
+ IF (K .LE. K0) CALL DD7MLP(P1, LMAT, TD, RMAT, -1)
+ IF (K .GT. K0) CALL DD7MLP(P1, LMAT, TD, WLM(L), -1)
+ CALL DS7BQN(B, D, STEP(1,2), IPIV, IPIV1, IPIV2, KB, LMAT,
+ 1 LV, NS, P, P1, STEP, TD, TG, V, W, X, X0)
+ PRED = PRED + V(PREDUC)
+ IF (NS .EQ. 0) GO TO 80
+ P0 = 0
+C
+C *** UPDATE RMAT AND QTR ***
+C
+ P11 = P1 + 1
+ L = P10 + P11
+ DO 70 K = P11, P10
+ J = L - K
+ I = IPIV2(J)
+ IF (I .LT. J) CALL DQ7RSH(I, J, .TRUE., QTR, RMAT, W)
+ 70 CONTINUE
+C
+ 80 IF (KB .GT. 0) GO TO 90
+C
+C *** UPDATE LOCAL COPY OF QTR ***
+C
+ CALL DV7VMP(P10, W, STEP(1,2), TD, -1)
+ CALL DL7TVM(P10, W, LMAT, W)
+ CALL DV2AXY(P10, STEP(1,3), ONE, W, QTR)
+ GO TO 40
+C
+ 90 V(DST0) = DS0
+ V(NREDUC) = NRED
+ V(PREDUC) = PRED
+ V(GTSTEP) = DD7TPR(P, G, STEP)
+C
+ RETURN
+C *** LAST LINE OF DL7MSB FOLLOWS ***
+ END
+ SUBROUTINE DN2LRD(DR, IV, L, LH, LIV, LV, ND, NN, P, R, RD, V)
+C
+C *** COMPUTE REGRESSION DIAGNOSTIC AND DEFAULT COVARIANCE MATRIX FOR
+C DRN2G ***
+C
+C *** PARAMETERS ***
+C
+ INTEGER LH, LIV, LV, ND, NN, P
+ INTEGER IV(LIV)
+ DOUBLE PRECISION DR(ND,P), L(LH), R(NN), RD(NN), V(LV)
+C
+C *** CODED BY DAVID M. GAY (WINTER 1982, FALL 1983) ***
+C
+C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
+C
+ DOUBLE PRECISION DD7TPR
+ EXTERNAL DD7TPR, DL7ITV, DL7IVM,DO7PRD, DV7SCP
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER COV, I, J, M, STEP1
+ DOUBLE PRECISION A, FF, S, T
+C
+C *** CONSTANTS ***
+C
+ DOUBLE PRECISION NEGONE, ONE, ONEV(1), ZERO
+C
+C *** INTRINSIC FUNCTIONS ***
+C/+
+ DOUBLE PRECISION DSQRT
+C/
+C
+C *** IV AND V SUBSCRIPTS ***
+C
+ INTEGER F, H, MODE, RDREQ, STEP
+ PARAMETER (F=10, H=56, MODE=35, RDREQ=57, STEP=40)
+ PARAMETER (NEGONE=-1.D+0, ONE=1.D+0, ZERO=0.D+0)
+ DATA ONEV(1)/1.D+0/
+C
+C++++++++++++++++++++++++++++++++ BODY +++++++++++++++++++++++++++++++
+C
+ STEP1 = IV(STEP)
+ I = IV(RDREQ)
+ IF (I .LE. 0) GO TO 999
+ IF (MOD(I,4) .LT. 2) GO TO 30
+ FF = ONE
+ IF (V(F) .NE. ZERO) FF = ONE / DSQRT(DABS(V(F)))
+ CALL DV7SCP(NN, RD, NEGONE)
+ DO 20 I = 1, NN
+ A = R(I)**2
+ M = STEP1
+ DO 10 J = 1, P
+ V(M) = DR(I,J)
+ M = M + 1
+ 10 CONTINUE
+ CALL DL7IVM(P, V(STEP1), L, V(STEP1))
+ S = DD7TPR(P, V(STEP1), V(STEP1))
+ T = ONE - S
+ IF (T .LE. ZERO) GO TO 20
+ A = A * S / T
+ RD(I) = DSQRT(A) * FF
+ 20 CONTINUE
+C
+ 30 IF (IV(MODE) - P .LT. 2) GO TO 999
+C
+C *** COMPUTE DEFAULT COVARIANCE MATRIX ***
+C
+ COV = IABS(IV(H))
+ DO 50 I = 1, NN
+ M = STEP1
+ DO 40 J = 1, P
+ V(M) = DR(I,J)
+ M = M + 1
+ 40 CONTINUE
+ CALL DL7IVM(P, V(STEP1), L, V(STEP1))
+ CALL DL7ITV(P, V(STEP1), L, V(STEP1))
+ CALL DO7PRD(1, LH, P, V(COV), ONEV, V(STEP1), V(STEP1))
+ 50 CONTINUE
+C
+ 999 RETURN
+C *** LAST LINE OF DN2LRD FOLLOWS ***
+ END
+ SUBROUTINE DR7TVM(N, P, Y, D, U, X)
+C
+C *** SET Y TO R*X, WHERE R IS THE UPPER TRIANGULAR MATRIX WHOSE
+C *** DIAGONAL IS IN D AND WHOSE STRICT UPPER TRIANGLE IS IN U.
+C
+C *** X AND Y MAY SHARE STORAGE.
+C
+ INTEGER N, P
+ DOUBLE PRECISION Y(P), D(P), U(N,P), X(P)
+C
+ DOUBLE PRECISION DD7TPR
+ EXTERNAL DD7TPR
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER I, II, PL, PP1
+ DOUBLE PRECISION T
+C
+C *** BODY ***
+C
+ PL = MIN0(N, P)
+ PP1 = PL + 1
+ DO 10 II = 1, PL
+ I = PP1 - II
+ T = X(I) * D(I)
+ IF (I .GT. 1) T = T + DD7TPR(I-1, U(1,I), X)
+ Y(I) = T
+ 10 CONTINUE
+ RETURN
+C *** LAST LINE OF DR7TVM FOLLOWS ***
+ END
+ SUBROUTINE DQ7RAD(N, NN, P, QTR, QTRSET, RMAT, W, Y)
+C
+C *** ADD ROWS W TO QR FACTORIZATION WITH R MATRIX RMAT AND
+C *** Q**T * RESIDUAL = QTR. Y = NEW COMPONENTS OF RESIDUAL
+C *** CORRESPONDING TO W. QTR, Y REFERENCED ONLY IF QTRSET = .TRUE.
+C
+ LOGICAL QTRSET
+ INTEGER N, NN, P
+ DOUBLE PRECISION QTR(P), RMAT(*), W(NN,P), Y(N)
+C DIMENSION RMAT(P*(P+1)/2)
+C/+
+ DOUBLE PRECISION DSQRT
+C/
+ DOUBLE PRECISION DD7TPR, DR7MDC, DV2NRM
+ EXTERNAL DD7TPR, DR7MDC,DV2AXY, DV7SCL, DV2NRM
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER I, II, IJ, IP1, J, K, NK
+ DOUBLE PRECISION ARI, QRI, RI, S, T, WI
+ DOUBLE PRECISION BIG, BIGRT, ONE, TINY, TINYRT, ZERO
+ SAVE BIGRT, TINY, TINYRT
+ DATA BIG/-1.D+0/, BIGRT/-1.D+0/, ONE/1.D+0/, TINY/0.D+0/,
+ 1 TINYRT/0.D+0/, ZERO/0.D+0/
+C
+C------------------------------ BODY -----------------------------------
+C
+ IF (TINY .GT. ZERO) GO TO 10
+ TINY = DR7MDC(1)
+ BIG = DR7MDC(6)
+ IF (TINY*BIG .LT. ONE) TINY = ONE / BIG
+ 10 K = 1
+ NK = N
+ II = 0
+ DO 180 I = 1, P
+ II = II + I
+ IP1 = I + 1
+ IJ = II + I
+ IF (NK .LE. 1) T = DABS(W(K,I))
+ IF (NK .GT. 1) T = DV2NRM(NK, W(K,I))
+ IF (T .LT. TINY) GOTO 180
+ RI = RMAT(II)
+ IF (RI .NE. ZERO) GO TO 100
+ IF (NK .GT. 1) GO TO 30
+ IJ = II
+ DO 20 J = I, P
+ RMAT(IJ) = W(K,J)
+ IJ = IJ + J
+ 20 CONTINUE
+ IF (QTRSET) QTR(I) = Y(K)
+ W(K,I) = ZERO
+ GO TO 999
+ 30 WI = W(K,I)
+ IF (BIGRT .GT. ZERO) GO TO 40
+ BIGRT = DR7MDC(5)
+ TINYRT = DR7MDC(2)
+ 40 IF (T .LE. TINYRT) GO TO 50
+ IF (T .GE. BIGRT) GO TO 50
+ IF (WI .LT. ZERO) T = -T
+ WI = WI + T
+ S = DSQRT(T * WI)
+ GO TO 70
+ 50 S = DSQRT(T)
+ IF (WI .LT. ZERO) GO TO 60
+ WI = WI + T
+ S = S * DSQRT(WI)
+ GO TO 70
+ 60 T = -T
+ WI = WI + T
+ S = S * DSQRT(-WI)
+ 70 W(K,I) = WI
+ CALL DV7SCL(NK, W(K,I), ONE/S, W(K,I))
+ RMAT(II) = -T
+ IF (.NOT. QTRSET) GO TO 80
+ CALL DV2AXY(NK, Y(K), -DD7TPR(NK,Y(K),W(K,I)), W(K,I), Y(K))
+ QTR(I) = Y(K)
+ 80 IF (IP1 .GT. P) GO TO 999
+ DO 90 J = IP1, P
+ CALL DV2AXY(NK, W(K,J), -DD7TPR(NK,W(K,J),W(K,I)),
+ 1 W(K,I), W(K,J))
+ RMAT(IJ) = W(K,J)
+ IJ = IJ + J
+ 90 CONTINUE
+ IF (NK .LE. 1) GO TO 999
+ K = K + 1
+ NK = NK - 1
+ GO TO 180
+C
+ 100 ARI = DABS(RI)
+ IF (ARI .GT. T) GO TO 110
+ T = T * DSQRT(ONE + (ARI/T)**2)
+ GO TO 120
+ 110 T = ARI * DSQRT(ONE + (T/ARI)**2)
+ 120 IF (RI .LT. ZERO) T = -T
+ RI = RI + T
+ RMAT(II) = -T
+ S = -RI / T
+ IF (NK .LE. 1) GO TO 150
+ CALL DV7SCL(NK, W(K,I), ONE/RI, W(K,I))
+ IF (.NOT. QTRSET) GO TO 130
+ QRI = QTR(I)
+ T = S * ( QRI + DD7TPR(NK, Y(K), W(K,I)) )
+ QTR(I) = QRI + T
+ 130 IF (IP1 .GT. P) GO TO 999
+ IF (QTRSET) CALL DV2AXY(NK, Y(K), T, W(K,I), Y(K))
+ DO 140 J = IP1, P
+ RI = RMAT(IJ)
+ T = S * ( RI + DD7TPR(NK, W(K,J), W(K,I)) )
+ CALL DV2AXY(NK, W(K,J), T, W(K,I), W(K,J))
+ RMAT(IJ) = RI + T
+ IJ = IJ + J
+ 140 CONTINUE
+ GO TO 180
+C
+ 150 WI = W(K,I) / RI
+ W(K,I) = WI
+ IF (.NOT. QTRSET) GO TO 160
+ QRI = QTR(I)
+ T = S * ( QRI + Y(K)*WI )
+ QTR(I) = QRI + T
+ 160 IF (IP1 .GT. P) GO TO 999
+ IF (QTRSET) Y(K) = T*WI + Y(K)
+ DO 170 J = IP1, P
+ RI = RMAT(IJ)
+ T = S * (RI + W(K,J)*WI)
+ W(K,J) = W(K,J) + T*WI
+ RMAT(IJ) = RI + T
+ IJ = IJ + J
+ 170 CONTINUE
+ 180 CONTINUE
+C
+ 999 RETURN
+C *** LAST LINE OF DQ7RAD FOLLOWS ***
+ END
+ SUBROUTINE DF7HES(D, G, IRT, IV, LIV, LV, P, V, X)
+C
+C *** COMPUTE FINITE-DIFFERENCE HESSIAN, STORE IT IN V STARTING
+C *** AT V(IV(FDH)) = V(-IV(H)).
+C
+C *** IF IV(COVREQ) .GE. 0 THEN DF7HES USES GRADIENT DIFFERENCES,
+C *** OTHERWISE FUNCTION DIFFERENCES. STORAGE IN V IS AS IN DG7LIT.
+C
+C IRT VALUES...
+C 1 = COMPUTE FUNCTION VALUE, I.E., V(F).
+C 2 = COMPUTE G.
+C 3 = DONE.
+C
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER IRT, LIV, LV, P
+ INTEGER IV(LIV)
+ DOUBLE PRECISION D(P), G(P), V(LV), X(P)
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER GSAVE1, HES, HMI, HPI, HPM, I, K, KIND, L, M, MM1, MM1O2,
+ 1 PP1O2, STPI, STPM, STP0
+ DOUBLE PRECISION DEL, HALF, NEGPT5, ONE, TWO, ZERO
+C
+C *** EXTERNAL SUBROUTINES ***
+C
+ EXTERNAL DV7CPY
+C
+C DV7CPY.... COPY ONE VECTOR TO ANOTHER.
+C
+C *** SUBSCRIPTS FOR IV AND V ***
+C
+ INTEGER COVREQ, DELTA, DELTA0, DLTFDC, F, FDH, FX, H, KAGQT, MODE,
+ 1 NFGCAL, SAVEI, SWITCH, TOOBIG, W, XMSAVE
+C
+ PARAMETER (HALF=0.5D+0, NEGPT5=-0.5D+0, ONE=1.D+0, TWO=2.D+0,
+ 1 ZERO=0.D+0)
+C
+ PARAMETER (COVREQ=15, DELTA=52, DELTA0=44, DLTFDC=42, F=10,
+ 1 FDH=74, FX=53, H=56, KAGQT=33, MODE=35, NFGCAL=7,
+ 2 SAVEI=63, SWITCH=12, TOOBIG=2, W=65, XMSAVE=51)
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ IRT = 4
+ KIND = IV(COVREQ)
+ M = IV(MODE)
+ IF (M .GT. 0) GO TO 10
+ IV(H) = -IABS(IV(H))
+ IV(FDH) = 0
+ IV(KAGQT) = -1
+ V(FX) = V(F)
+ 10 IF (M .GT. P) GO TO 999
+ IF (KIND .LT. 0) GO TO 110
+C
+C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND
+C *** GRADIENT VALUES.
+C
+ GSAVE1 = IV(W) + P
+ IF (M .GT. 0) GO TO 20
+C *** FIRST CALL ON DF7HES. SET GSAVE = G, TAKE FIRST STEP ***
+ CALL DV7CPY(P, V(GSAVE1), G)
+ IV(SWITCH) = IV(NFGCAL)
+ GO TO 90
+C
+ 20 DEL = V(DELTA)
+ X(M) = V(XMSAVE)
+ IF (IV(TOOBIG) .EQ. 0) GO TO 40
+C
+C *** HANDLE OVERSIZE V(DELTA) ***
+C
+ IF (DEL*X(M) .GT. ZERO) GO TO 30
+C *** WE ALREADY TRIED SHRINKING V(DELTA), SO QUIT ***
+ IV(FDH) = -2
+ GO TO 220
+C
+C *** TRY SHRINKING V(DELTA) ***
+ 30 DEL = NEGPT5 * DEL
+ GO TO 100
+C
+ 40 HES = -IV(H)
+C
+C *** SET G = (G - GSAVE)/DEL ***
+C
+ DO 50 I = 1, P
+ G(I) = (G(I) - V(GSAVE1)) / DEL
+ GSAVE1 = GSAVE1 + 1
+ 50 CONTINUE
+C
+C *** ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX ***
+C
+ K = HES + M*(M-1)/2
+ L = K + M - 2
+ IF (M .EQ. 1) GO TO 70
+C
+C *** SET H(I,M) = 0.5 * (H(I,M) + G(I)) FOR I = 1 TO M-1 ***
+C
+ MM1 = M - 1
+ DO 60 I = 1, MM1
+ V(K) = HALF * (V(K) + G(I))
+ K = K + 1
+ 60 CONTINUE
+C
+C *** ADD H(I,M) = G(I) FOR I = M TO P ***
+C
+ 70 L = L + 1
+ DO 80 I = M, P
+ V(L) = G(I)
+ L = L + I
+ 80 CONTINUE
+C
+ 90 M = M + 1
+ IV(MODE) = M
+ IF (M .GT. P) GO TO 210
+C
+C *** CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE ***
+C
+ DEL = V(DELTA0) * DMAX1(ONE/D(M), DABS(X(M)))
+ IF (X(M) .LT. ZERO) DEL = -DEL
+ V(XMSAVE) = X(M)
+ 100 X(M) = X(M) + DEL
+ V(DELTA) = DEL
+ IRT = 2
+ GO TO 999
+C
+C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY.
+C
+ 110 STP0 = IV(W) + P - 1
+ MM1 = M - 1
+ MM1O2 = M*MM1/2
+ IF (M .GT. 0) GO TO 120
+C *** FIRST CALL ON DF7HES. ***
+ IV(SAVEI) = 0
+ GO TO 200
+C
+ 120 I = IV(SAVEI)
+ HES = -IV(H)
+ IF (I .GT. 0) GO TO 180
+ IF (IV(TOOBIG) .EQ. 0) GO TO 140
+C
+C *** HANDLE OVERSIZE STEP ***
+C
+ STPM = STP0 + M
+ DEL = V(STPM)
+ IF (DEL*X(XMSAVE) .GT. ZERO) GO TO 130
+C *** WE ALREADY TRIED SHRINKING THE STEP, SO QUIT ***
+ IV(FDH) = -2
+ GO TO 220
+C
+C *** TRY SHRINKING THE STEP ***
+ 130 DEL = NEGPT5 * DEL
+ X(M) = X(XMSAVE) + DEL
+ V(STPM) = DEL
+ IRT = 1
+ GO TO 999
+C
+C *** SAVE F(X + STP(M)*E(M)) IN H(P,M) ***
+C
+ 140 PP1O2 = P * (P-1) / 2
+ HPM = HES + PP1O2 + MM1
+ V(HPM) = V(F)
+C
+C *** START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H. ***
+C
+ HMI = HES + MM1O2
+ IF (MM1 .EQ. 0) GO TO 160
+ HPI = HES + PP1O2
+ DO 150 I = 1, MM1
+ V(HMI) = V(FX) - (V(F) + V(HPI))
+ HMI = HMI + 1
+ HPI = HPI + 1
+ 150 CONTINUE
+ 160 V(HMI) = V(F) - TWO*V(FX)
+C
+C *** COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H. ***
+C
+ I = 1
+C
+ 170 IV(SAVEI) = I
+ STPI = STP0 + I
+ V(DELTA) = X(I)
+ X(I) = X(I) + V(STPI)
+ IF (I .EQ. M) X(I) = V(XMSAVE) - V(STPI)
+ IRT = 1
+ GO TO 999
+C
+ 180 X(I) = V(DELTA)
+ IF (IV(TOOBIG) .EQ. 0) GO TO 190
+C *** PUNT IN THE EVENT OF AN OVERSIZE STEP ***
+ IV(FDH) = -2
+ GO TO 220
+C
+C *** FINISH COMPUTING H(M,I) ***
+C
+ 190 STPI = STP0 + I
+ HMI = HES + MM1O2 + I - 1
+ STPM = STP0 + M
+ V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM))
+ I = I + 1
+ IF (I .LE. M) GO TO 170
+ IV(SAVEI) = 0
+ X(M) = V(XMSAVE)
+C
+ 200 M = M + 1
+ IV(MODE) = M
+ IF (M .GT. P) GO TO 210
+C
+C *** PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H.
+C *** COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN
+C *** F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR.
+C
+ DEL = V(DLTFDC) * DMAX1(ONE/D(M), DABS(X(M)))
+ IF (X(M) .LT. ZERO) DEL = -DEL
+ V(XMSAVE) = X(M)
+ X(M) = X(M) + DEL
+ STPM = STP0 + M
+ V(STPM) = DEL
+ IRT = 1
+ GO TO 999
+C
+C *** RESTORE V(F), ETC. ***
+C
+ 210 IV(FDH) = HES
+ 220 V(F) = V(FX)
+ IRT = 3
+ IF (KIND .LT. 0) GO TO 999
+ IV(NFGCAL) = IV(SWITCH)
+ GSAVE1 = IV(W) + P
+ CALL DV7CPY(P, G, V(GSAVE1))
+ GO TO 999
+C
+ 999 RETURN
+C *** LAST CARD OF DF7HES FOLLOWS ***
+ END
+ SUBROUTINE DRNSG(A, ALF, C, DA, IN, IV, L, L1, LA, LIV, LV,
+ 1 N, NDA, P, V, Y)
+C
+C *** ITERATION DRIVER FOR SEPARABLE NONLINEAR LEAST SQUARES.
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER L, L1, LA, LIV, LV, N, NDA, P
+ INTEGER IN(2,NDA), IV(LIV)
+C DIMENSION UIPARM(*)
+ DOUBLE PRECISION A(LA,L1), ALF(P), C(L), DA(LA,NDA), V(LV), Y(N)
+C
+C *** PURPOSE ***
+C
+C GIVEN A SET OF N OBSERVATIONS Y(1)....Y(N) OF A DEPENDENT VARIABLE
+C T(1)...T(N), DRNSG ATTEMPTS TO COMPUTE A LEAST SQUARES FIT
+C TO A FUNCTION ETA (THE MODEL) WHICH IS A LINEAR COMBINATION
+C
+C L
+C ETA(C,ALF,T) = SUM C * PHI(ALF,T) +PHI (ALF,T)
+C J=1 J J L+1
+C
+C OF NONLINEAR FUNCTIONS PHI(J) DEPENDENT ON T AND ALF(1),...,ALF(P)
+C (.E.G. A SUM OF EXPONENTIALS OR GAUSSIANS). THAT IS, IT DETERMINES
+C NONLINEAR PARAMETERS ALF WHICH MINIMIZE
+C
+C 2 N 2
+C NORM(RESIDUAL) = SUM (Y - ETA(C,ALF,T )).
+C I=1 I I
+C
+C THE (L+1)ST TERM IS OPTIONAL.
+C
+C
+C *** PARAMETERS ***
+C
+C A (IN) MATRIX PHI(ALF,T) OF THE MODEL.
+C ALF (I/O) NONLINEAR PARAMETERS.
+C INPUT = INITIAL GUESS,
+C OUTPUT = BEST ESTIMATE FOUND.
+C C (OUT) LINEAR PARAMETERS (ESTIMATED).
+C DA (IN) DERIVATIVES OF COLUMNS OF A WITH RESPECT TO COMPONENTS
+C OF ALF, AS SPECIFIED BY THE IN ARRAY...
+C IN (IN) WHEN DRNSG IS CALLED WITH IV(1) = 2 OR -2, THEN FOR
+C I = 1(1)NDA, COLUMN I OF DA IS THE PARTIAL
+C DERIVATIVE WITH RESPECT TO ALF(IN(1,I)) OF COLUMN
+C IN(2,I) OF A, UNLESS IV(1,I) IS NOT POSITIVE (IN
+C WHICH CASE COLUMN I OF DA IS IGNORED. IV(1) = -2
+C MEANS THERE ARE MORE COLUMNS OF DA TO COME AND
+C DRNSG SHOULD RETURN FOR THEM.
+C IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR. DRNSG RETURNS
+C WITH IV(1) = 1 WHEN IT WANTS A TO BE EVALUATED AT
+C ALF AND WITH IV(1) = 2 WHEN IT WANTS DA TO BE
+C EVALUATED AT ALF. WHEN CALLED WITH IV(1) = -2
+C (AFTER A RETURN WITH IV(1) = 2), DRNSG RETURNS
+C WITH IV(1) = -2 TO GET MORE COLUMNS OF DA.
+C L (IN) NUMBER OF LINEAR PARAMETERS TO BE ESTIMATED.
+C L1 (IN) L+1 IF PHI(L+1) IS IN THE MODEL, L IF NOT.
+C LA (IN) LEAD DIMENSION OF A. MUST BE AT LEAST N.
+C LIV (IN) LENGTH OF IV. MUST BE AT LEAST 110 + L + P.
+C LV (IN) LENGTH OF V. MUST BE AT LEAST
+C 105 + 2*N + JLEN + L*(L+3)/2 + P*(2*P + 17),
+C WHERE JLEN = (L+P)*(N+L+P+1), UNLESS NEITHER A
+C COVARIANCE MATRIX NOR REGRESSION DIAGNOSTICS ARE
+C REQUESTED, IN WHICH CASE JLEN = N*P.
+C N (IN) NUMBER OF OBSERVATIONS.
+C NDA (IN) NUMBER OF COLUMNS IN DA AND IN.
+C P (IN) NUMBER OF NONLINEAR PARAMETERS TO BE ESTIMATED.
+C V (I/O) FLOATING-POINT PARAMETER AND SCRATCH VECTOR.
+C IF A COVARIANCE ESTIMATE IS REQUESTED, IT IS FOR
+C (ALF,C) -- NONLINEAR PARAMETERS ORDERED FIRST,
+C FOLLOWED BY LINEAR PARAMETERS.
+C Y (IN) RIGHT-HAND SIDE VECTOR.
+C
+C
+C *** EXTERNAL SUBROUTINES ***
+C
+ DOUBLE PRECISION DD7TPR, DL7SVX, DL7SVN, DR7MDC
+ EXTERNAL DC7VFN,DIVSET, DD7TPR,DITSUM, DL7ITV,DL7SRT, DL7SVX,
+ 1 DL7SVN, DN2CVP, DN2LRD, DN2RDP, DRN2G, DQ7APL,DQ7RAD,
+ 2 DQ7RFH, DR7MDC, DS7CPR,DV2AXY,DV7CPY,DV7PRM, DV7SCL,
+ 3 DV7SCP
+C
+C DC7VFN... FINISHES COVARIANCE COMPUTATION.
+C DIVSET.... SUPPLIES DEFAULT PARAMETER VALUES.
+C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
+C DITSUM.... PRINTS ITERATION SUMMARY, INITIAL AND FINAL ALF.
+C DL7ITV... APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
+C DL7SRT.... COMPUTES (PARTIAL) CHOLESKY FACTORIZATION.
+C DL7SVX... ESTIMATES LARGEST SING. VALUE OF LOWER TRIANG. MATRIX.
+C DL7SVN... ESTIMATES SMALLEST SING. VALUE OF LOWER TRIANG. MATRIX.
+C DN2CVP... PRINTS COVARIANCE MATRIX.
+C DN2LRD... COMPUTES COVARIANCE AND REGRESSION DIAGNOSTICS.
+C DN2RDP... PRINTS REGRESSION DIAGNOSTICS.
+C DRN2G... UNDERLYING NONLINEAR LEAST-SQUARES SOLVER.
+C DQ7APL... APPLIES HOUSEHOLDER TRANSFORMS STORED BY DQ7RFH.
+C DQ7RFH.... COMPUTES QR FACT. VIA HOUSEHOLDER TRANSFORMS WITH PIVOTING.
+C DQ7RAD.... QR FACT., NO PIVOTING.
+C DR7MDC... RETURNS MACHINE-DEP. CONSTANTS.
+C DS7CPR... PRINTS LINEAR PARAMETERS AT SOLUTION.
+C DV2AXY.... ADDS MULTIPLE OF ONE VECTOR TO ANOTHER.
+C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
+C DV7PRM.... PERMUTES A VECTOR.
+C DV7SCL... SCALES AND COPIES ONE VECTOR TO ANOTHER.
+C DV7SCP... SETS ALL COMPONENTS OF A VECTOR TO A SCALAR.
+C
+C *** LOCAL VARIABLES ***
+C
+ LOGICAL NOCOV
+ INTEGER AR1, CSAVE1, D1, DR1, DR1L, DRI, DRI1, FDH0, HSAVE, I, I1,
+ 1 IPIV1, IER, IV1, J1, JLEN, K, LH, LI, LL1O2, MD, N1, N2,
+ 2 NML, NRAN, PP, PP1, R1, R1L, RD1, TEMP1
+ DOUBLE PRECISION SINGTL, T
+ DOUBLE PRECISION MACHEP, NEGONE, SNGFAC, ZERO
+C
+C *** SUBSCRIPTS FOR IV AND V ***
+C
+ INTEGER AR, CNVCOD, COVMAT, COVREQ, CSAVE, CVRQSV, D, FDH, H,
+ 1 IERS, IPIVS, IV1SAV, IVNEED, J, LMAT, MODE, NEXTIV, NEXTV,
+ 2 NFCALL, NFCOV, NFGCAL, NGCALL, NGCOV, PERM, R, RCOND,
+ 3 RDREQ, RDRQSV, REGD, REGD0, RESTOR, TOOBIG, VNEED
+C
+C *** IV SUBSCRIPT VALUES ***
+C
+ PARAMETER (AR=110, CNVCOD=55, COVMAT=26, COVREQ=15, CSAVE=105,
+ 1 CVRQSV=106, D=27, FDH=74, H=56, IERS=108, IPIVS=109,
+ 2 IV1SAV=104, IVNEED=3, J=70, LMAT=42, MODE=35,
+ 3 NEXTIV=46, NEXTV=47, NFCALL=6, NFCOV=52, NFGCAL=7,
+ 4 NGCALL=30, NGCOV=53, PERM=58, R=61, RCOND=53, RDREQ=57,
+ 5 RDRQSV=107, REGD=67, REGD0=82, RESTOR=9, TOOBIG=2,
+ 6 VNEED=4)
+ DATA MACHEP/-1.D+0/, NEGONE/-1.D+0/, SNGFAC/1.D+2/, ZERO/0.D+0/
+C
+C++++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++
+C
+C
+ IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
+ N1 = 1
+ NML = N
+ IV1 = IV(1)
+ IF (IV1 .LE. 2) GO TO 20
+C
+C *** CHECK INPUT INTEGERS ***
+C
+ IF (P .LE. 0) GO TO 370
+ IF (L .LT. 0) GO TO 370
+ IF (N .LE. L) GO TO 370
+ IF (LA .LT. N) GO TO 370
+ IF (IV1 .LT. 12) GO TO 20
+ IF (IV1 .EQ. 14) GO TO 20
+ IF (IV1 .EQ. 12) IV(1) = 13
+C
+C *** FRESH START -- COMPUTE STORAGE REQUIREMENTS ***
+C
+ IF (IV(1) .GT. 16) GO TO 370
+ LL1O2 = L*(L+1)/2
+ JLEN = N*P
+ I = L + P
+ IF (IV(RDREQ) .GT. 0 .AND. IV(COVREQ) .NE. 0) JLEN = I*(N + I + 1)
+ IF (IV(1) .NE. 13) GO TO 10
+ IV(IVNEED) = IV(IVNEED) + L
+ IV(VNEED) = IV(VNEED) + P + 2*N + JLEN + LL1O2 + L
+ 10 IF (IV(PERM) .LE. AR) IV(PERM) = AR + 1
+ CALL DRN2G(V, V, IV, LIV, LV, N, N, N1, NML, P, V, V, V, ALF)
+ IF (IV(1) .NE. 14) GO TO 999
+C
+C *** STORAGE ALLOCATION ***
+C
+ IV(IPIVS) = IV(NEXTIV)
+ IV(NEXTIV) = IV(NEXTIV) + L
+ IV(D) = IV(NEXTV)
+ IV(REGD0) = IV(D) + P
+ IV(AR) = IV(REGD0) + N
+ IV(CSAVE) = IV(AR) + LL1O2
+ IV(J) = IV(CSAVE) + L
+ IV(R) = IV(J) + JLEN
+ IV(NEXTV) = IV(R) + N
+ IV(IERS) = 0
+ IF (IV1 .EQ. 13) GO TO 999
+C
+C *** SET POINTERS INTO IV AND V ***
+C
+ 20 AR1 = IV(AR)
+ D1 = IV(D)
+ DR1 = IV(J)
+ DR1L = DR1 + L
+ R1 = IV(R)
+ R1L = R1 + L
+ RD1 = IV(REGD0)
+ CSAVE1 = IV(CSAVE)
+ NML = N - L
+ IF (IV1 .LE. 2) GO TO 50
+C
+C *** IF F.D. HESSIAN WILL BE NEEDED (FOR COVARIANCE OR REG.
+C *** DIAGNOSTICS), HAVE DRN2G COMPUTE ONLY THE PART CORRESP.
+C *** TO ALF WITH C FIXED...
+C
+ IF (L .LE. 0) GO TO 30
+ IV(CVRQSV) = IV(COVREQ)
+ IF (IABS(IV(COVREQ)) .GE. 3) IV(COVREQ) = 0
+ IV(RDRQSV) = IV(RDREQ)
+ IF (IV(RDREQ) .GT. 0) IV(RDREQ) = -1
+C
+ 30 N2 = NML
+ CALL DRN2G(V(D1), V(DR1L), IV, LIV, LV, NML, N, N1, N2, P,
+ 1 V(R1L), V(RD1), V, ALF)
+ IF (IABS(IV(RESTOR)-2) .EQ. 1 .AND. L .GT. 0)
+ 1 CALL DV7CPY(L, C, V(CSAVE1))
+ IV1 = IV(1)
+ IF (IV1 .EQ. 2) GO TO 150
+ IF (IV1 .GT. 2) GO TO 230
+C
+C *** NEW FUNCTION VALUE (RESIDUAL) NEEDED ***
+C
+ IV(IV1SAV) = IV(1)
+ IV(1) = IABS(IV1)
+ IF (IV(RESTOR) .EQ. 2 .AND. L .GT. 0) CALL DV7CPY(L, V(CSAVE1), C)
+ GO TO 999
+C
+C *** COMPUTE NEW RESIDUAL OR GRADIENT ***
+C
+ 50 IV(1) = IV(IV1SAV)
+ MD = IV(MODE)
+ IF (MD .LE. 0) GO TO 60
+ NML = N
+ DR1L = DR1
+ R1L = R1
+ 60 IF (IV(TOOBIG) .NE. 0) GO TO 30
+ IF (IABS(IV1) .EQ. 2) GO TO 170
+C
+C *** COMPUTE NEW RESIDUAL ***
+C
+ IF (L1 .LE. L) CALL DV7CPY(N, V(R1), Y)
+ IF (L1 .GT. L) CALL DV2AXY(N, V(R1), NEGONE, A(1,L1), Y)
+ IF (MD .GT. 0) GO TO 120
+ IER = 0
+ IF (L .LE. 0) GO TO 110
+ LL1O2 = L * (L + 1) / 2
+ IPIV1 = IV(IPIVS)
+ CALL DQ7RFH(IER, IV(IPIV1), N, LA, 0, L, A, V(AR1), LL1O2, C)
+C
+C *** DETERMINE NUMERICAL RANK OF A ***
+C
+ IF (MACHEP .LE. ZERO) MACHEP = DR7MDC(3)
+ SINGTL = SNGFAC * DBLE(MAX0(L,N)) * MACHEP
+ K = L
+ IF (IER .NE. 0) K = IER - 1
+ 70 IF (K .LE. 0) GO TO 90
+ T = DL7SVX(K, V(AR1), C, C)
+ IF (T .GT. ZERO) T = DL7SVN(K, V(AR1), C, C) / T
+ IF (T .GT. SINGTL) GO TO 80
+ K = K - 1
+ GO TO 70
+C
+C *** RECORD RANK IN IV(IERS)... IV(IERS) = 0 MEANS FULL RANK,
+C *** IV(IERS) .GT. 0 MEANS RANK IV(IERS) - 1.
+C
+ 80 IF (K .GE. L) GO TO 100
+ 90 IER = K + 1
+ CALL DV7SCP(L-K, C(K+1), ZERO)
+ 100 IV(IERS) = IER
+ IF (K .LE. 0) GO TO 110
+C
+C *** APPLY HOUSEHOLDER TRANSFORMATONS TO RESIDUALS...
+C
+ CALL DQ7APL(LA, N, K, A, V(R1), IER)
+C
+C *** COMPUTING C NOW MAY SAVE A FUNCTION EVALUATION AT
+C *** THE LAST ITERATION.
+C
+ CALL DL7ITV(K, C, V(AR1), V(R1))
+ CALL DV7PRM(L, IV(IPIV1), C)
+C
+ 110 IF(IV(1) .LT. 2) GO TO 220
+ GO TO 999
+C
+C
+C *** RESIDUAL COMPUTATION FOR F.D. HESSIAN ***
+C
+ 120 IF (L .LE. 0) GO TO 140
+ DO 130 I = 1, L
+ 130 CALL DV2AXY(N, V(R1), -C(I), A(1,I), V(R1))
+ 140 IF (IV(1) .GT. 0) GO TO 30
+ IV(1) = 2
+ GO TO 160
+C
+C *** NEW GRADIENT (JACOBIAN) NEEDED ***
+C
+ 150 IV(IV1SAV) = IV1
+ IF (IV(NFGCAL) .NE. IV(NFCALL)) IV(1) = 1
+ 160 CALL DV7SCP(N*P, V(DR1), ZERO)
+ GO TO 999
+C
+C *** COMPUTE NEW JACOBIAN ***
+C
+ 170 NOCOV = MD .LE. P .OR. IABS(IV(COVREQ)) .GE. 3
+ FDH0 = DR1 + N*(P+L)
+ IF (NDA .LE. 0) GO TO 370
+ DO 180 I = 1, NDA
+ I1 = IN(1,I) - 1
+ IF (I1 .LT. 0) GO TO 180
+ J1 = IN(2,I)
+ K = DR1 + I1*N
+ T = NEGONE
+ IF (J1 .LE. L) T = -C(J1)
+ CALL DV2AXY(N, V(K), T, DA(1,I), V(K))
+ IF (NOCOV) GO TO 180
+ IF (J1 .GT. L) GO TO 180
+C *** ADD IN (L,P) PORTION OF SECOND-ORDER PART OF HESSIAN
+C *** FOR COVARIANCE OR REG. DIAG. COMPUTATIONS...
+ J1 = J1 + P
+ K = FDH0 + J1*(J1-1)/2 + I1
+ V(K) = V(K) - DD7TPR(N, V(R1), DA(1,I))
+ 180 CONTINUE
+ IF (IV1 .EQ. 2) GO TO 190
+ IV(1) = IV1
+ GO TO 999
+ 190 IF (L .LE. 0) GO TO 30
+ IF (MD .GT. P) GO TO 240
+ IF (MD .GT. 0) GO TO 30
+ K = DR1
+ IER = IV(IERS)
+ NRAN = L
+ IF (IER .GT. 0) NRAN = IER - 1
+ IF (NRAN .LE. 0) GO TO 210
+ DO 200 I = 1, P
+ CALL DQ7APL(LA, N, NRAN, A, V(K), IER)
+ K = K + N
+ 200 CONTINUE
+ 210 CALL DV7CPY(L, V(CSAVE1), C)
+ 220 IF (IER .EQ. 0) GO TO 30
+C
+C *** ADJUST SUBSCRIPTS DESCRIBING R AND DR...
+C
+ NRAN = IER - 1
+ DR1L = DR1 + NRAN
+ NML = N - NRAN
+ R1L = R1 + NRAN
+ GO TO 30
+C
+C *** CONVERGENCE OR LIMIT REACHED ***
+C
+ 230 IF (L .LE. 0) GO TO 350
+ IV(COVREQ) = IV(CVRQSV)
+ IV(RDREQ) = IV(RDRQSV)
+ IF (IV(1) .GT. 6) GO TO 360
+ IF (MOD(IV(RDREQ),4) .EQ. 0) GO TO 360
+ IF (IV(FDH) .LE. 0 .AND. IABS(IV(COVREQ)) .LT. 3) GO TO 360
+ IF (IV(REGD) .GT. 0) GO TO 360
+ IF (IV(COVMAT) .GT. 0) GO TO 360
+C
+C *** PREPARE TO FINISH COMPUTING COVARIANCE MATRIX AND REG. DIAG. ***
+C
+ PP = L + P
+ I = 0
+ IF (MOD(IV(RDREQ),4) .GE. 2) I = 1
+ IF (MOD(IV(RDREQ),2) .EQ. 1 .AND. IABS(IV(COVREQ)) .EQ. 1) I = I+2
+ IV(MODE) = PP + I
+ I = DR1 + N*PP
+ K = P * (P + 1) / 2
+ I1 = IV(LMAT)
+ CALL DV7CPY(K, V(I), V(I1))
+ I = I + K
+ CALL DV7SCP(PP*(PP+1)/2 - K, V(I), ZERO)
+ IV(NFCOV) = IV(NFCOV) + 1
+ IV(NFCALL) = IV(NFCALL) + 1
+ IV(NFGCAL) = IV(NFCALL)
+ IV(CNVCOD) = IV(1)
+ IV(IV1SAV) = -1
+ IV(1) = 1
+ IV(NGCALL) = IV(NGCALL) + 1
+ IV(NGCOV) = IV(NGCOV) + 1
+ GO TO 999
+C
+C *** FINISH COVARIANCE COMPUTATION ***
+C
+ 240 I = DR1 + N*P
+ DO 250 I1 = 1, L
+ CALL DV7SCL(N, V(I), NEGONE, A(1,I1))
+ I = I + N
+ 250 CONTINUE
+ PP = L + P
+ HSAVE = IV(H)
+ K = DR1 + N*PP
+ LH = PP * (PP + 1) / 2
+ IF (IABS(IV(COVREQ)) .LT. 3) GO TO 270
+ I = IV(MODE) - 4
+ IF (I .GE. PP) GO TO 260
+ CALL DV7SCP(LH, V(K), ZERO)
+ CALL DQ7RAD(N, N, PP, V, .FALSE., V(K), V(DR1), V)
+ IV(MODE) = I + 8
+ IV(1) = 2
+ IV(NGCALL) = IV(NGCALL) + 1
+ IV(NGCOV) = IV(NGCOV) + 1
+ GO TO 160
+C
+ 260 IV(MODE) = I
+ GO TO 300
+C
+ 270 PP1 = P + 1
+ DRI = DR1 + N*P
+ LI = K + P*PP1/2
+ DO 290 I = PP1, PP
+ DRI1 = DR1
+ DO 280 I1 = 1, I
+ V(LI) = V(LI) + DD7TPR(N, V(DRI), V(DRI1))
+ LI = LI + 1
+ DRI1 = DRI1 + N
+ 280 CONTINUE
+ DRI = DRI + N
+ 290 CONTINUE
+ CALL DL7SRT(PP1, PP, V(K), V(K), I)
+ IF (I .NE. 0) GO TO 310
+ 300 TEMP1 = K + LH
+ T = DL7SVN(PP, V(K), V(TEMP1), V(TEMP1))
+ IF (T .LE. ZERO) GO TO 310
+ T = T / DL7SVX(PP, V(K), V(TEMP1), V(TEMP1))
+ V(RCOND) = T
+ IF (T .GT. DR7MDC(4)) GO TO 320
+ 310 IV(REGD) = -1
+ IV(COVMAT) = -1
+ IV(FDH) = -1
+ GO TO 340
+ 320 IV(H) = TEMP1
+ IV(FDH) = IABS(HSAVE)
+ IF (IV(MODE) - PP .LT. 2) GO TO 330
+ I = IV(H)
+ CALL DV7SCP(LH, V(I), ZERO)
+ 330 CALL DN2LRD(V(DR1), IV, V(K), LH, LIV, LV, N, N, PP, V(R1),
+ 1 V(RD1), V)
+ 340 CALL DC7VFN(IV, V(K), LH, LIV, LV, N, PP, V)
+ IV(H) = HSAVE
+C
+ 350 IF (IV(REGD) .EQ. 1) IV(REGD) = RD1
+ 360 IF (IV(1) .LE. 11) CALL DS7CPR(C, IV, L, LIV)
+ IF (IV(1) .GT. 6) GO TO 999
+ CALL DN2CVP(IV, LIV, LV, P+L, V)
+ CALL DN2RDP(IV, LIV, LV, N, V(RD1), V)
+ GO TO 999
+C
+ 370 IV(1) = 66
+ CALL DITSUM(V, V, IV, LIV, LV, P, V, ALF)
+C
+ 999 RETURN
+C
+C *** LAST CARD OF DRNSG FOLLOWS ***
+ END
+ SUBROUTINE DL7TVM(N, X, L, Y)
+C
+C *** COMPUTE X = (L**T)*Y, WHERE L IS AN N X N LOWER
+C *** TRIANGULAR MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY
+C *** OCCUPY THE SAME STORAGE. ***
+C
+ INTEGER N
+ DOUBLE PRECISION X(N), L(*), Y(N)
+C DIMENSION L(N*(N+1)/2)
+ INTEGER I, IJ, I0, J
+ DOUBLE PRECISION YI, ZERO
+ PARAMETER (ZERO=0.D+0)
+C
+ I0 = 0
+ DO 20 I = 1, N
+ YI = Y(I)
+ X(I) = ZERO
+ DO 10 J = 1, I
+ IJ = I0 + J
+ X(J) = X(J) + YI*L(IJ)
+ 10 CONTINUE
+ I0 = I0 + I
+ 20 CONTINUE
+ RETURN
+C *** LAST CARD OF DL7TVM FOLLOWS ***
+ END
+ SUBROUTINE DL7ITV(N, X, L, Y)
+C
+C *** SOLVE (L**T)*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR
+C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME
+C *** STORAGE. ***
+C
+ INTEGER N
+ DOUBLE PRECISION X(N), L(*), Y(N)
+ INTEGER I, II, IJ, IM1, I0, J, NP1
+ DOUBLE PRECISION XI, ZERO
+ PARAMETER (ZERO=0.D+0)
+C
+ DO 10 I = 1, N
+ 10 X(I) = Y(I)
+ NP1 = N + 1
+ I0 = N*(N+1)/2
+ DO 30 II = 1, N
+ I = NP1 - II
+ XI = X(I)/L(I0)
+ X(I) = XI
+ IF (I .LE. 1) GO TO 999
+ I0 = I0 - I
+ IF (XI .EQ. ZERO) GO TO 30
+ IM1 = I - 1
+ DO 20 J = 1, IM1
+ IJ = I0 + J
+ X(J) = X(J) - XI*L(IJ)
+ 20 CONTINUE
+ 30 CONTINUE
+ 999 RETURN
+C *** LAST CARD OF DL7ITV FOLLOWS ***
+ END
+ SUBROUTINE DRMNGB(B, D, FX, G, IV, LIV, LV, N, V, X)
+C
+C *** CARRY OUT DMNGB (SIMPLY BOUNDED MINIMIZATION) ITERATIONS,
+C *** USING DOUBLE-DOGLEG/BFGS STEPS.
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER LIV, LV, N
+ INTEGER IV(LIV)
+ DOUBLE PRECISION B(2,N), D(N), FX, G(N), V(LV), X(N)
+C
+C-------------------------- PARAMETER USAGE --------------------------
+C
+C B.... VECTOR OF LOWER AND UPPER BOUNDS ON X.
+C D.... SCALE VECTOR.
+C FX... FUNCTION VALUE.
+C G.... GRADIENT VECTOR.
+C IV... INTEGER VALUE ARRAY.
+C LIV.. LENGTH OF IV (AT LEAST 59) + N.
+C LV... LENGTH OF V (AT LEAST 71 + N*(N+19)/2).
+C N.... NUMBER OF VARIABLES (COMPONENTS IN X AND G).
+C V.... FLOATING-POINT VALUE ARRAY.
+C X.... VECTOR OF PARAMETERS TO BE OPTIMIZED.
+C
+C *** DISCUSSION ***
+C
+C PARAMETERS IV, N, V, AND X ARE THE SAME AS THE CORRESPONDING
+C ONES TO DMNGB (WHICH SEE), EXCEPT THAT V CAN BE SHORTER (SINCE
+C THE PART OF V THAT DMNGB USES FOR STORING G IS NOT NEEDED).
+C MOREOVER, COMPARED WITH DMNGB, IV(1) MAY HAVE THE TWO ADDITIONAL
+C OUTPUT VALUES 1 AND 2, WHICH ARE EXPLAINED BELOW, AS IS THE USE
+C OF IV(TOOBIG) AND IV(NFGCAL). THE VALUE IV(G), WHICH IS AN
+C OUTPUT VALUE FROM DMNGB (AND SMSNOB), IS NOT REFERENCED BY
+C DRMNGB OR THE SUBROUTINES IT CALLS.
+C FX AND G NEED NOT HAVE BEEN INITIALIZED WHEN DRMNGB IS CALLED
+C WITH IV(1) = 12, 13, OR 14.
+C
+C IV(1) = 1 MEANS THE CALLER SHOULD SET FX TO F(X), THE FUNCTION VALUE
+C AT X, AND CALL DRMNGB AGAIN, HAVING CHANGED NONE OF THE
+C OTHER PARAMETERS. AN EXCEPTION OCCURS IF F(X) CANNOT BE
+C (E.G. IF OVERFLOW WOULD OCCUR), WHICH MAY HAPPEN BECAUSE
+C OF AN OVERSIZED STEP. IN THIS CASE THE CALLER SHOULD SET
+C IV(TOOBIG) = IV(2) TO 1, WHICH WILL CAUSE DRMNGB TO IG-
+C NORE FX AND TRY A SMALLER STEP. THE PARAMETER NF THAT
+C DMNGB PASSES TO CALCF (FOR POSSIBLE USE BY CALCG) IS A
+C COPY OF IV(NFCALL) = IV(6).
+C IV(1) = 2 MEANS THE CALLER SHOULD SET G TO G(X), THE GRADIENT VECTOR
+C OF F AT X, AND CALL DRMNGB AGAIN, HAVING CHANGED NONE OF
+C THE OTHER PARAMETERS EXCEPT POSSIBLY THE SCALE VECTOR D
+C WHEN IV(DTYPE) = 0. THE PARAMETER NF THAT DMNGB PASSES
+C TO CALCG IS IV(NFGCAL) = IV(7). IF G(X) CANNOT BE
+C EVALUATED, THEN THE CALLER MAY SET IV(NFGCAL) TO 0, IN
+C WHICH CASE DRMNGB WILL RETURN WITH IV(1) = 65.
+C.
+C *** GENERAL ***
+C
+C CODED BY DAVID M. GAY (DECEMBER 1979). REVISED SEPT. 1982.
+C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
+C IN PART BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
+C MCS-7600324 AND MCS-7906671.
+C
+C (SEE DMNG FOR REFERENCES.)
+C
+C+++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++++
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER DG1, DSTEP1, DUMMY, G01, I, I1, IPI, IPN, J, K, L, LSTGST,
+ 1 N1, NP1, NWTST1, RSTRST, STEP1, TEMP0, TEMP1, TD1, TG1,
+ 2 W1, X01, Z
+ DOUBLE PRECISION GI, T, XI
+C
+C *** CONSTANTS ***
+C
+ DOUBLE PRECISION NEGONE, ONE, ONEP2, ZERO
+C
+C *** NO INTRINSIC FUNCTIONS ***
+C
+C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
+C
+ LOGICAL STOPX
+ DOUBLE PRECISION DD7TPR, DRLDST, DV2NRM
+ EXTERNAL DA7SST, DD7DGB,DIVSET, DD7TPR, I7SHFT,DITSUM, DL7TVM,
+ 1 DL7UPD,DL7VML,DPARCK, DQ7RSH, DRLDST, STOPX, DV2NRM,
+ 2 DV2AXY,DV7CPY, DV7IPR, DV7SCP, DV7VMP, DW7ZBF
+C
+C DA7SST.... ASSESSES CANDIDATE STEP.
+C DD7DGB... COMPUTES SIMPLY BOUNDED DOUBLE-DOGLEG (CANDIDATE) STEP.
+C DIVSET.... SUPPLIES DEFAULT IV AND V INPUT COMPONENTS.
+C DD7TPR... RETURNS INNER PRODUCT OF TWO VECTORS.
+C I7SHFT... CYCLICALLLY SHIFTS AN ARRAY OF INTEGERS.
+C DITSUM.... PRINTS ITERATION SUMMARY AND INFO ON INITIAL AND FINAL X.
+C DL7TVM... MULTIPLIES TRANSPOSE OF LOWER TRIANGLE TIMES VECTOR.
+C LUPDT.... UPDATES CHOLESKY FACTOR OF HESSIAN APPROXIMATION.
+C DL7VML.... MULTIPLIES LOWER TRIANGLE TIMES VECTOR.
+C DPARCK.... CHECKS VALIDITY OF INPUT IV AND V VALUES.
+C DQ7RSH... CYCLICALLY SHIFTS CHOLESKY FACTOR.
+C DRLDST... COMPUTES V(RELDX) = RELATIVE STEP SIZE.
+C STOPX.... RETURNS .TRUE. IF THE BREAK KEY HAS BEEN PRESSED.
+C DV2NRM... RETURNS THE 2-NORM OF A VECTOR.
+C DV2AXY.... COMPUTES SCALAR TIMES ONE VECTOR PLUS ANOTHER.
+C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
+C DV7IPR... CYCLICALLY SHIFTS A FLOATING-POINT ARRAY.
+C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
+C DV7VMP... MULTIPLIES VECTOR BY VECTOR RAISED TO POWER (COMPONENTWISE).
+C DW7ZBF... COMPUTES W AND Z FOR DL7UPD CORRESPONDING TO BFGS UPDATE.
+C
+C *** SUBSCRIPTS FOR IV AND V ***
+C
+ INTEGER CNVCOD, DG, DGNORM, DINIT, DSTNRM, F, F0, FDIF,
+ 1 GTSTEP, INCFAC, INITH, IRC, IVNEED, KAGQT, LMAT,
+ 2 LMAX0, LMAXS, MODE, MODEL, MXFCAL, MXITER, NC, NEXTIV,
+ 3 NEXTV, NFCALL, NFGCAL, NGCALL, NITER, NWTSTP, PERM,
+ 4 PREDUC, RADFAC, RADINC, RADIUS, RAD0, RELDX, RESTOR, STEP,
+ 4 STGLIM, STLSTG, TOOBIG, TUNER4, TUNER5, VNEED, XIRC, X0
+C
+C *** IV SUBSCRIPT VALUES ***
+C
+C *** (NOTE THAT NC IS STORED IN IV(G0)) ***
+C
+ PARAMETER (CNVCOD=55, DG=37, INITH=25, IRC=29, IVNEED=3, KAGQT=33,
+ 1 MODE=35, MODEL=5, MXFCAL=17, MXITER=18, NC=48,
+ 2 NEXTIV=46, NEXTV=47, NFCALL=6, NFGCAL=7, NGCALL=30,
+ 3 NITER=31, NWTSTP=34, PERM=58, RADINC=8, RESTOR=9,
+ 4 STEP=40, STGLIM=11, STLSTG=41, TOOBIG=2, XIRC=13,
+ 5 X0=43)
+C
+C *** V SUBSCRIPT VALUES ***
+C
+ PARAMETER (DGNORM=1, DINIT=38, DSTNRM=2, F=10, F0=13, FDIF=11,
+ 1 GTSTEP=4, INCFAC=23, LMAT=42, LMAX0=35, LMAXS=36,
+ 2 PREDUC=7, RADFAC=16, RADIUS=8, RAD0=9, RELDX=17,
+ 3 TUNER4=29, TUNER5=30, VNEED=4)
+C
+ PARAMETER (NEGONE=-1.D+0, ONE=1.D+0, ONEP2=1.2D+0, ZERO=0.D+0)
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ I = IV(1)
+ IF (I .EQ. 1) GO TO 70
+ IF (I .EQ. 2) GO TO 80
+C
+C *** CHECK VALIDITY OF IV AND V INPUT VALUES ***
+C
+ IF (IV(1) .EQ. 0) CALL DIVSET(2, IV, LIV, LV, V)
+ IF (IV(1) .LT. 12) GO TO 10
+ IF (IV(1) .GT. 13) GO TO 10
+ IV(VNEED) = IV(VNEED) + N*(N+19)/2
+ IV(IVNEED) = IV(IVNEED) + N
+ 10 CALL DPARCK(2, D, IV, LIV, LV, N, V)
+ I = IV(1) - 2
+ IF (I .GT. 12) GO TO 999
+ GO TO (250, 250, 250, 250, 250, 250, 190, 150, 190, 20, 20, 30), I
+C
+C *** STORAGE ALLOCATION ***
+C
+ 20 L = IV(LMAT)
+ IV(X0) = L + N*(N+1)/2
+ IV(STEP) = IV(X0) + 2*N
+ IV(STLSTG) = IV(STEP) + 2*N
+ IV(NWTSTP) = IV(STLSTG) + N
+ IV(DG) = IV(NWTSTP) + 2*N
+ IV(NEXTV) = IV(DG) + 2*N
+ IV(NEXTIV) = IV(PERM) + N
+ IF (IV(1) .NE. 13) GO TO 30
+ IV(1) = 14
+ GO TO 999
+C
+C *** INITIALIZATION ***
+C
+ 30 IV(NITER) = 0
+ IV(NFCALL) = 1
+ IV(NGCALL) = 1
+ IV(NFGCAL) = 1
+ IV(MODE) = -1
+ IV(MODEL) = 1
+ IV(STGLIM) = 1
+ IV(TOOBIG) = 0
+ IV(CNVCOD) = 0
+ IV(RADINC) = 0
+ IV(NC) = N
+ V(RAD0) = ZERO
+C
+C *** CHECK CONSISTENCY OF B AND INITIALIZE IP ARRAY ***
+C
+ IPI = IV(PERM)
+ DO 40 I = 1, N
+ IV(IPI) = I
+ IPI = IPI + 1
+ IF (B(1,I) .GT. B(2,I)) GO TO 410
+ 40 CONTINUE
+C
+ IF (V(DINIT) .GE. ZERO) CALL DV7SCP(N, D, V(DINIT))
+ IF (IV(INITH) .NE. 1) GO TO 60
+C
+C *** SET THE INITIAL HESSIAN APPROXIMATION TO DIAG(D)**-2 ***
+C
+ L = IV(LMAT)
+ CALL DV7SCP(N*(N+1)/2, V(L), ZERO)
+ K = L - 1
+ DO 50 I = 1, N
+ K = K + I
+ T = D(I)
+ IF (T .LE. ZERO) T = ONE
+ V(K) = T
+ 50 CONTINUE
+C
+C *** GET INITIAL FUNCTION VALUE ***
+C
+ 60 IV(1) = 1
+ GO TO 440
+C
+ 70 V(F) = FX
+ IF (IV(MODE) .GE. 0) GO TO 250
+ V(F0) = FX
+ IV(1) = 2
+ IF (IV(TOOBIG) .EQ. 0) GO TO 999
+ IV(1) = 63
+ GO TO 430
+C
+C *** MAKE SURE GRADIENT COULD BE COMPUTED ***
+C
+ 80 IF (IV(TOOBIG) .EQ. 0) GO TO 90
+ IV(1) = 65
+ GO TO 430
+C
+C *** CHOOSE INITIAL PERMUTATION ***
+C
+ 90 IPI = IV(PERM)
+ IPN = IPI + N
+ N1 = N
+ NP1 = N + 1
+ L = IV(LMAT)
+ W1 = IV(NWTSTP) + N
+ K = N - IV(NC)
+ DO 120 I = 1, N
+ IPN = IPN - 1
+ J = IV(IPN)
+ IF (B(1,J) .GE. B(2,J)) GO TO 100
+ XI = X(J)
+ GI = G(J)
+ IF (XI .LE. B(1,J) .AND. GI .GT. ZERO) GO TO 100
+ IF (XI .GE. B(2,J) .AND. GI .LT. ZERO) GO TO 100
+C *** DISALLOW CONVERGENCE IF X(J) HAS JUST BEEN FREED ***
+ IF (I .LE. K) IV(CNVCOD) = 0
+ GO TO 120
+ 100 I1 = NP1 - I
+ IF (I1 .GE. N1) GO TO 110
+ CALL I7SHFT(N1, I1, IV(IPI))
+ CALL DQ7RSH(I1, N1, .FALSE., G, V(L), V(W1))
+ 110 N1 = N1 - 1
+ 120 CONTINUE
+C
+ IV(NC) = N1
+ V(DGNORM) = ZERO
+ IF (N1 .LE. 0) GO TO 130
+ DG1 = IV(DG)
+ CALL DV7VMP(N, V(DG1), G, D, -1)
+ CALL DV7IPR(N, IV(IPI), V(DG1))
+ V(DGNORM) = DV2NRM(N1, V(DG1))
+ 130 IF (IV(CNVCOD) .NE. 0) GO TO 420
+ IF (IV(MODE) .EQ. 0) GO TO 370
+C
+C *** ALLOW FIRST STEP TO HAVE SCALED 2-NORM AT MOST V(LMAX0) ***
+C
+ V(RADIUS) = V(LMAX0)
+C
+ IV(MODE) = 0
+C
+C
+C----------------------------- MAIN LOOP -----------------------------
+C
+C
+C *** PRINT ITERATION SUMMARY, CHECK ITERATION LIMIT ***
+C
+ 140 CALL DITSUM(D, G, IV, LIV, LV, N, V, X)
+ 150 K = IV(NITER)
+ IF (K .LT. IV(MXITER)) GO TO 160
+ IV(1) = 10
+ GO TO 430
+C
+C *** UPDATE RADIUS ***
+C
+ 160 IV(NITER) = K + 1
+ IF (K .EQ. 0) GO TO 170
+ T = V(RADFAC) * V(DSTNRM)
+ IF (V(RADFAC) .LT. ONE .OR. T .GT. V(RADIUS)) V(RADIUS) = T
+C
+C *** INITIALIZE FOR START OF NEXT ITERATION ***
+C
+ 170 X01 = IV(X0)
+ V(F0) = V(F)
+ IV(IRC) = 4
+ IV(KAGQT) = -1
+C
+C *** COPY X TO X0 ***
+C
+ CALL DV7CPY(N, V(X01), X)
+C
+C *** CHECK STOPX AND FUNCTION EVALUATION LIMIT ***
+C
+ 180 IF (.NOT. STOPX(DUMMY)) GO TO 200
+ IV(1) = 11
+ GO TO 210
+C
+C *** COME HERE WHEN RESTARTING AFTER FUNC. EVAL. LIMIT OR STOPX.
+C
+ 190 IF (V(F) .GE. V(F0)) GO TO 200
+ V(RADFAC) = ONE
+ K = IV(NITER)
+ GO TO 160
+C
+ 200 IF (IV(NFCALL) .LT. IV(MXFCAL)) GO TO 220
+ IV(1) = 9
+ 210 IF (V(F) .GE. V(F0)) GO TO 430
+C
+C *** IN CASE OF STOPX OR FUNCTION EVALUATION LIMIT WITH
+C *** IMPROVED V(F), EVALUATE THE GRADIENT AT X.
+C
+ IV(CNVCOD) = IV(1)
+ GO TO 360
+C
+C. . . . . . . . . . . . . COMPUTE CANDIDATE STEP . . . . . . . . . .
+C
+ 220 STEP1 = IV(STEP)
+ DG1 = IV(DG)
+ NWTST1 = IV(NWTSTP)
+ W1 = NWTST1 + N
+ DSTEP1 = STEP1 + N
+ IPI = IV(PERM)
+ L = IV(LMAT)
+ TG1 = DG1 + N
+ X01 = IV(X0)
+ TD1 = X01 + N
+ CALL DD7DGB(B, D, V(DG1), V(DSTEP1), G, IV(IPI), IV(KAGQT),
+ 1 V(L), LV, N, IV(NC), V(NWTST1), V(STEP1), V(TD1),
+ 2 V(TG1), V, V(W1), V(X01))
+ IF (IV(IRC) .NE. 6) GO TO 230
+ IF (IV(RESTOR) .NE. 2) GO TO 250
+ RSTRST = 2
+ GO TO 260
+C
+C *** CHECK WHETHER EVALUATING F(X0 + STEP) LOOKS WORTHWHILE ***
+C
+ 230 IV(TOOBIG) = 0
+ IF (V(DSTNRM) .LE. ZERO) GO TO 250
+ IF (IV(IRC) .NE. 5) GO TO 240
+ IF (V(RADFAC) .LE. ONE) GO TO 240
+ IF (V(PREDUC) .GT. ONEP2 * V(FDIF)) GO TO 240
+ IF (IV(RESTOR) .NE. 2) GO TO 250
+ RSTRST = 0
+ GO TO 260
+C
+C *** COMPUTE F(X0 + STEP) ***
+C
+ 240 CALL DV2AXY(N, X, ONE, V(STEP1), V(X01))
+ IV(NFCALL) = IV(NFCALL) + 1
+ IV(1) = 1
+ GO TO 440
+C
+C. . . . . . . . . . . . . ASSESS CANDIDATE STEP . . . . . . . . . . .
+C
+ 250 RSTRST = 3
+ 260 X01 = IV(X0)
+ V(RELDX) = DRLDST(N, D, X, V(X01))
+ CALL DA7SST(IV, LIV, LV, V)
+ STEP1 = IV(STEP)
+ LSTGST = IV(STLSTG)
+ I = IV(RESTOR) + 1
+ GO TO (300, 270, 280, 290), I
+ 270 CALL DV7CPY(N, X, V(X01))
+ GO TO 300
+ 280 CALL DV7CPY(N, V(LSTGST), X)
+ GO TO 300
+ 290 CALL DV7CPY(N, X, V(LSTGST))
+ CALL DV2AXY(N, V(STEP1), NEGONE, V(X01), X)
+ V(RELDX) = DRLDST(N, D, X, V(X01))
+ IV(RESTOR) = RSTRST
+C
+ 300 K = IV(IRC)
+ GO TO (310,340,340,340,310,320,330,330,330,330,330,330,400,370), K
+C
+C *** RECOMPUTE STEP WITH CHANGED RADIUS ***
+C
+ 310 V(RADIUS) = V(RADFAC) * V(DSTNRM)
+ GO TO 180
+C
+C *** COMPUTE STEP OF LENGTH V(LMAXS) FOR SINGULAR CONVERGENCE TEST.
+C
+ 320 V(RADIUS) = V(LMAXS)
+ GO TO 220
+C
+C *** CONVERGENCE OR FALSE CONVERGENCE ***
+C
+ 330 IV(CNVCOD) = K - 4
+ IF (V(F) .GE. V(F0)) GO TO 420
+ IF (IV(XIRC) .EQ. 14) GO TO 420
+ IV(XIRC) = 14
+C
+C. . . . . . . . . . . . PROCESS ACCEPTABLE STEP . . . . . . . . . . .
+C
+ 340 X01 = IV(X0)
+ STEP1 = IV(STEP)
+ CALL DV2AXY(N, V(STEP1), NEGONE, V(X01), X)
+ IF (IV(IRC) .NE. 3) GO TO 360
+C
+C *** SET TEMP1 = HESSIAN * STEP FOR USE IN GRADIENT TESTS ***
+C
+C *** USE X0 AS TEMPORARY...
+C
+ IPI = IV(PERM)
+ CALL DV7CPY(N, V(X01), V(STEP1))
+ CALL DV7IPR(N, IV(IPI), V(X01))
+ L = IV(LMAT)
+ CALL DL7TVM(N, V(X01), V(L), V(X01))
+ CALL DL7VML(N, V(X01), V(L), V(X01))
+C
+C *** UNPERMUTE X0 INTO TEMP1 ***
+C
+ TEMP1 = IV(STLSTG)
+ TEMP0 = TEMP1 - 1
+ DO 350 I = 1, N
+ J = IV(IPI)
+ IPI = IPI + 1
+ K = TEMP0 + J
+ V(K) = V(X01)
+ X01 = X01 + 1
+ 350 CONTINUE
+C
+C *** SAVE OLD GRADIENT, COMPUTE NEW ONE ***
+C
+ 360 G01 = IV(NWTSTP) + N
+ CALL DV7CPY(N, V(G01), G)
+ IV(NGCALL) = IV(NGCALL) + 1
+ IV(TOOBIG) = 0
+ IV(1) = 2
+ GO TO 999
+C
+C *** INITIALIZATIONS -- G0 = G - G0, ETC. ***
+C
+ 370 G01 = IV(NWTSTP) + N
+ CALL DV2AXY(N, V(G01), NEGONE, V(G01), G)
+ STEP1 = IV(STEP)
+ TEMP1 = IV(STLSTG)
+ IF (IV(IRC) .NE. 3) GO TO 390
+C
+C *** SET V(RADFAC) BY GRADIENT TESTS ***
+C
+C *** SET TEMP1 = DIAG(D)**-1 * (HESSIAN*STEP + (G(X0)-G(X))) ***
+C
+ CALL DV2AXY(N, V(TEMP1), NEGONE, V(G01), V(TEMP1))
+ CALL DV7VMP(N, V(TEMP1), V(TEMP1), D, -1)
+C
+C *** DO GRADIENT TESTS ***
+C
+ IF (DV2NRM(N, V(TEMP1)) .LE. V(DGNORM) * V(TUNER4))
+ 1 GO TO 380
+ IF (DD7TPR(N, G, V(STEP1))
+ 1 .GE. V(GTSTEP) * V(TUNER5)) GO TO 390
+ 380 V(RADFAC) = V(INCFAC)
+C
+C *** UPDATE H, LOOP ***
+C
+ 390 W1 = IV(NWTSTP)
+ Z = IV(X0)
+ L = IV(LMAT)
+ IPI = IV(PERM)
+ CALL DV7IPR(N, IV(IPI), V(STEP1))
+ CALL DV7IPR(N, IV(IPI), V(G01))
+ CALL DW7ZBF(V(L), N, V(STEP1), V(W1), V(G01), V(Z))
+C
+C ** USE THE N-VECTORS STARTING AT V(STEP1) AND V(G01) FOR SCRATCH..
+ CALL DL7UPD(V(TEMP1), V(STEP1), V(L), V(G01), V(L), N, V(W1),
+ 1 V(Z))
+ IV(1) = 2
+ GO TO 140
+C
+C. . . . . . . . . . . . . . MISC. DETAILS . . . . . . . . . . . . . .
+C
+C *** BAD PARAMETERS TO ASSESS ***
+C
+ 400 IV(1) = 64
+ GO TO 430
+C
+C *** INCONSISTENT B ***
+C
+ 410 IV(1) = 82
+ GO TO 430
+C
+C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
+C
+ 420 IV(1) = IV(CNVCOD)
+ IV(CNVCOD) = 0
+ 430 CALL DITSUM(D, G, IV, LIV, LV, N, V, X)
+ GO TO 999
+C
+C *** PROJECT X INTO FEASIBLE REGION (PRIOR TO COMPUTING F OR G) ***
+C
+ 440 DO 450 I = 1, N
+ IF (X(I) .LT. B(1,I)) X(I) = B(1,I)
+ IF (X(I) .GT. B(2,I)) X(I) = B(2,I)
+ 450 CONTINUE
+C
+ 999 RETURN
+C
+C *** LAST CARD OF DRMNGB FOLLOWS ***
+ END
+ SUBROUTINE DS7GRD (ALPHA, D, ETA0, FX, G, IRC, N, W, X)
+C
+C *** COMPUTE FINITE DIFFERENCE GRADIENT BY STWEART*S SCHEME ***
+C
+C *** PARAMETERS ***
+C
+ INTEGER IRC, N
+ DOUBLE PRECISION ALPHA(N), D(N), ETA0, FX, G(N), W(6), X(N)
+C
+C.......................................................................
+C
+C *** PURPOSE ***
+C
+C THIS SUBROUTINE USES AN EMBELLISHED FORM OF THE FINITE-DIFFER-
+C ENCE SCHEME PROPOSED BY STEWART (REF. 1) TO APPROXIMATE THE
+C GRADIENT OF THE FUNCTION F(X), WHOSE VALUES ARE SUPPLIED BY
+C REVERSE COMMUNICATION.
+C
+C *** PARAMETER DESCRIPTION ***
+C
+C ALPHA IN (APPROXIMATE) DIAGONAL ELEMENTS OF THE HESSIAN OF F(X).
+C D IN SCALE VECTOR SUCH THAT D(I)*X(I), I = 1,...,N, ARE IN
+C COMPARABLE UNITS.
+C ETA0 IN ESTIMATED BOUND ON RELATIVE ERROR IN THE FUNCTION VALUE...
+C (TRUE VALUE) = (COMPUTED VALUE)*(1+E), WHERE
+C ABS(E) .LE. ETA0.
+C FX I/O ON INPUT, FX MUST BE THE COMPUTED VALUE OF F(X). ON
+C OUTPUT WITH IRC = 0, FX HAS BEEN RESTORED TO ITS ORIGINAL
+C VALUE, THE ONE IT HAD WHEN DS7GRD WAS LAST CALLED WITH
+C IRC = 0.
+C G I/O ON INPUT WITH IRC = 0, G SHOULD CONTAIN AN APPROXIMATION
+C TO THE GRADIENT OF F NEAR X, E.G., THE GRADIENT AT THE
+C PREVIOUS ITERATE. WHEN DS7GRD RETURNS WITH IRC = 0, G IS
+C THE DESIRED FINITE-DIFFERENCE APPROXIMATION TO THE
+C GRADIENT AT X.
+C IRC I/O INPUT/RETURN CODE... BEFORE THE VERY FIRST CALL ON DS7GRD,
+C THE CALLER MUST SET IRC TO 0. WHENEVER DS7GRD RETURNS A
+C NONZERO VALUE FOR IRC, IT HAS PERTURBED SOME COMPONENT OF
+C X... THE CALLER SHOULD EVALUATE F(X) AND CALL DS7GRD
+C AGAIN WITH FX = F(X).
+C N IN THE NUMBER OF VARIABLES (COMPONENTS OF X) ON WHICH F
+C DEPENDS.
+C X I/O ON INPUT WITH IRC = 0, X IS THE POINT AT WHICH THE
+C GRADIENT OF F IS DESIRED. ON OUTPUT WITH IRC NONZERO, X
+C IS THE POINT AT WHICH F SHOULD BE EVALUATED. ON OUTPUT
+C WITH IRC = 0, X HAS BEEN RESTORED TO ITS ORIGINAL VALUE
+C (THE ONE IT HAD WHEN DS7GRD WAS LAST CALLED WITH IRC = 0)
+C AND G CONTAINS THE DESIRED GRADIENT APPROXIMATION.
+C W I/O WORK VECTOR OF LENGTH 6 IN WHICH DS7GRD SAVES CERTAIN
+C QUANTITIES WHILE THE CALLER IS EVALUATING F(X) AT A
+C PERTURBED X.
+C
+C *** APPLICATION AND USAGE RESTRICTIONS ***
+C
+C THIS ROUTINE IS INTENDED FOR USE WITH QUASI-NEWTON ROUTINES
+C FOR UNCONSTRAINED MINIMIZATION (IN WHICH CASE ALPHA COMES FROM
+C THE DIAGONAL OF THE QUASI-NEWTON HESSIAN APPROXIMATION).
+C
+C *** ALGORITHM NOTES ***
+C
+C THIS CODE DEPARTS FROM THE SCHEME PROPOSED BY STEWART (REF. 1)
+C IN ITS GUARDING AGAINST OVERLY LARGE OR SMALL STEP SIZES AND ITS
+C HANDLING OF SPECIAL CASES (SUCH AS ZERO COMPONENTS OF ALPHA OR G).
+C
+C *** REFERENCES ***
+C
+C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
+C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
+C J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
+C
+C *** HISTORY ***
+C
+C DESIGNED AND CODED BY DAVID M. GAY (SUMMER 1977/SUMMER 1980).
+C
+C *** GENERAL ***
+C
+C THIS ROUTINE WAS PREPARED IN CONNECTION WITH WORK SUPPORTED BY
+C THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS76-00324 AND
+C MCS-7906671.
+C
+C.......................................................................
+C
+C ***** EXTERNAL FUNCTION *****
+C
+ DOUBLE PRECISION DR7MDC
+ EXTERNAL DR7MDC
+C DR7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS.
+C
+C ***** INTRINSIC FUNCTIONS *****
+C/+
+ DOUBLE PRECISION DSQRT
+C/
+C ***** LOCAL VARIABLES *****
+C
+ INTEGER FH, FX0, HSAVE, I, XISAVE
+ DOUBLE PRECISION AAI, AFX, AFXETA, AGI, ALPHAI, AXI, AXIBAR,
+ 1 DISCON, ETA, GI, H, HMIN
+ DOUBLE PRECISION C2000, FOUR, HMAX0, HMIN0, H0, MACHEP, ONE, P002,
+ 1 THREE, TWO, ZERO
+C
+ PARAMETER (C2000=2.0D+3, FOUR=4.0D+0, HMAX0=0.02D+0, HMIN0=5.0D+1,
+ 1 ONE=1.0D+0, P002=0.002D+0, THREE=3.0D+0,
+ 2 TWO=2.0D+0, ZERO=0.0D+0)
+ PARAMETER (FH=3, FX0=4, HSAVE=5, XISAVE=6)
+C
+C--------------------------------- BODY ------------------------------
+C
+ IF (IRC .LT. 0) GO TO 140
+ IF (IRC .GT. 0) GO TO 210
+C
+C *** FRESH START -- GET MACHINE-DEPENDENT CONSTANTS ***
+C
+C STORE MACHEP IN W(1) AND H0 IN W(2), WHERE MACHEP IS THE UNIT
+C ROUNDOFF (THE SMALLEST POSITIVE NUMBER SUCH THAT
+C 1 + MACHEP .GT. 1 AND 1 - MACHEP .LT. 1), AND H0 IS THE
+C SQUARE-ROOT OF MACHEP.
+C
+ W(1) = DR7MDC(3)
+ W(2) = DSQRT(W(1))
+C
+ W(FX0) = FX
+C
+C *** INCREMENT I AND START COMPUTING G(I) ***
+C
+ 110 I = IABS(IRC) + 1
+ IF (I .GT. N) GO TO 300
+ IRC = I
+ AFX = DABS(W(FX0))
+ MACHEP = W(1)
+ H0 = W(2)
+ HMIN = HMIN0 * MACHEP
+ W(XISAVE) = X(I)
+ AXI = DABS(X(I))
+ AXIBAR = DMAX1(AXI, ONE/D(I))
+ GI = G(I)
+ AGI = DABS(GI)
+ ETA = DABS(ETA0)
+ IF (AFX .GT. ZERO) ETA = DMAX1(ETA, AGI*AXI*MACHEP/AFX)
+ ALPHAI = ALPHA(I)
+ IF (ALPHAI .EQ. ZERO) GO TO 170
+ IF (GI .EQ. ZERO .OR. FX .EQ. ZERO) GO TO 180
+ AFXETA = AFX*ETA
+ AAI = DABS(ALPHAI)
+C
+C *** COMPUTE H = STEWART*S FORWARD-DIFFERENCE STEP SIZE.
+C
+ IF (GI**2 .LE. AFXETA*AAI) GO TO 120
+ H = TWO*DSQRT(AFXETA/AAI)
+ H = H*(ONE - AAI*H/(THREE*AAI*H + FOUR*AGI))
+ GO TO 130
+C120 H = TWO*(AFXETA*AGI/(AAI**2))**(ONE/THREE)
+ 120 H = TWO * (AFXETA*AGI)**(ONE/THREE) * AAI**(-TWO/THREE)
+ H = H*(ONE - TWO*AGI/(THREE*AAI*H + FOUR*AGI))
+C
+C *** ENSURE THAT H IS NOT INSIGNIFICANTLY SMALL ***
+C
+ 130 H = DMAX1(H, HMIN*AXIBAR)
+C
+C *** USE FORWARD DIFFERENCE IF BOUND ON TRUNCATION ERROR IS AT
+C *** MOST 10**-3.
+C
+ IF (AAI*H .LE. P002*AGI) GO TO 160
+C
+C *** COMPUTE H = STEWART*S STEP FOR CENTRAL DIFFERENCE.
+C
+ DISCON = C2000*AFXETA
+ H = DISCON/(AGI + DSQRT(GI**2 + AAI*DISCON))
+C
+C *** ENSURE THAT H IS NEITHER TOO SMALL NOR TOO BIG ***
+C
+ H = DMAX1(H, HMIN*AXIBAR)
+ IF (H .GE. HMAX0*AXIBAR) H = AXIBAR * H0**(TWO/THREE)
+C
+C *** COMPUTE CENTRAL DIFFERENCE ***
+C
+ IRC = -I
+ GO TO 200
+C
+ 140 H = -W(HSAVE)
+ I = IABS(IRC)
+ IF (H .GT. ZERO) GO TO 150
+ W(FH) = FX
+ GO TO 200
+C
+ 150 G(I) = (W(FH) - FX) / (TWO * H)
+ X(I) = W(XISAVE)
+ GO TO 110
+C
+C *** COMPUTE FORWARD DIFFERENCES IN VARIOUS CASES ***
+C
+ 160 IF (H .GE. HMAX0*AXIBAR) H = H0 * AXIBAR
+ IF (ALPHAI*GI .LT. ZERO) H = -H
+ GO TO 200
+ 170 H = AXIBAR
+ GO TO 200
+ 180 H = H0 * AXIBAR
+C
+ 200 X(I) = W(XISAVE) + H
+ W(HSAVE) = H
+ GO TO 999
+C
+C *** COMPUTE ACTUAL FORWARD DIFFERENCE ***
+C
+ 210 G(IRC) = (FX - W(FX0)) / W(HSAVE)
+ X(IRC) = W(XISAVE)
+ GO TO 110
+C
+C *** RESTORE FX AND INDICATE THAT G HAS BEEN COMPUTED ***
+C
+ 300 FX = W(FX0)
+ IRC = 0
+C
+ 999 RETURN
+C *** LAST CARD OF DS7GRD FOLLOWS ***
+ END
+ SUBROUTINE DG7QTS(D, DIG, DIHDI, KA, L, P, STEP, V, W)
+C
+C *** COMPUTE GOLDFELD-QUANDT-TROTTER STEP BY MORE-HEBDEN TECHNIQUE ***
+C *** (NL2SOL VERSION 2.2), MODIFIED A LA MORE AND SORENSEN ***
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER KA, P
+ DOUBLE PRECISION D(P), DIG(P), DIHDI(*), L(*), V(21), STEP(P),
+ 1 W(*)
+C DIMENSION DIHDI(P*(P+1)/2), L(P*(P+1)/2), W(4*P+7)
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+C *** PURPOSE ***
+C
+C GIVEN THE (COMPACTLY STORED) LOWER TRIANGLE OF A SCALED
+C HESSIAN (APPROXIMATION) AND A NONZERO SCALED GRADIENT VECTOR,
+C THIS SUBROUTINE COMPUTES A GOLDFELD-QUANDT-TROTTER STEP OF
+C APPROXIMATE LENGTH V(RADIUS) BY THE MORE-HEBDEN TECHNIQUE. IN
+C OTHER WORDS, STEP IS COMPUTED TO (APPROXIMATELY) MINIMIZE
+C PSI(STEP) = (G**T)*STEP + 0.5*(STEP**T)*H*STEP SUCH THAT THE
+C 2-NORM OF D*STEP IS AT MOST (APPROXIMATELY) V(RADIUS), WHERE
+C G IS THE GRADIENT, H IS THE HESSIAN, AND D IS A DIAGONAL
+C SCALE MATRIX WHOSE DIAGONAL IS STORED IN THE PARAMETER D.
+C (DG7QTS ASSUMES DIG = D**-1 * G AND DIHDI = D**-1 * H * D**-1.)
+C
+C *** PARAMETER DESCRIPTION ***
+C
+C D (IN) = THE SCALE VECTOR, I.E. THE DIAGONAL OF THE SCALE
+C MATRIX D MENTIONED ABOVE UNDER PURPOSE.
+C DIG (IN) = THE SCALED GRADIENT VECTOR, D**-1 * G. IF G = 0, THEN
+C STEP = 0 AND V(STPPAR) = 0 ARE RETURNED.
+C DIHDI (IN) = LOWER TRIANGLE OF THE SCALED HESSIAN (APPROXIMATION),
+C I.E., D**-1 * H * D**-1, STORED COMPACTLY BY ROWS., I.E.,
+C IN THE ORDER (1,1), (2,1), (2,2), (3,1), (3,2), ETC.
+C KA (I/O) = THE NUMBER OF HEBDEN ITERATIONS (SO FAR) TAKEN TO DETER-
+C MINE STEP. KA .LT. 0 ON INPUT MEANS THIS IS THE FIRST
+C ATTEMPT TO DETERMINE STEP (FOR THE PRESENT DIG AND DIHDI)
+C -- KA IS INITIALIZED TO 0 IN THIS CASE. OUTPUT WITH
+C KA = 0 (OR V(STPPAR) = 0) MEANS STEP = -(H**-1)*G.
+C L (I/O) = WORKSPACE OF LENGTH P*(P+1)/2 FOR CHOLESKY FACTORS.
+C P (IN) = NUMBER OF PARAMETERS -- THE HESSIAN IS A P X P MATRIX.
+C STEP (I/O) = THE STEP COMPUTED.
+C V (I/O) CONTAINS VARIOUS CONSTANTS AND VARIABLES DESCRIBED BELOW.
+C W (I/O) = WORKSPACE OF LENGTH 4*P + 6.
+C
+C *** ENTRIES IN V ***
+C
+C V(DGNORM) (I/O) = 2-NORM OF (D**-1)*G.
+C V(DSTNRM) (OUTPUT) = 2-NORM OF D*STEP.
+C V(DST0) (I/O) = 2-NORM OF D*(H**-1)*G (FOR POS. DEF. H ONLY), OR
+C OVERESTIMATE OF SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1).
+C V(EPSLON) (IN) = MAX. REL. ERROR ALLOWED FOR PSI(STEP). FOR THE
+C STEP RETURNED, PSI(STEP) WILL EXCEED ITS OPTIMAL VALUE
+C BY LESS THAN -V(EPSLON)*PSI(STEP). SUGGESTED VALUE = 0.1.
+C V(GTSTEP) (OUT) = INNER PRODUCT BETWEEN G AND STEP.
+C V(NREDUC) (OUT) = PSI(-(H**-1)*G) = PSI(NEWTON STEP) (FOR POS. DEF.
+C H ONLY -- V(NREDUC) IS SET TO ZERO OTHERWISE).
+C V(PHMNFC) (IN) = TOL. (TOGETHER WITH V(PHMXFC)) FOR ACCEPTING STEP
+C (MORE*S SIGMA). THE ERROR V(DSTNRM) - V(RADIUS) MUST LIE
+C BETWEEN V(PHMNFC)*V(RADIUS) AND V(PHMXFC)*V(RADIUS).
+C V(PHMXFC) (IN) (SEE V(PHMNFC).)
+C SUGGESTED VALUES -- V(PHMNFC) = -0.25, V(PHMXFC) = 0.5.
+C V(PREDUC) (OUT) = PSI(STEP) = PREDICTED OBJ. FUNC. REDUCTION FOR STEP.
+C V(RADIUS) (IN) = RADIUS OF CURRENT (SCALED) TRUST REGION.
+C V(RAD0) (I/O) = VALUE OF V(RADIUS) FROM PREVIOUS CALL.
+C V(STPPAR) (I/O) IS NORMALLY THE MARQUARDT PARAMETER, I.E. THE ALPHA
+C DESCRIBED BELOW UNDER ALGORITHM NOTES. IF H + ALPHA*D**2
+C (SEE ALGORITHM NOTES) IS (NEARLY) SINGULAR, HOWEVER,
+C THEN V(STPPAR) = -ALPHA.
+C
+C *** USAGE NOTES ***
+C
+C IF IT IS DESIRED TO RECOMPUTE STEP USING A DIFFERENT VALUE OF
+C V(RADIUS), THEN THIS ROUTINE MAY BE RESTARTED BY CALLING IT
+C WITH ALL PARAMETERS UNCHANGED EXCEPT V(RADIUS). (THIS EXPLAINS
+C WHY STEP AND W ARE LISTED AS I/O). ON AN INITIAL CALL (ONE WITH
+C KA .LT. 0), STEP AND W NEED NOT BE INITIALIZED AND ONLY COMPO-
+C NENTS V(EPSLON), V(STPPAR), V(PHMNFC), V(PHMXFC), V(RADIUS), AND
+C V(RAD0) OF V MUST BE INITIALIZED.
+C
+C *** ALGORITHM NOTES ***
+C
+C THE DESIRED G-Q-T STEP (REF. 2, 3, 4, 6) SATISFIES
+C (H + ALPHA*D**2)*STEP = -G FOR SOME NONNEGATIVE ALPHA SUCH THAT
+C H + ALPHA*D**2 IS POSITIVE SEMIDEFINITE. ALPHA AND STEP ARE
+C COMPUTED BY A SCHEME ANALOGOUS TO THE ONE DESCRIBED IN REF. 5.
+C ESTIMATES OF THE SMALLEST AND LARGEST EIGENVALUES OF THE HESSIAN
+C ARE OBTAINED FROM THE GERSCHGORIN CIRCLE THEOREM ENHANCED BY A
+C SIMPLE FORM OF THE SCALING DESCRIBED IN REF. 7. CASES IN WHICH
+C H + ALPHA*D**2 IS NEARLY (OR EXACTLY) SINGULAR ARE HANDLED BY
+C THE TECHNIQUE DISCUSSED IN REF. 2. IN THESE CASES, A STEP OF
+C (EXACT) LENGTH V(RADIUS) IS RETURNED FOR WHICH PSI(STEP) EXCEEDS
+C ITS OPTIMAL VALUE BY LESS THAN -V(EPSLON)*PSI(STEP). THE TEST
+C SUGGESTED IN REF. 6 FOR DETECTING THE SPECIAL CASE IS PERFORMED
+C ONCE TWO MATRIX FACTORIZATIONS HAVE BEEN DONE -- DOING SO SOONER
+C SEEMS TO DEGRADE THE PERFORMANCE OF OPTIMIZATION ROUTINES THAT
+C CALL THIS ROUTINE.
+C
+C *** FUNCTIONS AND SUBROUTINES CALLED ***
+C
+C DD7TPR - RETURNS INNER PRODUCT OF TWO VECTORS.
+C DL7ITV - APPLIES INVERSE-TRANSPOSE OF COMPACT LOWER TRIANG. MATRIX.
+C DL7IVM - APPLIES INVERSE OF COMPACT LOWER TRIANG. MATRIX.
+C DL7SRT - FINDS CHOLESKY FACTOR (OF COMPACTLY STORED LOWER TRIANG.).
+C DL7SVN - RETURNS APPROX. TO MIN. SING. VALUE OF LOWER TRIANG. MATRIX.
+C DR7MDC - RETURNS MACHINE-DEPENDENT CONSTANTS.
+C DV2NRM - RETURNS 2-NORM OF A VECTOR.
+C
+C *** REFERENCES ***
+C
+C 1. DENNIS, J.E., GAY, D.M., AND WELSCH, R.E. (1981), AN ADAPTIVE
+C NONLINEAR LEAST-SQUARES ALGORITHM, ACM TRANS. MATH.
+C SOFTWARE, VOL. 7, NO. 3.
+C 2. GAY, D.M. (1981), COMPUTING OPTIMAL LOCALLY CONSTRAINED STEPS,
+C SIAM J. SCI. STATIST. COMPUTING, VOL. 2, NO. 2, PP.
+C 186-197.
+C 3. GOLDFELD, S.M., QUANDT, R.E., AND TROTTER, H.F. (1966),
+C MAXIMIZATION BY QUADRATIC HILL-CLIMBING, ECONOMETRICA 34,
+C PP. 541-551.
+C 4. HEBDEN, M.D. (1973), AN ALGORITHM FOR MINIMIZATION USING EXACT
+C SECOND DERIVATIVES, REPORT T.P. 515, THEORETICAL PHYSICS
+C DIV., A.E.R.E. HARWELL, OXON., ENGLAND.
+C 5. MORE, J.J. (1978), THE LEVENBERG-MARQUARDT ALGORITHM, IMPLEMEN-
+C TATION AND THEORY, PP.105-116 OF SPRINGER LECTURE NOTES
+C IN MATHEMATICS NO. 630, EDITED BY G.A. WATSON, SPRINGER-
+C VERLAG, BERLIN AND NEW YORK.
+C 6. MORE, J.J., AND SORENSEN, D.C. (1981), COMPUTING A TRUST REGION
+C STEP, TECHNICAL REPORT ANL-81-83, ARGONNE NATIONAL LAB.
+C 7. VARGA, R.S. (1965), MINIMAL GERSCHGORIN SETS, PACIFIC J. MATH. 15,
+C PP. 719-729.
+C
+C *** GENERAL ***
+C
+C CODED BY DAVID M. GAY.
+C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
+C SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
+C MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
+C MCS-7906671.
+C
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+C *** LOCAL VARIABLES ***
+C
+ LOGICAL RESTRT
+ INTEGER DGGDMX, DIAG, DIAG0, DSTSAV, EMAX, EMIN, I, IM1, INC, IRC,
+ 1 J, K, KALIM, KAMIN, K1, LK0, PHIPIN, Q, Q0, UK0, X
+ DOUBLE PRECISION ALPHAK, AKI, AKK, DELTA, DST, EPS, GTSTA, LK,
+ 1 OLDPHI, PHI, PHIMAX, PHIMIN, PSIFAC, RAD, RADSQ,
+ 2 ROOT, SI, SK, SW, T, TWOPSI, T1, T2, UK, WI
+C
+C *** CONSTANTS ***
+ DOUBLE PRECISION BIG, DGXFAC, EPSFAC, FOUR, HALF, KAPPA, NEGONE,
+ 1 ONE, P001, SIX, THREE, TWO, ZERO
+C
+C *** INTRINSIC FUNCTIONS ***
+C/+
+ DOUBLE PRECISION DSQRT
+C/
+C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
+C
+ DOUBLE PRECISION DD7TPR, DL7SVN, DR7MDC, DV2NRM
+ EXTERNAL DD7TPR, DL7ITV, DL7IVM,DL7SRT, DL7SVN, DR7MDC, DV2NRM
+C
+C *** SUBSCRIPTS FOR V ***
+C
+ INTEGER DGNORM, DSTNRM, DST0, EPSLON, GTSTEP, STPPAR, NREDUC,
+ 1 PHMNFC, PHMXFC, PREDUC, RADIUS, RAD0
+ PARAMETER (DGNORM=1, DSTNRM=2, DST0=3, EPSLON=19, GTSTEP=4,
+ 1 NREDUC=6, PHMNFC=20, PHMXFC=21, PREDUC=7, RADIUS=8,
+ 2 RAD0=9, STPPAR=5)
+C
+ PARAMETER (EPSFAC=50.0D+0, FOUR=4.0D+0, HALF=0.5D+0,
+ 1 KAPPA=2.0D+0, NEGONE=-1.0D+0, ONE=1.0D+0, P001=1.0D-3,
+ 2 SIX=6.0D+0, THREE=3.0D+0, TWO=2.0D+0, ZERO=0.0D+0)
+ SAVE DGXFAC
+ DATA BIG/0.D+0/, DGXFAC/0.D+0/
+C
+C *** BODY ***
+C
+ IF (BIG .LE. ZERO) BIG = DR7MDC(6)
+C
+C *** STORE LARGEST ABS. ENTRY IN (D**-1)*H*(D**-1) AT W(DGGDMX).
+ DGGDMX = P + 1
+C *** STORE GERSCHGORIN OVER- AND UNDERESTIMATES OF THE LARGEST
+C *** AND SMALLEST EIGENVALUES OF (D**-1)*H*(D**-1) AT W(EMAX)
+C *** AND W(EMIN) RESPECTIVELY.
+ EMAX = DGGDMX + 1
+ EMIN = EMAX + 1
+C *** FOR USE IN RECOMPUTING STEP, THE FINAL VALUES OF LK, UK, DST,
+C *** AND THE INVERSE DERIVATIVE OF MORE*S PHI AT 0 (FOR POS. DEF.
+C *** H) ARE STORED IN W(LK0), W(UK0), W(DSTSAV), AND W(PHIPIN)
+C *** RESPECTIVELY.
+ LK0 = EMIN + 1
+ PHIPIN = LK0 + 1
+ UK0 = PHIPIN + 1
+ DSTSAV = UK0 + 1
+C *** STORE DIAG OF (D**-1)*H*(D**-1) IN W(DIAG),...,W(DIAG0+P).
+ DIAG0 = DSTSAV
+ DIAG = DIAG0 + 1
+C *** STORE -D*STEP IN W(Q),...,W(Q0+P).
+ Q0 = DIAG0 + P
+ Q = Q0 + 1
+C *** ALLOCATE STORAGE FOR SCRATCH VECTOR X ***
+ X = Q + P
+ RAD = V(RADIUS)
+ RADSQ = RAD**2
+C *** PHITOL = MAX. ERROR ALLOWED IN DST = V(DSTNRM) = 2-NORM OF
+C *** D*STEP.
+ PHIMAX = V(PHMXFC) * RAD
+ PHIMIN = V(PHMNFC) * RAD
+ PSIFAC = BIG
+ T1 = TWO * V(EPSLON) / (THREE * (FOUR * (V(PHMNFC) + ONE) *
+ 1 (KAPPA + ONE) + KAPPA + TWO) * RAD)
+ IF (T1 .LT. BIG*DMIN1(RAD,ONE)) PSIFAC = T1 / RAD
+C *** OLDPHI IS USED TO DETECT LIMITS OF NUMERICAL ACCURACY. IF
+C *** WE RECOMPUTE STEP AND IT DOES NOT CHANGE, THEN WE ACCEPT IT.
+ OLDPHI = ZERO
+ EPS = V(EPSLON)
+ IRC = 0
+ RESTRT = .FALSE.
+ KALIM = KA + 50
+C
+C *** START OR RESTART, DEPENDING ON KA ***
+C
+ IF (KA .GE. 0) GO TO 290
+C
+C *** FRESH START ***
+C
+ K = 0
+ UK = NEGONE
+ KA = 0
+ KALIM = 50
+ V(DGNORM) = DV2NRM(P, DIG)
+ V(NREDUC) = ZERO
+ V(DST0) = ZERO
+ KAMIN = 3
+ IF (V(DGNORM) .EQ. ZERO) KAMIN = 0
+C
+C *** STORE DIAG(DIHDI) IN W(DIAG0+1),...,W(DIAG0+P) ***
+C
+ J = 0
+ DO 10 I = 1, P
+ J = J + I
+ K1 = DIAG0 + I
+ W(K1) = DIHDI(J)
+ 10 CONTINUE
+C
+C *** DETERMINE W(DGGDMX), THE LARGEST ELEMENT OF DIHDI ***
+C
+ T1 = ZERO
+ J = P * (P + 1) / 2
+ DO 20 I = 1, J
+ T = DABS(DIHDI(I))
+ IF (T1 .LT. T) T1 = T
+ 20 CONTINUE
+ W(DGGDMX) = T1
+C
+C *** TRY ALPHA = 0 ***
+C
+ 30 CALL DL7SRT(1, P, L, DIHDI, IRC)
+ IF (IRC .EQ. 0) GO TO 50
+C *** INDEF. H -- UNDERESTIMATE SMALLEST EIGENVALUE, USE THIS
+C *** ESTIMATE TO INITIALIZE LOWER BOUND LK ON ALPHA.
+ J = IRC*(IRC+1)/2
+ T = L(J)
+ L(J) = ONE
+ DO 40 I = 1, IRC
+ 40 W(I) = ZERO
+ W(IRC) = ONE
+ CALL DL7ITV(IRC, W, L, W)
+ T1 = DV2NRM(IRC, W)
+ LK = -T / T1 / T1
+ V(DST0) = -LK
+ IF (RESTRT) GO TO 210
+ GO TO 70
+C
+C *** POSITIVE DEFINITE H -- COMPUTE UNMODIFIED NEWTON STEP. ***
+ 50 LK = ZERO
+ T = DL7SVN(P, L, W(Q), W(Q))
+ IF (T .GE. ONE) GO TO 60
+ IF (V(DGNORM) .GE. T*T*BIG) GO TO 70
+ 60 CALL DL7IVM(P, W(Q), L, DIG)
+ GTSTA = DD7TPR(P, W(Q), W(Q))
+ V(NREDUC) = HALF * GTSTA
+ CALL DL7ITV(P, W(Q), L, W(Q))
+ DST = DV2NRM(P, W(Q))
+ V(DST0) = DST
+ PHI = DST - RAD
+ IF (PHI .LE. PHIMAX) GO TO 260
+ IF (RESTRT) GO TO 210
+C
+C *** PREPARE TO COMPUTE GERSCHGORIN ESTIMATES OF LARGEST (AND
+C *** SMALLEST) EIGENVALUES. ***
+C
+ 70 K = 0
+ DO 100 I = 1, P
+ WI = ZERO
+ IF (I .EQ. 1) GO TO 90
+ IM1 = I - 1
+ DO 80 J = 1, IM1
+ K = K + 1
+ T = DABS(DIHDI(K))
+ WI = WI + T
+ W(J) = W(J) + T
+ 80 CONTINUE
+ 90 W(I) = WI
+ K = K + 1
+ 100 CONTINUE
+C
+C *** (UNDER-)ESTIMATE SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1) ***
+C
+ K = 1
+ T1 = W(DIAG) - W(1)
+ IF (P .LE. 1) GO TO 120
+ DO 110 I = 2, P
+ J = DIAG0 + I
+ T = W(J) - W(I)
+ IF (T .GE. T1) GO TO 110
+ T1 = T
+ K = I
+ 110 CONTINUE
+C
+ 120 SK = W(K)
+ J = DIAG0 + K
+ AKK = W(J)
+ K1 = K*(K-1)/2 + 1
+ INC = 1
+ T = ZERO
+ DO 150 I = 1, P
+ IF (I .EQ. K) GO TO 130
+ AKI = DABS(DIHDI(K1))
+ SI = W(I)
+ J = DIAG0 + I
+ T1 = HALF * (AKK - W(J) + SI - AKI)
+ T1 = T1 + DSQRT(T1*T1 + SK*AKI)
+ IF (T .LT. T1) T = T1
+ IF (I .LT. K) GO TO 140
+ 130 INC = I
+ 140 K1 = K1 + INC
+ 150 CONTINUE
+C
+ W(EMIN) = AKK - T
+ UK = V(DGNORM)/RAD - W(EMIN)
+ IF (V(DGNORM) .EQ. ZERO) UK = UK + P001 + P001*UK
+ IF (UK .LE. ZERO) UK = P001
+C
+C *** COMPUTE GERSCHGORIN (OVER-)ESTIMATE OF LARGEST EIGENVALUE ***
+C
+ K = 1
+ T1 = W(DIAG) + W(1)
+ IF (P .LE. 1) GO TO 170
+ DO 160 I = 2, P
+ J = DIAG0 + I
+ T = W(J) + W(I)
+ IF (T .LE. T1) GO TO 160
+ T1 = T
+ K = I
+ 160 CONTINUE
+C
+ 170 SK = W(K)
+ J = DIAG0 + K
+ AKK = W(J)
+ K1 = K*(K-1)/2 + 1
+ INC = 1
+ T = ZERO
+ DO 200 I = 1, P
+ IF (I .EQ. K) GO TO 180
+ AKI = DABS(DIHDI(K1))
+ SI = W(I)
+ J = DIAG0 + I
+ T1 = HALF * (W(J) + SI - AKI - AKK)
+ T1 = T1 + DSQRT(T1*T1 + SK*AKI)
+ IF (T .LT. T1) T = T1
+ IF (I .LT. K) GO TO 190
+ 180 INC = I
+ 190 K1 = K1 + INC
+ 200 CONTINUE
+C
+ W(EMAX) = AKK + T
+ LK = DMAX1(LK, V(DGNORM)/RAD - W(EMAX))
+C
+C *** ALPHAK = CURRENT VALUE OF ALPHA (SEE ALG. NOTES ABOVE). WE
+C *** USE MORE*S SCHEME FOR INITIALIZING IT.
+ ALPHAK = DABS(V(STPPAR)) * V(RAD0)/RAD
+ ALPHAK = DMIN1(UK, DMAX1(ALPHAK, LK))
+C
+ IF (IRC .NE. 0) GO TO 210
+C
+C *** COMPUTE L0 FOR POSITIVE DEFINITE H ***
+C
+ CALL DL7IVM(P, W, L, W(Q))
+ T = DV2NRM(P, W)
+ W(PHIPIN) = RAD / T / T
+ LK = DMAX1(LK, PHI*W(PHIPIN))
+C
+C *** SAFEGUARD ALPHAK AND ADD ALPHAK*I TO (D**-1)*H*(D**-1) ***
+C
+ 210 KA = KA + 1
+ IF (-V(DST0) .GE. ALPHAK .OR. ALPHAK .LT. LK .OR. ALPHAK .GE. UK)
+ 1 ALPHAK = UK * DMAX1(P001, DSQRT(LK/UK))
+ IF (ALPHAK .LE. ZERO) ALPHAK = HALF * UK
+ IF (ALPHAK .LE. ZERO) ALPHAK = UK
+ K = 0
+ DO 220 I = 1, P
+ K = K + I
+ J = DIAG0 + I
+ DIHDI(K) = W(J) + ALPHAK
+ 220 CONTINUE
+C
+C *** TRY COMPUTING CHOLESKY DECOMPOSITION ***
+C
+ CALL DL7SRT(1, P, L, DIHDI, IRC)
+ IF (IRC .EQ. 0) GO TO 240
+C
+C *** (D**-1)*H*(D**-1) + ALPHAK*I IS INDEFINITE -- OVERESTIMATE
+C *** SMALLEST EIGENVALUE FOR USE IN UPDATING LK ***
+C
+ J = (IRC*(IRC+1))/2
+ T = L(J)
+ L(J) = ONE
+ DO 230 I = 1, IRC
+ 230 W(I) = ZERO
+ W(IRC) = ONE
+ CALL DL7ITV(IRC, W, L, W)
+ T1 = DV2NRM(IRC, W)
+ LK = ALPHAK - T/T1/T1
+ V(DST0) = -LK
+ IF (UK .LT. LK) UK = LK
+ IF (ALPHAK .LT. LK) GO TO 210
+C
+C *** NASTY CASE -- EXACT GERSCHGORIN BOUNDS. FUDGE LK, UK...
+C
+ T = P001 * ALPHAK
+ IF (T .LE. ZERO) T = P001
+ LK = ALPHAK + T
+ IF (UK .LE. LK) UK = LK + T
+ GO TO 210
+C
+C *** ALPHAK MAKES (D**-1)*H*(D**-1) POSITIVE DEFINITE.
+C *** COMPUTE Q = -D*STEP, CHECK FOR CONVERGENCE. ***
+C
+ 240 CALL DL7IVM(P, W(Q), L, DIG)
+ GTSTA = DD7TPR(P, W(Q), W(Q))
+ CALL DL7ITV(P, W(Q), L, W(Q))
+ DST = DV2NRM(P, W(Q))
+ PHI = DST - RAD
+ IF (PHI .LE. PHIMAX .AND. PHI .GE. PHIMIN) GO TO 270
+ IF (PHI .EQ. OLDPHI) GO TO 270
+ OLDPHI = PHI
+ IF (PHI .LT. ZERO) GO TO 330
+C
+C *** UNACCEPTABLE ALPHAK -- UPDATE LK, UK, ALPHAK ***
+C
+ 250 IF (KA .GE. KALIM) GO TO 270
+C *** THE FOLLOWING DMIN1 IS NECESSARY BECAUSE OF RESTARTS ***
+ IF (PHI .LT. ZERO) UK = DMIN1(UK, ALPHAK)
+C *** KAMIN = 0 ONLY IFF THE GRADIENT VANISHES ***
+ IF (KAMIN .EQ. 0) GO TO 210
+ CALL DL7IVM(P, W, L, W(Q))
+C *** THE FOLLOWING, COMMENTED CALCULATION OF ALPHAK IS SOMETIMES
+C *** SAFER BUT WORSE IN PERFORMANCE...
+C T1 = DST / DV2NRM(P, W)
+C ALPHAK = ALPHAK + T1 * (PHI/RAD) * T1
+ T1 = DV2NRM(P, W)
+ ALPHAK = ALPHAK + (PHI/T1) * (DST/T1) * (DST/RAD)
+ LK = DMAX1(LK, ALPHAK)
+ ALPHAK = LK
+ GO TO 210
+C
+C *** ACCEPTABLE STEP ON FIRST TRY ***
+C
+ 260 ALPHAK = ZERO
+C
+C *** SUCCESSFUL STEP IN GENERAL. COMPUTE STEP = -(D**-1)*Q ***
+C
+ 270 DO 280 I = 1, P
+ J = Q0 + I
+ STEP(I) = -W(J)/D(I)
+ 280 CONTINUE
+ V(GTSTEP) = -GTSTA
+ V(PREDUC) = HALF * (DABS(ALPHAK)*DST*DST + GTSTA)
+ GO TO 410
+C
+C
+C *** RESTART WITH NEW RADIUS ***
+C
+ 290 IF (V(DST0) .LE. ZERO .OR. V(DST0) - RAD .GT. PHIMAX) GO TO 310
+C
+C *** PREPARE TO RETURN NEWTON STEP ***
+C
+ RESTRT = .TRUE.
+ KA = KA + 1
+ K = 0
+ DO 300 I = 1, P
+ K = K + I
+ J = DIAG0 + I
+ DIHDI(K) = W(J)
+ 300 CONTINUE
+ UK = NEGONE
+ GO TO 30
+C
+ 310 KAMIN = KA + 3
+ IF (V(DGNORM) .EQ. ZERO) KAMIN = 0
+ IF (KA .EQ. 0) GO TO 50
+C
+ DST = W(DSTSAV)
+ ALPHAK = DABS(V(STPPAR))
+ PHI = DST - RAD
+ T = V(DGNORM)/RAD
+ UK = T - W(EMIN)
+ IF (V(DGNORM) .EQ. ZERO) UK = UK + P001 + P001*UK
+ IF (UK .LE. ZERO) UK = P001
+ IF (RAD .GT. V(RAD0)) GO TO 320
+C
+C *** SMALLER RADIUS ***
+ LK = ZERO
+ IF (ALPHAK .GT. ZERO) LK = W(LK0)
+ LK = DMAX1(LK, T - W(EMAX))
+ IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
+ GO TO 250
+C
+C *** BIGGER RADIUS ***
+ 320 IF (ALPHAK .GT. ZERO) UK = DMIN1(UK, W(UK0))
+ LK = DMAX1(ZERO, -V(DST0), T - W(EMAX))
+ IF (V(DST0) .GT. ZERO) LK = DMAX1(LK, (V(DST0)-RAD)*W(PHIPIN))
+ GO TO 250
+C
+C *** DECIDE WHETHER TO CHECK FOR SPECIAL CASE... IN PRACTICE (FROM
+C *** THE STANDPOINT OF THE CALLING OPTIMIZATION CODE) IT SEEMS BEST
+C *** NOT TO CHECK UNTIL A FEW ITERATIONS HAVE FAILED -- HENCE THE
+C *** TEST ON KAMIN BELOW.
+C
+ 330 DELTA = ALPHAK + DMIN1(ZERO, V(DST0))
+ TWOPSI = ALPHAK*DST*DST + GTSTA
+ IF (KA .GE. KAMIN) GO TO 340
+C *** IF THE TEST IN REF. 2 IS SATISFIED, FALL THROUGH TO HANDLE
+C *** THE SPECIAL CASE (AS SOON AS THE MORE-SORENSEN TEST DETECTS
+C *** IT).
+ IF (PSIFAC .GE. BIG) GO TO 340
+ IF (DELTA .GE. PSIFAC*TWOPSI) GO TO 370
+C
+C *** CHECK FOR THE SPECIAL CASE OF H + ALPHA*D**2 (NEARLY)
+C *** SINGULAR. USE ONE STEP OF INVERSE POWER METHOD WITH START
+C *** FROM DL7SVN TO OBTAIN APPROXIMATE EIGENVECTOR CORRESPONDING
+C *** TO SMALLEST EIGENVALUE OF (D**-1)*H*(D**-1). DL7SVN RETURNS
+C *** X AND W WITH L*W = X.
+C
+ 340 T = DL7SVN(P, L, W(X), W)
+C
+C *** NORMALIZE W ***
+ DO 350 I = 1, P
+ 350 W(I) = T*W(I)
+C *** COMPLETE CURRENT INV. POWER ITER. -- REPLACE W BY (L**-T)*W.
+ CALL DL7ITV(P, W, L, W)
+ T2 = ONE/DV2NRM(P, W)
+ DO 360 I = 1, P
+ 360 W(I) = T2*W(I)
+ T = T2 * T
+C
+C *** NOW W IS THE DESIRED APPROXIMATE (UNIT) EIGENVECTOR AND
+C *** T*X = ((D**-1)*H*(D**-1) + ALPHAK*I)*W.
+C
+ SW = DD7TPR(P, W(Q), W)
+ T1 = (RAD + DST) * (RAD - DST)
+ ROOT = DSQRT(SW*SW + T1)
+ IF (SW .LT. ZERO) ROOT = -ROOT
+ SI = T1 / (SW + ROOT)
+C
+C *** THE ACTUAL TEST FOR THE SPECIAL CASE...
+C
+ IF ((T2*SI)**2 .LE. EPS*(DST**2 + ALPHAK*RADSQ)) GO TO 380
+C
+C *** UPDATE UPPER BOUND ON SMALLEST EIGENVALUE (WHEN NOT POSITIVE)
+C *** (AS RECOMMENDED BY MORE AND SORENSEN) AND CONTINUE...
+C
+ IF (V(DST0) .LE. ZERO) V(DST0) = DMIN1(V(DST0), T2**2 - ALPHAK)
+ LK = DMAX1(LK, -V(DST0))
+C
+C *** CHECK WHETHER WE CAN HOPE TO DETECT THE SPECIAL CASE IN
+C *** THE AVAILABLE ARITHMETIC. ACCEPT STEP AS IT IS IF NOT.
+C
+C *** IF NOT YET AVAILABLE, OBTAIN MACHINE DEPENDENT VALUE DGXFAC.
+ 370 IF (DGXFAC .EQ. ZERO) DGXFAC = EPSFAC * DR7MDC(3)
+C
+ IF (DELTA .GT. DGXFAC*W(DGGDMX)) GO TO 250
+ GO TO 270
+C
+C *** SPECIAL CASE DETECTED... NEGATE ALPHAK TO INDICATE SPECIAL CASE
+C
+ 380 ALPHAK = -ALPHAK
+ V(PREDUC) = HALF * TWOPSI
+C
+C *** ACCEPT CURRENT STEP IF ADDING SI*W WOULD LEAD TO A
+C *** FURTHER RELATIVE REDUCTION IN PSI OF LESS THAN V(EPSLON)/3.
+C
+ T1 = ZERO
+ T = SI*(ALPHAK*SW - HALF*SI*(ALPHAK + T*DD7TPR(P,W(X),W)))
+ IF (T .LT. EPS*TWOPSI/SIX) GO TO 390
+ V(PREDUC) = V(PREDUC) + T
+ DST = RAD
+ T1 = -SI
+ 390 DO 400 I = 1, P
+ J = Q0 + I
+ W(J) = T1*W(I) - W(J)
+ STEP(I) = W(J) / D(I)
+ 400 CONTINUE
+ V(GTSTEP) = DD7TPR(P, DIG, W(Q))
+C
+C *** SAVE VALUES FOR USE IN A POSSIBLE RESTART ***
+C
+ 410 V(DSTNRM) = DST
+ V(STPPAR) = ALPHAK
+ W(LK0) = LK
+ W(UK0) = UK
+ V(RAD0) = RAD
+ W(DSTSAV) = DST
+C
+C *** RESTORE DIAGONAL OF DIHDI ***
+C
+ J = 0
+ DO 420 I = 1, P
+ J = J + I
+ K = DIAG0 + I
+ DIHDI(J) = W(K)
+ 420 CONTINUE
+C
+ RETURN
+C
+C *** LAST CARD OF DG7QTS FOLLOWS ***
+ END
+ SUBROUTINE DW7ZBF (L, N, S, W, Y, Z)
+C
+C *** COMPUTE Y AND Z FOR DL7UPD CORRESPONDING TO BFGS UPDATE.
+C
+ INTEGER N
+ DOUBLE PRECISION L(*), S(N), W(N), Y(N), Z(N)
+C DIMENSION L(N*(N+1)/2)
+C
+C-------------------------- PARAMETER USAGE --------------------------
+C
+C L (I/O) CHOLESKY FACTOR OF HESSIAN, A LOWER TRIANG. MATRIX STORED
+C COMPACTLY BY ROWS.
+C N (INPUT) ORDER OF L AND LENGTH OF S, W, Y, Z.
+C S (INPUT) THE STEP JUST TAKEN.
+C W (OUTPUT) RIGHT SINGULAR VECTOR OF RANK 1 CORRECTION TO L.
+C Y (INPUT) CHANGE IN GRADIENTS CORRESPONDING TO S.
+C Z (OUTPUT) LEFT SINGULAR VECTOR OF RANK 1 CORRECTION TO L.
+C
+C------------------------------- NOTES -------------------------------
+C
+C *** ALGORITHM NOTES ***
+C
+C WHEN S IS COMPUTED IN CERTAIN WAYS, E.G. BY GQTSTP OR
+C DBLDOG, IT IS POSSIBLE TO SAVE N**2/2 OPERATIONS SINCE (L**T)*S
+C OR L*(L**T)*S IS THEN KNOWN.
+C IF THE BFGS UPDATE TO L*(L**T) WOULD REDUCE ITS DETERMINANT TO
+C LESS THAN EPS TIMES ITS OLD VALUE, THEN THIS ROUTINE IN EFFECT
+C REPLACES Y BY THETA*Y + (1 - THETA)*L*(L**T)*S, WHERE THETA
+C (BETWEEN 0 AND 1) IS CHOSEN TO MAKE THE REDUCTION FACTOR = EPS.
+C
+C *** GENERAL ***
+C
+C CODED BY DAVID M. GAY (FALL 1979).
+C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
+C BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS-7600324 AND
+C MCS-7906671.
+C
+C------------------------ EXTERNAL QUANTITIES ------------------------
+C
+C *** FUNCTIONS AND SUBROUTINES CALLED ***
+C
+ DOUBLE PRECISION DD7TPR
+ EXTERNAL DD7TPR, DL7IVM, DL7TVM
+C DD7TPR RETURNS INNER PRODUCT OF TWO VECTORS.
+C DL7IVM MULTIPLIES L**-1 TIMES A VECTOR.
+C DL7TVM MULTIPLIES L**T TIMES A VECTOR.
+C
+C *** INTRINSIC FUNCTIONS ***
+C/+
+ DOUBLE PRECISION DSQRT
+C/
+C-------------------------- LOCAL VARIABLES --------------------------
+C
+ INTEGER I
+ DOUBLE PRECISION CS, CY, EPS, EPSRT, ONE, SHS, YS, THETA
+C
+C *** DATA INITIALIZATIONS ***
+C
+ PARAMETER (EPS=0.1D+0, ONE=1.D+0)
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ CALL DL7TVM(N, W, L, S)
+ SHS = DD7TPR(N, W, W)
+ YS = DD7TPR(N, Y, S)
+ IF (YS .GE. EPS*SHS) GO TO 10
+ THETA = (ONE - EPS) * SHS / (SHS - YS)
+ EPSRT = DSQRT(EPS)
+ CY = THETA / (SHS * EPSRT)
+ CS = (ONE + (THETA-ONE)/EPSRT) / SHS
+ GO TO 20
+ 10 CY = ONE / (DSQRT(YS) * DSQRT(SHS))
+ CS = ONE / SHS
+ 20 CALL DL7IVM(N, Z, L, Y)
+ DO 30 I = 1, N
+ 30 Z(I) = CY * Z(I) - CS * W(I)
+C
+ RETURN
+C *** LAST CARD OF DW7ZBF FOLLOWS ***
+ END
+ SUBROUTINE DC7VFN(IV, L, LH, LIV, LV, N, P, V)
+C
+C *** FINISH COVARIANCE COMPUTATION FOR DRN2G, DRNSG ***
+C
+ INTEGER LH, LIV, LV, N, P
+ INTEGER IV(LIV)
+ DOUBLE PRECISION L(LH), V(LV)
+C
+ EXTERNAL DL7NVR, DL7TSQ, DV7SCL
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER COV, I
+ DOUBLE PRECISION HALF
+C
+C *** SUBSCRIPTS FOR IV AND V ***
+C
+ INTEGER CNVCOD, COVMAT, F, FDH, H, MODE, RDREQ, REGD
+C
+ PARAMETER (CNVCOD=55, COVMAT=26, F=10, FDH=74, H=56, MODE=35,
+ 1 RDREQ=57, REGD=67)
+ DATA HALF/0.5D+0/
+C
+C *** BODY ***
+C
+ IV(1) = IV(CNVCOD)
+ I = IV(MODE) - P
+ IV(MODE) = 0
+ IV(CNVCOD) = 0
+ IF (IV(FDH) .LE. 0) GO TO 999
+ IF ((I-2)**2 .EQ. 1) IV(REGD) = 1
+ IF (MOD(IV(RDREQ),2) .NE. 1) GO TO 999
+C
+C *** FINISH COMPUTING COVARIANCE MATRIX = INVERSE OF F.D. HESSIAN.
+C
+ COV = IABS(IV(H))
+ IV(FDH) = 0
+C
+ IF (IV(COVMAT) .NE. 0) GO TO 999
+ IF (I .GE. 2) GO TO 10
+ CALL DL7NVR(P, V(COV), L)
+ CALL DL7TSQ(P, V(COV), V(COV))
+C
+ 10 CALL DV7SCL(LH, V(COV), V(F)/(HALF * DBLE(MAX0(1,N-P))), V(COV))
+ IV(COVMAT) = COV
+C
+ 999 RETURN
+C *** LAST LINE OF DC7VFN FOLLOWS ***
+ END
+ SUBROUTINE DD7MLP(N, X, Y, Z, K)
+C
+C *** SET X = DIAG(Y)**K * Z
+C *** FOR X, Z = LOWER TRIANG. MATRICES STORED COMPACTLY BY ROW
+C *** K = 1 OR -1.
+C
+ INTEGER N, K
+ DOUBLE PRECISION X(*), Y(N), Z(*)
+ INTEGER I, J, L
+ DOUBLE PRECISION ONE, T
+ DATA ONE/1.D+0/
+C
+ L = 1
+ IF (K .GE. 0) GO TO 30
+ DO 20 I = 1, N
+ T = ONE / Y(I)
+ DO 10 J = 1, I
+ X(L) = T * Z(L)
+ L = L + 1
+ 10 CONTINUE
+ 20 CONTINUE
+ GO TO 999
+C
+ 30 DO 50 I = 1, N
+ T = Y(I)
+ DO 40 J = 1, I
+ X(L) = T * Z(L)
+ L = L + 1
+ 40 CONTINUE
+ 50 CONTINUE
+ 999 RETURN
+C *** LAST CARD OF DD7MLP FOLLOWS ***
+ END
+ SUBROUTINE DL7IVM(N, X, L, Y)
+C
+C *** SOLVE L*X = Y, WHERE L IS AN N X N LOWER TRIANGULAR
+C *** MATRIX STORED COMPACTLY BY ROWS. X AND Y MAY OCCUPY THE SAME
+C *** STORAGE. ***
+C
+ INTEGER N
+ DOUBLE PRECISION X(N), L(*), Y(N)
+ DOUBLE PRECISION DD7TPR
+ EXTERNAL DD7TPR
+ INTEGER I, J, K
+ DOUBLE PRECISION T, ZERO
+ PARAMETER (ZERO=0.D+0)
+C
+ DO 10 K = 1, N
+ IF (Y(K) .NE. ZERO) GO TO 20
+ X(K) = ZERO
+ 10 CONTINUE
+ GO TO 999
+ 20 J = K*(K+1)/2
+ X(K) = Y(K) / L(J)
+ IF (K .GE. N) GO TO 999
+ K = K + 1
+ DO 30 I = K, N
+ T = DD7TPR(I-1, L(J+1), X)
+ J = J + I
+ X(I) = (Y(I) - T)/L(J)
+ 30 CONTINUE
+ 999 RETURN
+C *** LAST CARD OF DL7IVM FOLLOWS ***
+ END
+ SUBROUTINE DD7UPD(D, DR, IV, LIV, LV, N, ND, NN, N2, P, V)
+C
+C *** UPDATE SCALE VECTOR D FOR NL2IT ***
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER LIV, LV, N, ND, NN, N2, P
+ INTEGER IV(LIV)
+ DOUBLE PRECISION D(P), DR(ND,P), V(LV)
+C DIMENSION V(*)
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER D0, I, JCN0, JCN1, JCNI, JTOL0, JTOLI, K, SII
+ DOUBLE PRECISION T, VDFAC
+C
+C *** CONSTANTS ***
+C
+ DOUBLE PRECISION ZERO
+C
+C *** INTRINSIC FUNCTIONS ***
+C/+
+ DOUBLE PRECISION DSQRT
+C/
+C *** EXTERNAL SUBROUTINE ***
+C
+ EXTERNAL DV7SCP
+C
+C DV7SCP... SETS ALL COMPONENTS OF A VECTOR TO A SCALAR.
+C
+C *** SUBSCRIPTS FOR IV AND V ***
+C
+ INTEGER DFAC, DTYPE, JCN, JTOL, NITER, S
+ PARAMETER (DFAC=41, DTYPE=16, JCN=66, JTOL=59, NITER=31, S=62)
+C
+ PARAMETER (ZERO=0.D+0)
+C
+C------------------------------- BODY --------------------------------
+C
+ IF (IV(DTYPE) .NE. 1 .AND. IV(NITER) .GT. 0) GO TO 999
+ JCN1 = IV(JCN)
+ JCN0 = IABS(JCN1) - 1
+ IF (JCN1 .LT. 0) GO TO 10
+ IV(JCN) = -JCN1
+ CALL DV7SCP(P, V(JCN1), ZERO)
+ 10 DO 30 I = 1, P
+ JCNI = JCN0 + I
+ T = V(JCNI)
+ DO 20 K = 1, NN
+ 20 T = DMAX1(T, DABS(DR(K,I)))
+ V(JCNI) = T
+ 30 CONTINUE
+ IF (N2 .LT. N) GO TO 999
+ VDFAC = V(DFAC)
+ JTOL0 = IV(JTOL) - 1
+ D0 = JTOL0 + P
+ SII = IV(S) - 1
+ DO 50 I = 1, P
+ SII = SII + I
+ JCNI = JCN0 + I
+ T = V(JCNI)
+ IF (V(SII) .GT. ZERO) T = DMAX1(DSQRT(V(SII)), T)
+ JTOLI = JTOL0 + I
+ D0 = D0 + 1
+ IF (T .LT. V(JTOLI)) T = DMAX1(V(D0), V(JTOLI))
+ D(I) = DMAX1(VDFAC*D(I), T)
+ 50 CONTINUE
+C
+ 999 RETURN
+C *** LAST CARD OF DD7UPD FOLLOWS ***
+ END
+ SUBROUTINE DV7SHF(N, K, X)
+C
+C *** SHIFT X(K),...,X(N) LEFT CIRCULARLY ONE POSITION ***
+C
+ INTEGER N, K
+ DOUBLE PRECISION X(N)
+C
+ INTEGER I, NM1
+ DOUBLE PRECISION T
+C
+ IF (K .GE. N) GO TO 999
+ NM1 = N - 1
+ T = X(K)
+ DO 10 I = K, NM1
+ 10 X(I) = X(I+1)
+ X(N) = T
+ 999 RETURN
+ END
+ SUBROUTINE DS3GRD(ALPHA, B, D, ETA0, FX, G, IRC, P, W, X)
+C
+C *** COMPUTE FINITE DIFFERENCE GRADIENT BY STWEART*S SCHEME ***
+C
+C *** PARAMETERS ***
+C
+ INTEGER IRC, P
+ DOUBLE PRECISION ALPHA(P), B(2,P), D(P), ETA0, FX, G(P), W(6),
+ 1 X(P)
+C
+C.......................................................................
+C
+C *** PURPOSE ***
+C
+C THIS SUBROUTINE USES AN EMBELLISHED FORM OF THE FINITE-DIFFER-
+C ENCE SCHEME PROPOSED BY STEWART (REF. 1) TO APPROXIMATE THE
+C GRADIENT OF THE FUNCTION F(X), WHOSE VALUES ARE SUPPLIED BY
+C REVERSE COMMUNICATION.
+C
+C *** PARAMETER DESCRIPTION ***
+C
+C ALPHA IN (APPROXIMATE) DIAGONAL ELEMENTS OF THE HESSIAN OF F(X).
+C B IN ARRAY OF SIMPLE LOWER AND UPPER BOUNDS ON X. X MUST
+C SATISFY B(1,I) .LE. X(I) .LE. B(2,I), I = 1(1)P.
+C FOR ALL I WITH B(1,I) .GE. B(2,I), DS3GRD SIMPLY
+C SETS G(I) TO 0.
+C D IN SCALE VECTOR SUCH THAT D(I)*X(I), I = 1,...,P, ARE IN
+C COMPARABLE UNITS.
+C ETA0 IN ESTIMATED BOUND ON RELATIVE ERROR IN THE FUNCTION VALUE...
+C (TRUE VALUE) = (COMPUTED VALUE)*(1+E), WHERE
+C ABS(E) .LE. ETA0.
+C FX I/O ON INPUT, FX MUST BE THE COMPUTED VALUE OF F(X). ON
+C OUTPUT WITH IRC = 0, FX HAS BEEN RESTORED TO ITS ORIGINAL
+C VALUE, THE ONE IT HAD WHEN DS3GRD WAS LAST CALLED WITH
+C IRC = 0.
+C G I/O ON INPUT WITH IRC = 0, G SHOULD CONTAIN AN APPROXIMATION
+C TO THE GRADIENT OF F NEAR X, E.G., THE GRADIENT AT THE
+C PREVIOUS ITERATE. WHEN DS3GRD RETURNS WITH IRC = 0, G IS
+C THE DESIRED FINITE-DIFFERENCE APPROXIMATION TO THE
+C GRADIENT AT X.
+C IRC I/O INPUT/RETURN CODE... BEFORE THE VERY FIRST CALL ON DS3GRD,
+C THE CALLER MUST SET IRC TO 0. WHENEVER DS3GRD RETURNS A
+C NONZERO VALUE (OF AT MOST P) FOR IRC, IT HAS PERTURBED
+C SOME COMPONENT OF X... THE CALLER SHOULD EVALUATE F(X)
+C AND CALL DS3GRD AGAIN WITH FX = F(X). IF B PREVENTS
+C ESTIMATING G(I) I.E., IF THERE IS AN I WITH
+C B(1,I) .LT. B(2,I) BUT WITH B(1,I) SO CLOSE TO B(2,I)
+C THAT THE FINITE-DIFFERENCING STEPS CANNOT BE CHOSEN,
+C THEN DS3GRD RETURNS WITH IRC .GT. P.
+C P IN THE NUMBER OF VARIABLES (COMPONENTS OF X) ON WHICH F
+C DEPENDS.
+C X I/O ON INPUT WITH IRC = 0, X IS THE POINT AT WHICH THE
+C GRADIENT OF F IS DESIRED. ON OUTPUT WITH IRC NONZERO, X
+C IS THE POINT AT WHICH F SHOULD BE EVALUATED. ON OUTPUT
+C WITH IRC = 0, X HAS BEEN RESTORED TO ITS ORIGINAL VALUE
+C (THE ONE IT HAD WHEN DS3GRD WAS LAST CALLED WITH IRC = 0)
+C AND G CONTAINS THE DESIRED GRADIENT APPROXIMATION.
+C W I/O WORK VECTOR OF LENGTH 6 IN WHICH DS3GRD SAVES CERTAIN
+C QUANTITIES WHILE THE CALLER IS EVALUATING F(X) AT A
+C PERTURBED X.
+C
+C *** APPLICATION AND USAGE RESTRICTIONS ***
+C
+C THIS ROUTINE IS INTENDED FOR USE WITH QUASI-NEWTON ROUTINES
+C FOR UNCONSTRAINED MINIMIZATION (IN WHICH CASE ALPHA COMES FROM
+C THE DIAGONAL OF THE QUASI-NEWTON HESSIAN APPROXIMATION).
+C
+C *** ALGORITHM NOTES ***
+C
+C THIS CODE DEPARTS FROM THE SCHEME PROPOSED BY STEWART (REF. 1)
+C IN ITS GUARDING AGAINST OVERLY LARGE OR SMALL STEP SIZES AND ITS
+C HANDLING OF SPECIAL CASES (SUCH AS ZERO COMPONENTS OF ALPHA OR G).
+C
+C *** REFERENCES ***
+C
+C 1. STEWART, G.W. (1967), A MODIFICATION OF DAVIDON*S MINIMIZATION
+C METHOD TO ACCEPT DIFFERENCE APPROXIMATIONS OF DERIVATIVES,
+C J. ASSOC. COMPUT. MACH. 14, PP. 72-83.
+C
+C *** HISTORY ***
+C
+C DESIGNED AND CODED BY DAVID M. GAY (SUMMER 1977/SUMMER 1980).
+C
+C *** GENERAL ***
+C
+C THIS ROUTINE WAS PREPARED IN CONNECTION WITH WORK SUPPORTED BY
+C THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS76-00324 AND
+C MCS-7906671.
+C
+C.......................................................................
+C
+C ***** EXTERNAL FUNCTION *****
+C
+ DOUBLE PRECISION DR7MDC
+ EXTERNAL DR7MDC
+C DR7MDC... RETURNS MACHINE-DEPENDENT CONSTANTS.
+C
+C ***** INTRINSIC FUNCTIONS *****
+C/+
+ DOUBLE PRECISION DSQRT
+C/
+C ***** LOCAL VARIABLES *****
+C
+ LOGICAL HIT
+ INTEGER FH, FX0, HSAVE, I, XISAVE
+ DOUBLE PRECISION AAI, AFX, AFXETA, AGI, ALPHAI, AXI, AXIBAR,
+ 1 DISCON, ETA, GI, H, HMIN, XI, XIH
+ DOUBLE PRECISION C2000, FOUR, HMAX0, HMIN0, H0, MACHEP, ONE, P002,
+ 1 THREE, TWO, ZERO
+C
+ PARAMETER (C2000=2.0D+3, FOUR=4.0D+0, HMAX0=0.02D+0, HMIN0=5.0D+1,
+ 1 ONE=1.0D+0, P002=0.002D+0, THREE=3.0D+0,
+ 2 TWO=2.0D+0, ZERO=0.0D+0)
+ PARAMETER (FH=3, FX0=4, HSAVE=5, XISAVE=6)
+C
+C--------------------------------- BODY ------------------------------
+C
+ IF (IRC .LT. 0) GO TO 80
+ IF (IRC .GT. 0) GO TO 210
+C
+C *** FRESH START -- GET MACHINE-DEPENDENT CONSTANTS ***
+C
+C STORE MACHEP IN W(1) AND H0 IN W(2), WHERE MACHEP IS THE UNIT
+C ROUNDOFF (THE SMALLEST POSITIVE NUMBER SUCH THAT
+C 1 + MACHEP .GT. 1 AND 1 - MACHEP .LT. 1), AND H0 IS THE
+C SQUARE-ROOT OF MACHEP.
+C
+ W(1) = DR7MDC(3)
+ W(2) = DSQRT(W(1))
+C
+ W(FX0) = FX
+C
+C *** INCREMENT I AND START COMPUTING G(I) ***
+C
+ 20 I = IABS(IRC) + 1
+ IF (I .GT. P) GO TO 220
+ IRC = I
+ IF (B(1,I) .LT. B(2,I)) GO TO 30
+ G(I) = ZERO
+ GO TO 20
+ 30 AFX = DABS(W(FX0))
+ MACHEP = W(1)
+ H0 = W(2)
+ HMIN = HMIN0 * MACHEP
+ XI = X(I)
+ W(XISAVE) = XI
+ AXI = DABS(XI)
+ AXIBAR = DMAX1(AXI, ONE/D(I))
+ GI = G(I)
+ AGI = DABS(GI)
+ ETA = DABS(ETA0)
+ IF (AFX .GT. ZERO) ETA = DMAX1(ETA, AGI*AXI*MACHEP/AFX)
+ ALPHAI = ALPHA(I)
+ IF (ALPHAI .EQ. ZERO) GO TO 130
+ IF (GI .EQ. ZERO .OR. FX .EQ. ZERO) GO TO 140
+ AFXETA = AFX*ETA
+ AAI = DABS(ALPHAI)
+C
+C *** COMPUTE H = STEWART*S FORWARD-DIFFERENCE STEP SIZE.
+C
+ IF (GI**2 .LE. AFXETA*AAI) GO TO 40
+ H = TWO*DSQRT(AFXETA/AAI)
+ H = H*(ONE - AAI*H/(THREE*AAI*H + FOUR*AGI))
+ GO TO 50
+C40 H = TWO*(AFXETA*AGI/(AAI**2))**(ONE/THREE)
+ 40 H = TWO * (AFXETA*AGI)**(ONE/THREE) * AAI**(-TWO/THREE)
+ H = H*(ONE - TWO*AGI/(THREE*AAI*H + FOUR*AGI))
+C
+C *** ENSURE THAT H IS NOT INSIGNIFICANTLY SMALL ***
+C
+ 50 H = DMAX1(H, HMIN*AXIBAR)
+C
+C *** USE FORWARD DIFFERENCE IF BOUND ON TRUNCATION ERROR IS AT
+C *** MOST 10**-3.
+C
+ IF (AAI*H .LE. P002*AGI) GO TO 120
+C
+C *** COMPUTE H = STEWART*S STEP FOR CENTRAL DIFFERENCE.
+C
+ DISCON = C2000*AFXETA
+ H = DISCON/(AGI + DSQRT(GI**2 + AAI*DISCON))
+C
+C *** ENSURE THAT H IS NEITHER TOO SMALL NOR TOO BIG ***
+C
+ H = DMAX1(H, HMIN*AXIBAR)
+ IF (H .GE. HMAX0*AXIBAR) H = AXIBAR * H0**(TWO/THREE)
+C
+C *** COMPUTE CENTRAL DIFFERENCE ***
+C
+ XIH = XI + H
+ IF (XI - H .LT. B(1,I)) GO TO 60
+ IRC = -I
+ IF (XIH .LE. B(2,I)) GO TO 200
+ H = -H
+ XIH = XI + H
+ IF (XI + TWO*H .LT. B(1,I)) GO TO 190
+ GO TO 70
+ 60 IF (XI + TWO*H .GT. B(2,I)) GO TO 190
+C *** MUST DO OFF-SIDE CENTRAL DIFFERENCE ***
+ 70 IRC = -(I + P)
+ GO TO 200
+C
+ 80 I = -IRC
+ IF (I .LE. P) GO TO 100
+ I = I - P
+ IF (I .GT. P) GO TO 90
+ W(FH) = FX
+ H = TWO * W(HSAVE)
+ XIH = W(XISAVE) + H
+ IRC = IRC - P
+ GO TO 200
+C
+C *** FINISH OFF-SIDE CENTRAL DIFFERENCE ***
+C
+ 90 I = I - P
+ G(I) = (FOUR*W(FH) - FX - THREE*W(FX0)) / W(HSAVE)
+ IRC = I
+ X(I) = W(XISAVE)
+ GO TO 20
+C
+ 100 H = -W(HSAVE)
+ IF (H .GT. ZERO) GO TO 110
+ W(FH) = FX
+ XIH = W(XISAVE) + H
+ GO TO 200
+C
+ 110 G(I) = (W(FH) - FX) / (TWO * H)
+ X(I) = W(XISAVE)
+ GO TO 20
+C
+C *** COMPUTE FORWARD DIFFERENCES IN VARIOUS CASES ***
+C
+ 120 IF (H .GE. HMAX0*AXIBAR) H = H0 * AXIBAR
+ IF (ALPHAI*GI .LT. ZERO) H = -H
+ GO TO 150
+ 130 H = AXIBAR
+ GO TO 150
+ 140 H = H0 * AXIBAR
+C
+ 150 HIT = .FALSE.
+ 160 XIH = XI + H
+ IF (H .GT. ZERO) GO TO 170
+ IF (XIH .GE. B(1,I)) GO TO 200
+ GO TO 180
+ 170 IF (XIH .LE. B(2,I)) GO TO 200
+ 180 IF (HIT) GO TO 190
+ HIT = .TRUE.
+ H = -H
+ GO TO 160
+C
+C *** ERROR RETURN...
+ 190 IRC = I + P
+ GO TO 230
+C
+C *** RETURN FOR NEW FUNCTION VALUE...
+ 200 X(I) = XIH
+ W(HSAVE) = H
+ GO TO 999
+C
+C *** COMPUTE ACTUAL FORWARD DIFFERENCE ***
+C
+ 210 G(IRC) = (FX - W(FX0)) / W(HSAVE)
+ X(IRC) = W(XISAVE)
+ GO TO 20
+C
+C *** RESTORE FX AND INDICATE THAT G HAS BEEN COMPUTED ***
+C
+ 220 IRC = 0
+ 230 FX = W(FX0)
+C
+ 999 RETURN
+C *** LAST LINE OF DS3GRD FOLLOWS ***
+ END
+ SUBROUTINE DL7UPD(BETA, GAMMA, L, LAMBDA, LPLUS, N, W, Z)
+C
+C *** COMPUTE LPLUS = SECANT UPDATE OF L ***
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER N
+ DOUBLE PRECISION BETA(N), GAMMA(N), L(*), LAMBDA(N), LPLUS(*),
+ 1 W(N), Z(N)
+C DIMENSION L(N*(N+1)/2), LPLUS(N*(N+1)/2)
+C
+C-------------------------- PARAMETER USAGE --------------------------
+C
+C BETA = SCRATCH VECTOR.
+C GAMMA = SCRATCH VECTOR.
+C L (INPUT) LOWER TRIANGULAR MATRIX, STORED ROWWISE.
+C LAMBDA = SCRATCH VECTOR.
+C LPLUS (OUTPUT) LOWER TRIANGULAR MATRIX, STORED ROWWISE, WHICH MAY
+C OCCUPY THE SAME STORAGE AS L.
+C N (INPUT) LENGTH OF VECTOR PARAMETERS AND ORDER OF MATRICES.
+C W (INPUT, DESTROYED ON OUTPUT) RIGHT SINGULAR VECTOR OF RANK 1
+C CORRECTION TO L.
+C Z (INPUT, DESTROYED ON OUTPUT) LEFT SINGULAR VECTOR OF RANK 1
+C CORRECTION TO L.
+C
+C------------------------------- NOTES -------------------------------
+C
+C *** APPLICATION AND USAGE RESTRICTIONS ***
+C
+C THIS ROUTINE UPDATES THE CHOLESKY FACTOR L OF A SYMMETRIC
+C POSITIVE DEFINITE MATRIX TO WHICH A SECANT UPDATE IS BEING
+C APPLIED -- IT COMPUTES A CHOLESKY FACTOR LPLUS OF
+C L * (I + Z*W**T) * (I + W*Z**T) * L**T. IT IS ASSUMED THAT W
+C AND Z HAVE BEEN CHOSEN SO THAT THE UPDATED MATRIX IS STRICTLY
+C POSITIVE DEFINITE.
+C
+C *** ALGORITHM NOTES ***
+C
+C THIS CODE USES RECURRENCE 3 OF REF. 1 (WITH D(J) = 1 FOR ALL J)
+C TO COMPUTE LPLUS OF THE FORM L * (I + Z*W**T) * Q, WHERE Q
+C IS AN ORTHOGONAL MATRIX THAT MAKES THE RESULT LOWER TRIANGULAR.
+C LPLUS MAY HAVE SOME NEGATIVE DIAGONAL ELEMENTS.
+C
+C *** REFERENCES ***
+C
+C 1. GOLDFARB, D. (1976), FACTORIZED VARIABLE METRIC METHODS FOR UNCON-
+C STRAINED OPTIMIZATION, MATH. COMPUT. 30, PP. 796-811.
+C
+C *** GENERAL ***
+C
+C CODED BY DAVID M. GAY (FALL 1979).
+C THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH SUPPORTED
+C BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS MCS-7600324 AND
+C MCS-7906671.
+C
+C------------------------ EXTERNAL QUANTITIES ------------------------
+C
+C *** INTRINSIC FUNCTIONS ***
+C/+
+ DOUBLE PRECISION DSQRT
+C/
+C-------------------------- LOCAL VARIABLES --------------------------
+C
+ INTEGER I, IJ, J, JJ, JP1, K, NM1, NP1
+ DOUBLE PRECISION A, B, BJ, ETA, GJ, LJ, LIJ, LJJ, NU, S, THETA,
+ 1 WJ, ZJ
+ DOUBLE PRECISION ONE, ZERO
+C
+C *** DATA INITIALIZATIONS ***
+C
+ PARAMETER (ONE=1.D+0, ZERO=0.D+0)
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ NU = ONE
+ ETA = ZERO
+ IF (N .LE. 1) GO TO 30
+ NM1 = N - 1
+C
+C *** TEMPORARILY STORE S(J) = SUM OVER K = J+1 TO N OF W(K)**2 IN
+C *** LAMBDA(J).
+C
+ S = ZERO
+ DO 10 I = 1, NM1
+ J = N - I
+ S = S + W(J+1)**2
+ LAMBDA(J) = S
+ 10 CONTINUE
+C
+C *** COMPUTE LAMBDA, GAMMA, AND BETA BY GOLDFARB*S RECURRENCE 3.
+C
+ DO 20 J = 1, NM1
+ WJ = W(J)
+ A = NU*Z(J) - ETA*WJ
+ THETA = ONE + A*WJ
+ S = A*LAMBDA(J)
+ LJ = DSQRT(THETA**2 + A*S)
+ IF (THETA .GT. ZERO) LJ = -LJ
+ LAMBDA(J) = LJ
+ B = THETA*WJ + S
+ GAMMA(J) = B * NU / LJ
+ BETA(J) = (A - B*ETA) / LJ
+ NU = -NU / LJ
+ ETA = -(ETA + (A**2)/(THETA - LJ)) / LJ
+ 20 CONTINUE
+ 30 LAMBDA(N) = ONE + (NU*Z(N) - ETA*W(N))*W(N)
+C
+C *** UPDATE L, GRADUALLY OVERWRITING W AND Z WITH L*W AND L*Z.
+C
+ NP1 = N + 1
+ JJ = N * (N + 1) / 2
+ DO 60 K = 1, N
+ J = NP1 - K
+ LJ = LAMBDA(J)
+ LJJ = L(JJ)
+ LPLUS(JJ) = LJ * LJJ
+ WJ = W(J)
+ W(J) = LJJ * WJ
+ ZJ = Z(J)
+ Z(J) = LJJ * ZJ
+ IF (K .EQ. 1) GO TO 50
+ BJ = BETA(J)
+ GJ = GAMMA(J)
+ IJ = JJ + J
+ JP1 = J + 1
+ DO 40 I = JP1, N
+ LIJ = L(IJ)
+ LPLUS(IJ) = LJ*LIJ + BJ*W(I) + GJ*Z(I)
+ W(I) = W(I) + LIJ*WJ
+ Z(I) = Z(I) + LIJ*ZJ
+ IJ = IJ + I
+ 40 CONTINUE
+ 50 JJ = JJ - J
+ 60 CONTINUE
+C
+ RETURN
+C *** LAST CARD OF DL7UPD FOLLOWS ***
+ END
+ SUBROUTINE DO7PRD(L, LS, P, S, W, Y, Z)
+C
+C *** FOR I = 1..L, SET S = S + W(I)*Y(.,I)*(Z(.,I)**T), I.E.,
+C *** ADD W(I) TIMES THE OUTER PRODUCT OF Y(.,I) AND Z(.,I).
+C
+ INTEGER L, LS, P
+ DOUBLE PRECISION S(LS), W(L), Y(P,L), Z(P,L)
+C DIMENSION S(P*(P+1)/2)
+C
+ INTEGER I, J, K, M
+ DOUBLE PRECISION WK, YI, ZERO
+ DATA ZERO/0.D+0/
+C
+ DO 30 K = 1, L
+ WK = W(K)
+ IF (WK .EQ. ZERO) GO TO 30
+ M = 1
+ DO 20 I = 1, P
+ YI = WK * Y(I,K)
+ DO 10 J = 1, I
+ S(M) = S(M) + YI*Z(J,K)
+ M = M + 1
+ 10 CONTINUE
+ 20 CONTINUE
+ 30 CONTINUE
+C
+ RETURN
+C *** LAST CARD OF DO7PRD FOLLOWS ***
+ END
+ SUBROUTINE DV7VMP(N, X, Y, Z, K)
+C
+C *** SET X(I) = Y(I) * Z(I)**K, 1 .LE. I .LE. N (FOR K = 1 OR -1) ***
+C
+ INTEGER N, K
+ DOUBLE PRECISION X(N), Y(N), Z(N)
+ INTEGER I
+C
+ IF (K .GE. 0) GO TO 20
+ DO 10 I = 1, N
+ 10 X(I) = Y(I) / Z(I)
+ GO TO 999
+C
+ 20 DO 30 I = 1, N
+ 30 X(I) = Y(I) * Z(I)
+ 999 RETURN
+C *** LAST CARD OF DV7VMP FOLLOWS ***
+ END
+ SUBROUTINE DSM(M,N,NPAIRS,INDROW,INDCOL,NGRP,MAXGRP,MINGRP,
+ * INFO,IPNTR,JPNTR,IWA,LIWA,BWA)
+ INTEGER M,N,NPAIRS,MAXGRP,MINGRP,INFO,LIWA
+ INTEGER INDROW(NPAIRS),INDCOL(NPAIRS),NGRP(N),
+ * IPNTR(1),JPNTR(1),IWA(LIWA)
+ LOGICAL BWA(N)
+C **********
+C
+C SUBROUTINE DSM
+C
+C THE PURPOSE OF DSM IS TO DETERMINE AN OPTIMAL OR NEAR-
+C OPTIMAL CONSISTENT PARTITION OF THE COLUMNS OF A SPARSE
+C M BY N MATRIX A.
+C
+C THE SPARSITY PATTERN OF THE MATRIX A IS SPECIFIED BY
+C THE ARRAYS INDROW AND INDCOL. ON INPUT THE INDICES
+C FOR THE NON-ZERO ELEMENTS OF A ARE
+C
+C INDROW(K),INDCOL(K), K = 1,2,...,NPAIRS.
+C
+C THE (INDROW,INDCOL) PAIRS MAY BE SPECIFIED IN ANY ORDER.
+C DUPLICATE INPUT PAIRS ARE PERMITTED, BUT THE SUBROUTINE
+C ELIMINATES THEM.
+C
+C THE SUBROUTINE PARTITIONS THE COLUMNS OF A INTO GROUPS
+C SUCH THAT COLUMNS IN THE SAME GROUP DO NOT HAVE A
+C NON-ZERO IN THE SAME ROW POSITION. A PARTITION OF THE
+C COLUMNS OF A WITH THIS PROPERTY IS CONSISTENT WITH THE
+C DIRECT DETERMINATION OF A.
+C
+C THE SUBROUTINE STATEMENT IS
+C
+C SUBROUTINE DSM(M,N,NPAIRS,INDROW,INDCOL,NGRP,MAXGRP,MINGRP,
+C INFO,IPNTR,JPNTR,IWA,LIWA,BWA)
+C
+C WHERE
+C
+C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C OF ROWS OF A.
+C
+C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C OF COLUMNS OF A.
+C
+C NPAIRS IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE
+C NUMBER OF (INDROW,INDCOL) PAIRS USED TO DESCRIBE THE
+C SPARSITY PATTERN OF A.
+C
+C INDROW IS AN INTEGER ARRAY OF LENGTH NPAIRS. ON INPUT INDROW
+C MUST CONTAIN THE ROW INDICES OF THE NON-ZERO ELEMENTS OF A.
+C ON OUTPUT INDROW IS PERMUTED SO THAT THE CORRESPONDING
+C COLUMN INDICES ARE IN NON-DECREASING ORDER. THE COLUMN
+C INDICES CAN BE RECOVERED FROM THE ARRAY JPNTR.
+C
+C INDCOL IS AN INTEGER ARRAY OF LENGTH NPAIRS. ON INPUT INDCOL
+C MUST CONTAIN THE COLUMN INDICES OF THE NON-ZERO ELEMENTS OF
+C A. ON OUTPUT INDCOL IS PERMUTED SO THAT THE CORRESPONDING
+C ROW INDICES ARE IN NON-DECREASING ORDER. THE ROW INDICES
+C CAN BE RECOVERED FROM THE ARRAY IPNTR.
+C
+C NGRP IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH SPECIFIES
+C THE PARTITION OF THE COLUMNS OF A. COLUMN JCOL BELONGS
+C TO GROUP NGRP(JCOL).
+C
+C MAXGRP IS AN INTEGER OUTPUT VARIABLE WHICH SPECIFIES THE
+C NUMBER OF GROUPS IN THE PARTITION OF THE COLUMNS OF A.
+C
+C MINGRP IS AN INTEGER OUTPUT VARIABLE WHICH SPECIFIES A LOWER
+C BOUND FOR THE NUMBER OF GROUPS IN ANY CONSISTENT PARTITION
+C OF THE COLUMNS OF A.
+C
+C INFO IS AN INTEGER OUTPUT VARIABLE SET AS FOLLOWS. FOR
+C NORMAL TERMINATION INFO = 1. IF M, N, OR NPAIRS IS NOT
+C POSITIVE OR LIWA IS LESS THAN MAX(M,6*N), THEN INFO = 0.
+C IF THE K-TH ELEMENT OF INDROW IS NOT AN INTEGER BETWEEN
+C 1 AND M OR THE K-TH ELEMENT OF INDCOL IS NOT AN INTEGER
+C BETWEEN 1 AND N, THEN INFO = -K.
+C
+C IPNTR IS AN INTEGER OUTPUT ARRAY OF LENGTH M + 1 WHICH
+C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL.
+C THE COLUMN INDICES FOR ROW I ARE
+C
+C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1.
+C
+C NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO
+C ELEMENTS OF THE MATRIX A.
+C
+C JPNTR IS AN INTEGER OUTPUT ARRAY OF LENGTH N + 1 WHICH
+C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW.
+C THE ROW INDICES FOR COLUMN J ARE
+C
+C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1.
+C
+C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO
+C ELEMENTS OF THE MATRIX A.
+C
+C IWA IS AN INTEGER WORK ARRAY OF LENGTH LIWA.
+C
+C LIWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
+C MAX(M,6*N).
+C
+C BWA IS A LOGICAL WORK ARRAY OF LENGTH N.
+C
+C SUBPROGRAMS CALLED
+C
+C MINPACK-SUPPLIED ...D7EGR,I7DO,N7MSRT,M7SEQ,S7ETR,M7SLO,S7RTDT
+C
+C FORTRAN-SUPPLIED ... MAX0
+C
+C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982.
+C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE
+C
+C **********
+ INTEGER I,IR,J,JP,JPL,JPU,K,MAXCLQ,NNZ,NUMGRP
+C
+C CHECK THE INPUT DATA.
+C
+ INFO = 0
+ IF (M .LT. 1 .OR. N .LT. 1 .OR. NPAIRS .LT. 1 .OR.
+ * LIWA .LT. MAX0(M,6*N)) GO TO 130
+ DO 10 K = 1, NPAIRS
+ INFO = -K
+ IF (INDROW(K) .LT. 1 .OR. INDROW(K) .GT. M .OR.
+ * INDCOL(K) .LT. 1 .OR. INDCOL(K) .GT. N) GO TO 130
+ 10 CONTINUE
+ INFO = 1
+C
+C SORT THE DATA STRUCTURE BY COLUMNS.
+C
+ CALL S7RTDT(N,NPAIRS,INDROW,INDCOL,JPNTR,IWA(1))
+C
+C COMPRESS THE DATA AND DETERMINE THE NUMBER OF
+C NON-ZERO ELEMENTS OF A.
+C
+ DO 20 I = 1, M
+ IWA(I) = 0
+ 20 CONTINUE
+ NNZ = 0
+ DO 70 J = 1, N
+ JPL = JPNTR(J)
+ JPU = JPNTR(J+1) - 1
+ JPNTR(J) = NNZ + 1
+ IF (JPU .LT. JPL) GO TO 60
+ DO 40 JP = JPL, JPU
+ IR = INDROW(JP)
+ IF (IWA(IR) .NE. 0) GO TO 30
+ NNZ = NNZ + 1
+ INDROW(NNZ) = IR
+ IWA(IR) = 1
+ 30 CONTINUE
+ 40 CONTINUE
+ JPL = JPNTR(J)
+ DO 50 JP = JPL, NNZ
+ IR = INDROW(JP)
+ IWA(IR) = 0
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ JPNTR(N+1) = NNZ + 1
+C
+C EXTEND THE DATA STRUCTURE TO ROWS.
+C
+ CALL S7ETR(M,N,INDROW,JPNTR,INDCOL,IPNTR,IWA(1))
+C
+C DETERMINE A LOWER BOUND FOR THE NUMBER OF GROUPS.
+C
+ MINGRP = 0
+ DO 80 I = 1, M
+ MINGRP = MAX0(MINGRP,IPNTR(I+1)-IPNTR(I))
+ 80 CONTINUE
+C
+C DETERMINE THE DEGREE SEQUENCE FOR THE INTERSECTION
+C GRAPH OF THE COLUMNS OF A.
+C
+ CALL D7EGR(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(5*N+1),IWA(N+1),BWA)
+C
+C COLOR THE INTERSECTION GRAPH OF THE COLUMNS OF A
+C WITH THE SMALLEST-LAST (SL) ORDERING.
+C
+ CALL M7SLO(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(5*N+1),IWA(4*N+1),
+ * MAXCLQ,IWA(1),IWA(N+1),IWA(2*N+1),IWA(3*N+1),BWA)
+ CALL M7SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(4*N+1),NGRP,MAXGRP,
+ * IWA(N+1),BWA)
+ MINGRP = MAX0(MINGRP,MAXCLQ)
+ IF (MAXGRP .EQ. MINGRP) GO TO 130
+C
+C COLOR THE INTERSECTION GRAPH OF THE COLUMNS OF A
+C WITH THE INCIDENCE-DEGREE (ID) ORDERING.
+C
+ CALL I7DO(M,N,INDROW,JPNTR,INDCOL,IPNTR,IWA(5*N+1),IWA(4*N+1),
+ * MAXCLQ,IWA(1),IWA(N+1),IWA(2*N+1),IWA(3*N+1),BWA)
+ CALL M7SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(4*N+1),IWA(1),NUMGRP,
+ * IWA(N+1),BWA)
+ MINGRP = MAX0(MINGRP,MAXCLQ)
+ IF (NUMGRP .GE. MAXGRP) GO TO 100
+ MAXGRP = NUMGRP
+ DO 90 J = 1, N
+ NGRP(J) = IWA(J)
+ 90 CONTINUE
+ IF (MAXGRP .EQ. MINGRP) GO TO 130
+ 100 CONTINUE
+C
+C COLOR THE INTERSECTION GRAPH OF THE COLUMNS OF A
+C WITH THE LARGEST-FIRST (LF) ORDERING.
+C
+ CALL N7MSRT(N,N-1,IWA(5*N+1),-1,IWA(4*N+1),IWA(2*N+1),IWA(N+1))
+ CALL M7SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,IWA(4*N+1),IWA(1),NUMGRP,
+ * IWA(N+1),BWA)
+ IF (NUMGRP .GE. MAXGRP) GO TO 120
+ MAXGRP = NUMGRP
+ DO 110 J = 1, N
+ NGRP(J) = IWA(J)
+ 110 CONTINUE
+ 120 CONTINUE
+C
+C EXIT FROM PROGRAM.
+C
+ 130 CONTINUE
+ RETURN
+C
+C LAST CARD OF SUBROUTINE DSM.
+C
+ END
+ SUBROUTINE M7SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,LIST,NGRP,MAXGRP,
+ * IWA,BWA)
+ INTEGER N,MAXGRP
+ INTEGER INDROW(1),JPNTR(1),INDCOL(1),IPNTR(1),LIST(N),NGRP(N),
+ * IWA(N)
+ LOGICAL BWA(N)
+C **********
+C
+C SUBROUTINE M7SEQ
+C
+C GIVEN THE SPARSITY PATTERN OF AN M BY N MATRIX A, THIS
+C SUBROUTINE DETERMINES A CONSISTENT PARTITION OF THE
+C COLUMNS OF A BY A SEQUENTIAL ALGORITHM.
+C
+C A CONSISTENT PARTITION IS DEFINED IN TERMS OF THE LOOPLESS
+C GRAPH G WITH VERTICES A(J), J = 1,2,...,N WHERE A(J) IS THE
+C J-TH COLUMN OF A AND WITH EDGE (A(I),A(J)) IF AND ONLY IF
+C COLUMNS I AND J HAVE A NON-ZERO IN THE SAME ROW POSITION.
+C
+C A PARTITION OF THE COLUMNS OF A INTO GROUPS IS CONSISTENT
+C IF THE COLUMNS IN ANY GROUP ARE NOT ADJACENT IN THE GRAPH G.
+C IN GRAPH-THEORY TERMINOLOGY, A CONSISTENT PARTITION OF THE
+C COLUMNS OF A CORRESPONDS TO A COLORING OF THE GRAPH G.
+C
+C THE SUBROUTINE EXAMINES THE COLUMNS IN THE ORDER SPECIFIED
+C BY THE ARRAY LIST, AND ASSIGNS THE CURRENT COLUMN TO THE
+C GROUP WITH THE SMALLEST POSSIBLE NUMBER.
+C
+C NOTE THAT THE VALUE OF M IS NOT NEEDED BY M7SEQ AND IS
+C THEREFORE NOT PRESENT IN THE SUBROUTINE STATEMENT.
+C
+C THE SUBROUTINE STATEMENT IS
+C
+C SUBROUTINE M7SEQ(N,INDROW,JPNTR,INDCOL,IPNTR,LIST,NGRP,MAXGRP,
+C IWA,BWA)
+C
+C WHERE
+C
+C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
+C OF COLUMNS OF A.
+C
+C INDROW IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE ROW
+C INDICES FOR THE NON-ZEROES IN THE MATRIX A.
+C
+C JPNTR IS AN INTEGER INPUT ARRAY OF LENGTH N + 1 WHICH
+C SPECIFIES THE LOCATIONS OF THE ROW INDICES IN INDROW.
+C THE ROW INDICES FOR COLUMN J ARE
+C
+C INDROW(K), K = JPNTR(J),...,JPNTR(J+1)-1.
+C
+C NOTE THAT JPNTR(N+1)-1 IS THEN THE NUMBER OF NON-ZERO
+C ELEMENTS OF THE MATRIX A.
+C
+C INDCOL IS AN INTEGER INPUT ARRAY WHICH CONTAINS THE
+C COLUMN INDICES FOR THE NON-ZEROES IN THE MATRIX A.
+C
+C IPNTR IS AN INTEGER INPUT ARRAY OF LENGTH M + 1 WHICH
+C SPECIFIES THE LOCATIONS OF THE COLUMN INDICES IN INDCOL.
+C THE COLUMN INDICES FOR ROW I ARE
+C
+C INDCOL(K), K = IPNTR(I),...,IPNTR(I+1)-1.
+C
+C NOTE THAT IPNTR(M+1)-1 IS THEN THE NUMBER OF NON-ZERO
+C ELEMENTS OF THE MATRIX A.
+C
+C LIST IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH SPECIFIES
+C THE ORDER TO BE USED BY THE SEQUENTIAL ALGORITHM.
+C THE J-TH COLUMN IN THIS ORDER IS LIST(J).
+C
+C NGRP IS AN INTEGER OUTPUT ARRAY OF LENGTH N WHICH SPECIFIES
+C THE PARTITION OF THE COLUMNS OF A. COLUMN JCOL BELONGS
+C TO GROUP NGRP(JCOL).
+C
+C MAXGRP IS AN INTEGER OUTPUT VARIABLE WHICH SPECIFIES THE
+C NUMBER OF GROUPS IN THE PARTITION OF THE COLUMNS OF A.
+C
+C IWA IS AN INTEGER WORK ARRAY OF LENGTH N.
+C
+C BWA IS A LOGICAL WORK ARRAY OF LENGTH N.
+C
+C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. JUNE 1982.
+C THOMAS F. COLEMAN, BURTON S. GARBOW, JORGE J. MORE
+C
+C **********
+ INTEGER DEG,IC,IP,IPL,IPU,IR,J,JCOL,JP,JPL,JPU,L,NUMGRP
+C
+C INITIALIZATION BLOCK.
+C
+ MAXGRP = 0
+ DO 10 JP = 1, N
+ NGRP(JP) = N
+ BWA(JP) = .FALSE.
+ 10 CONTINUE
+ BWA(N) = .TRUE.
+C
+C BEGINNING OF ITERATION LOOP.
+C
+ DO 100 J = 1, N
+ JCOL = LIST(J)
+C
+C FIND ALL COLUMNS ADJACENT TO COLUMN JCOL.
+C
+ DEG = 0
+C
+C DETERMINE ALL POSITIONS (IR,JCOL) WHICH CORRESPOND
+C TO NON-ZEROES IN THE MATRIX.
+C
+ JPL = JPNTR(JCOL)
+ JPU = JPNTR(JCOL+1) - 1
+ IF (JPU .LT. JPL) GO TO 50
+ DO 40 JP = JPL, JPU
+ IR = INDROW(JP)
+C
+C FOR EACH ROW IR, DETERMINE ALL POSITIONS (IR,IC)
+C WHICH CORRESPOND TO NON-ZEROES IN THE MATRIX.
+C
+ IPL = IPNTR(IR)
+ IPU = IPNTR(IR+1) - 1
+ DO 30 IP = IPL, IPU
+ IC = INDCOL(IP)
+ L = NGRP(IC)
+C
+C ARRAY BWA MARKS THE GROUP NUMBERS OF THE
+C COLUMNS WHICH ARE ADJACENT TO COLUMN JCOL.
+C ARRAY IWA RECORDS THE MARKED GROUP NUMBERS.
+C
+ IF (BWA(L)) GO TO 20
+ BWA(L) = .TRUE.
+ DEG = DEG + 1
+ IWA(DEG) = L
+ 20 CONTINUE
+ 30 CONTINUE
+ 40 CONTINUE
+ 50 CONTINUE
+C
+C ASSIGN THE SMALLEST UN-MARKED GROUP NUMBER TO JCOL.
+C
+ DO 60 JP = 1, N
+ NUMGRP = JP
+ IF (.NOT. BWA(JP)) GO TO 70
+ 60 CONTINUE
+ 70 CONTINUE
+ NGRP(JCOL) = NUMGRP
+ MAXGRP = MAX0(MAXGRP,NUMGRP)
+C
+C UN-MARK THE GROUP NUMBERS.
+C
+ IF (DEG .LT. 1) GO TO 90
+ DO 80 JP = 1, DEG
+ L = IWA(JP)
+ BWA(L) = .FALSE.
+ 80 CONTINUE
+ 90 CONTINUE
+ 100 CONTINUE
+C
+C END OF ITERATION LOOP.
+C
+ RETURN
+C
+C LAST CARD OF SUBROUTINE M7SEQ.
+C
+ END
+ SUBROUTINE DL7TSQ(N, A, L)
+C
+C *** SET A TO LOWER TRIANGLE OF (L**T) * L ***
+C
+C *** L = N X N LOWER TRIANG. MATRIX STORED ROWWISE. ***
+C *** A IS ALSO STORED ROWWISE AND MAY SHARE STORAGE WITH L. ***
+C
+ INTEGER N
+ DOUBLE PRECISION A(*), L(*)
+C DIMENSION A(N*(N+1)/2), L(N*(N+1)/2)
+C
+ INTEGER I, II, IIM1, I1, J, K, M
+ DOUBLE PRECISION LII, LJ
+C
+ II = 0
+ DO 50 I = 1, N
+ I1 = II + 1
+ II = II + I
+ M = 1
+ IF (I .EQ. 1) GO TO 30
+ IIM1 = II - 1
+ DO 20 J = I1, IIM1
+ LJ = L(J)
+ DO 10 K = I1, J
+ A(M) = A(M) + LJ*L(K)
+ M = M + 1
+ 10 CONTINUE
+ 20 CONTINUE
+ 30 LII = L(II)
+ DO 40 J = I1, II
+ 40 A(J) = LII * L(J)
+ 50 CONTINUE
+C
+ RETURN
+C *** LAST CARD OF DL7TSQ FOLLOWS ***
+ END
+ DOUBLE PRECISION FUNCTION DRLDST(P, D, X, X0)
+C
+C *** COMPUTE AND RETURN RELATIVE DIFFERENCE BETWEEN X AND X0 ***
+C *** NL2SOL VERSION 2.2 ***
+C
+ INTEGER P
+ DOUBLE PRECISION D(P), X(P), X0(P)
+C
+ INTEGER I
+ DOUBLE PRECISION EMAX, T, XMAX, ZERO
+ PARAMETER (ZERO=0.D+0)
+C
+C *** BODY ***
+C
+ EMAX = ZERO
+ XMAX = ZERO
+ DO 10 I = 1, P
+ T = DABS(D(I) * (X(I) - X0(I)))
+ IF (EMAX .LT. T) EMAX = T
+ T = D(I) * (DABS(X(I)) + DABS(X0(I)))
+ IF (XMAX .LT. T) XMAX = T
+ 10 CONTINUE
+ DRLDST = ZERO
+ IF (XMAX .GT. ZERO) DRLDST = EMAX / XMAX
+ RETURN
+C *** LAST CARD OF DRLDST FOLLOWS ***
+ END
+ SUBROUTINE DRN2GB(B, D, DR, IV, LIV, LV, N, ND, N1, N2, P, R,
+ 1 RD, V, X)
+C
+C *** REVISED ITERATION DRIVER FOR NL2SOL WITH SIMPLE BOUNDS ***
+C
+ INTEGER LIV, LV, N, ND, N1, N2, P
+ INTEGER IV(LIV)
+ DOUBLE PRECISION B(2,P), D(P), DR(ND,P), R(ND), RD(ND), V(LV),
+ 1 X(P)
+C
+C-------------------------- PARAMETER USAGE --------------------------
+C
+C B........ BOUNDS ON X.
+C D........ SCALE VECTOR.
+C DR....... DERIVATIVES OF R AT X.
+C IV....... INTEGER VALUES ARRAY.
+C LIV...... LENGTH OF IV... LIV MUST BE AT LEAST 4*P + 82.
+C LV....... LENGTH OF V... LV MUST BE AT LEAST 105 + P*(2*P+20).
+C N........ TOTAL NUMBER OF RESIDUALS.
+C ND....... MAX. NO. OF RESIDUALS PASSED ON ONE CALL.
+C N1....... LOWEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME.
+C N2....... HIGHEST ROW INDEX FOR RESIDUALS SUPPLIED THIS TIME.
+C P........ NUMBER OF PARAMETERS (COMPONENTS OF X) BEING ESTIMATED.
+C R........ RESIDUALS.
+C V........ FLOATING-POINT VALUES ARRAY.
+C X........ PARAMETER VECTOR BEING ESTIMATED (INPUT = INITIAL GUESS,
+C OUTPUT = BEST VALUE FOUND).
+C
+C *** DISCUSSION ***
+C
+C THIS ROUTINE CARRIES OUT ITERATIONS FOR SOLVING NONLINEAR
+C LEAST SQUARES PROBLEMS. IT IS SIMILAR TO DRN2G, EXCEPT THAT
+C THIS ROUTINE ENFORCES THE BOUNDS B(1,I) .LE. X(I) .LE. B(2,I),
+C I = 1(1)P.
+C
+C *** GENERAL ***
+C
+C CODED BY DAVID M. GAY.
+C
+C+++++++++++++++++++++++++++++ DECLARATIONS ++++++++++++++++++++++++++
+C
+C *** EXTERNAL FUNCTIONS AND SUBROUTINES ***
+C
+ DOUBLE PRECISION DD7TPR, DV2NRM
+ EXTERNAL DIVSET, DD7TPR,DD7UPD, DG7ITB,DITSUM,DL7VML, DQ7APL,
+ 1 DQ7RAD, DR7TVM,DV7CPY, DV7SCP, DV2NRM
+C
+C DIVSET.... PROVIDES DEFAULT IV AND V INPUT COMPONENTS.
+C DD7TPR... COMPUTES INNER PRODUCT OF TWO VECTORS.
+C DD7UPD... UPDATES SCALE VECTOR D.
+C DG7ITB... PERFORMS BASIC MINIMIZATION ALGORITHM.
+C DITSUM.... PRINTS ITERATION SUMMARY, INFO ABOUT INITIAL AND FINAL X.
+C DL7VML.... COMPUTES L * V, V = VECTOR, L = LOWER TRIANGULAR MATRIX.
+C DQ7APL... APPLIES QR TRANSFORMATIONS STORED BY DQ7RAD.
+C DQ7RAD.... ADDS A NEW BLOCK OF ROWS TO QR DECOMPOSITION.
+C DR7TVM... MULT. VECTOR BY TRANS. OF UPPER TRIANG. MATRIX FROM QR FACT.
+C DV7CPY.... COPIES ONE VECTOR TO ANOTHER.
+C DV7SCP... SETS ALL ELEMENTS OF A VECTOR TO A SCALAR.
+C DV2NRM... RETURNS THE 2-NORM OF A VECTOR.
+C
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER G1, GI, I, IV1, IVMODE, JTOL1, L, LH, NN, QTR1,
+ 1 RD1, RMAT1, YI, Y1
+ DOUBLE PRECISION T
+C
+ DOUBLE PRECISION HALF, ZERO
+C
+C *** SUBSCRIPTS FOR IV AND V ***
+C
+ INTEGER DINIT, DTYPE, DTINIT, D0INIT, F, G, JCN, JTOL, MODE,
+ 1 NEXTV, NF0, NF00, NF1, NFCALL, NFCOV, NFGCAL, QTR, RDREQ,
+ 1 REGD, RESTOR, RLIMIT, RMAT, TOOBIG, VNEED
+C
+C *** IV SUBSCRIPT VALUES ***
+C
+ PARAMETER (DTYPE=16, G=28, JCN=66, JTOL=59, MODE=35, NEXTV=47,
+ 1 NF0=68, NF00=81, NF1=69, NFCALL=6, NFCOV=52, NFGCAL=7,
+ 2 QTR=77, RDREQ=57, RESTOR=9, REGD=67, RMAT=78, TOOBIG=2,
+ 3 VNEED=4)
+C
+C *** V SUBSCRIPT VALUES ***
+C
+ PARAMETER (DINIT=38, DTINIT=39, D0INIT=40, F=10, RLIMIT=46)
+ PARAMETER (HALF=0.5D+0, ZERO=0.D+0)
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ LH = P * (P+1) / 2
+ IF (IV(1) .EQ. 0) CALL DIVSET(1, IV, LIV, LV, V)
+ IV1 = IV(1)
+ IF (IV1 .GT. 2) GO TO 10
+ NN = N2 - N1 + 1
+ IV(RESTOR) = 0
+ I = IV1 + 4
+ IF (IV(TOOBIG) .EQ. 0) GO TO (150, 130, 150, 120, 120, 150), I
+ IF (I .NE. 5) IV(1) = 2
+ GO TO 40
+C
+C *** FRESH START OR RESTART -- CHECK INPUT INTEGERS ***
+C
+ 10 IF (ND .LE. 0) GO TO 220
+ IF (P .LE. 0) GO TO 220
+ IF (N .LE. 0) GO TO 220
+ IF (IV1 .EQ. 14) GO TO 30
+ IF (IV1 .GT. 16) GO TO 270
+ IF (IV1 .LT. 12) GO TO 40
+ IF (IV1 .EQ. 12) IV(1) = 13
+ IF (IV(1) .NE. 13) GO TO 20
+ IV(VNEED) = IV(VNEED) + P*(P+15)/2
+ 20 CALL DG7ITB(B, D, X, IV, LIV, LV, P, P, V, X, X)
+ IF (IV(1) .NE. 14) GO TO 999
+C
+C *** STORAGE ALLOCATION ***
+C
+ IV(G) = IV(NEXTV)
+ IV(JCN) = IV(G) + 2*P
+ IV(RMAT) = IV(JCN) + P
+ IV(QTR) = IV(RMAT) + LH
+ IV(JTOL) = IV(QTR) + 2*P
+ IV(NEXTV) = IV(JTOL) + 2*P
+C *** TURN OFF COVARIANCE COMPUTATION ***
+ IV(RDREQ) = 0
+ IF (IV1 .EQ. 13) GO TO 999
+C
+ 30 JTOL1 = IV(JTOL)
+ IF (V(DINIT) .GE. ZERO) CALL DV7SCP(P, D, V(DINIT))
+ IF (V(DTINIT) .GT. ZERO) CALL DV7SCP(P, V(JTOL1), V(DTINIT))
+ I = JTOL1 + P
+ IF (V(D0INIT) .GT. ZERO) CALL DV7SCP(P, V(I), V(D0INIT))
+ IV(NF0) = 0
+ IV(NF1) = 0
+ IF (ND .GE. N) GO TO 40
+C
+C *** SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT EVALUATION
+C *** -- ASK FOR BOTH RESIDUAL AND JACOBIAN AT ONCE
+C
+ G1 = IV(G)
+ Y1 = G1 + P
+ CALL DG7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
+ IF (IV(1) .NE. 1) GO TO 260
+ V(F) = ZERO
+ CALL DV7SCP(P, V(G1), ZERO)
+ IV(1) = -1
+ QTR1 = IV(QTR)
+ CALL DV7SCP(P, V(QTR1), ZERO)
+ IV(REGD) = 0
+ RMAT1 = IV(RMAT)
+ GO TO 100
+C
+ 40 G1 = IV(G)
+ Y1 = G1 + P
+ CALL DG7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
+ IF (IV(1) .EQ. 2) GO TO 60
+ IF (IV(1) .GT. 2) GO TO 260
+C
+ V(F) = ZERO
+ IF (IV(NF1) .EQ. 0) GO TO 240
+ IF (IV(RESTOR) .NE. 2) GO TO 240
+ IV(NF0) = IV(NF1)
+ CALL DV7CPY(N, RD, R)
+ IV(REGD) = 0
+ GO TO 240
+C
+ 60 CALL DV7SCP(P, V(G1), ZERO)
+ IF (IV(MODE) .GT. 0) GO TO 230
+ RMAT1 = IV(RMAT)
+ QTR1 = IV(QTR)
+ RD1 = QTR1 + P
+ CALL DV7SCP(P, V(QTR1), ZERO)
+ IV(REGD) = 0
+ IF (ND .LT. N) GO TO 90
+ IF (N1 .NE. 1) GO TO 90
+ IF (IV(MODE) .LT. 0) GO TO 100
+ IF (IV(NF1) .EQ. IV(NFGCAL)) GO TO 70
+ IF (IV(NF0) .NE. IV(NFGCAL)) GO TO 90
+ CALL DV7CPY(N, R, RD)
+ GO TO 80
+ 70 CALL DV7CPY(N, RD, R)
+ 80 CALL DQ7APL(ND, N, P, DR, RD, 0)
+ CALL DR7TVM(ND, MIN0(N,P), V(Y1), V(RD1), DR, RD)
+ IV(REGD) = 0
+ GO TO 110
+C
+ 90 IV(1) = -2
+ IF (IV(MODE) .LT. 0) IV(1) = -3
+ 100 CALL DV7SCP(P, V(Y1), ZERO)
+ 110 CALL DV7SCP(LH, V(RMAT1), ZERO)
+ GO TO 240
+C
+C *** COMPUTE F(X) ***
+C
+ 120 T = DV2NRM(NN, R)
+ IF (T .GT. V(RLIMIT)) GO TO 210
+ V(F) = V(F) + HALF * T**2
+ IF (N2 .LT. N) GO TO 250
+ IF (N1 .EQ. 1) IV(NF1) = IV(NFCALL)
+ GO TO 40
+C
+C *** COMPUTE Y ***
+C
+ 130 Y1 = IV(G) + P
+ YI = Y1
+ DO 140 L = 1, P
+ V(YI) = V(YI) + DD7TPR(NN, DR(1,L), R)
+ YI = YI + 1
+ 140 CONTINUE
+ IF (N2 .LT. N) GO TO 250
+ IV(1) = 2
+ IF (N1 .GT. 1) IV(1) = -3
+ GO TO 240
+C
+C *** COMPUTE GRADIENT INFORMATION ***
+C
+ 150 G1 = IV(G)
+ IVMODE = IV(MODE)
+ IF (IVMODE .LT. 0) GO TO 170
+ IF (IVMODE .EQ. 0) GO TO 180
+ IV(1) = 2
+C
+C *** COMPUTE GRADIENT ONLY (FOR USE IN COVARIANCE COMPUTATION) ***
+C
+ GI = G1
+ DO 160 L = 1, P
+ V(GI) = V(GI) + DD7TPR(NN, R, DR(1,L))
+ GI = GI + 1
+ 160 CONTINUE
+ GO TO 200
+C
+C *** COMPUTE INITIAL FUNCTION VALUE WHEN ND .LT. N ***
+C
+ 170 IF (N .LE. ND) GO TO 180
+ T = DV2NRM(NN, R)
+ IF (T .GT. V(RLIMIT)) GO TO 210
+ V(F) = V(F) + HALF * T**2
+C
+C *** UPDATE D IF DESIRED ***
+C
+ 180 IF (IV(DTYPE) .GT. 0)
+ 1 CALL DD7UPD(D, DR, IV, LIV, LV, N, ND, NN, N2, P, V)
+C
+C *** COMPUTE RMAT AND QTR ***
+C
+ QTR1 = IV(QTR)
+ RMAT1 = IV(RMAT)
+ CALL DQ7RAD(NN, ND, P, V(QTR1), .TRUE., V(RMAT1), DR, R)
+ IV(NF1) = 0
+ IF (N1 .GT. 1) GO TO 200
+ IF (N2 .LT. N) GO TO 250
+C
+C *** SAVE DIAGONAL OF R FOR COMPUTING Y LATER ***
+C
+ RD1 = QTR1 + P
+ L = RMAT1 - 1
+ DO 190 I = 1, P
+ L = L + I
+ V(RD1) = V(L)
+ RD1 = RD1 + 1
+ 190 CONTINUE
+C
+ 200 IF (N2 .LT. N) GO TO 250
+ IF (IVMODE .GT. 0) GO TO 40
+ IV(NF00) = IV(NFGCAL)
+C
+C *** COMPUTE G FROM RMAT AND QTR ***
+C
+ CALL DL7VML(P, V(G1), V(RMAT1), V(QTR1))
+ IV(1) = 2
+ IF (IVMODE .EQ. 0) GO TO 40
+ IF (N .LE. ND) GO TO 40
+C
+C *** FINISH SPECIAL CASE HANDLING OF FIRST FUNCTION AND GRADIENT
+C
+ Y1 = G1 + P
+ IV(1) = 1
+ CALL DG7ITB(B, D, V(G1), IV, LIV, LV, P, P, V, X, V(Y1))
+ IF (IV(1) .NE. 2) GO TO 260
+ GO TO 40
+C
+C *** MISC. DETAILS ***
+C
+C *** X IS OUT OF RANGE (OVERSIZE STEP) ***
+C
+ 210 IV(TOOBIG) = 1
+ GO TO 40
+C
+C *** BAD N, ND, OR P ***
+C
+ 220 IV(1) = 66
+ GO TO 270
+C
+C *** RECORD EXTRA EVALUATIONS FOR FINITE-DIFFERENCE HESSIAN ***
+C
+ 230 IV(NFCOV) = IV(NFCOV) + 1
+ IV(NFCALL) = IV(NFCALL) + 1
+ IV(NFGCAL) = IV(NFCALL)
+ IV(1) = -1
+C
+C *** RETURN FOR MORE FUNCTION OR GRADIENT INFORMATION ***
+C
+ 240 N2 = 0
+ 250 N1 = N2 + 1
+ N2 = N2 + ND
+ IF (N2 .GT. N) N2 = N
+ GO TO 999
+C
+C *** PRINT SUMMARY OF FINAL ITERATION AND OTHER REQUESTED ITEMS ***
+C
+ 260 G1 = IV(G)
+ 270 CALL DITSUM(D, V(G1), IV, LIV, LV, P, V, X)
+C
+ 999 RETURN
+C *** LAST CARD OF DRN2GB FOLLOWS ***
+ END
+ SUBROUTINE DD7DGB(B, D, DIG, DST, G, IPIV, KA, L, LV, P, PC,
+ 1 NWTST, STEP, TD, TG, V, W, X0)
+C
+C *** COMPUTE DOUBLE-DOGLEG STEP, SUBJECT TO SIMPLE BOUNDS ON X ***
+C
+ INTEGER LV, KA, P, PC
+ INTEGER IPIV(P)
+ DOUBLE PRECISION B(2,P), D(P), DIG(P), DST(P), G(P), L(*),
+ 1 NWTST(P), STEP(P), TD(P), TG(P), V(LV), W(P),
+ 2 X0(P)
+C
+C DIMENSION L(P*(P+1)/2)
+C
+ DOUBLE PRECISION DD7TPR, DR7MDC, DV2NRM
+ EXTERNAL DD7DOG, DD7TPR, I7SHFT, DL7ITV, DL7IVM, DL7TVM,DL7VML,
+ 1 DQ7RSH, DR7MDC, DV2NRM,DV2AXY,DV7CPY, DV7IPR, DV7SCP,
+ 2 DV7SHF, DV7VMP
+C
+C *** LOCAL VARIABLES ***
+C
+ INTEGER I, J, K, P1, P1M1
+ DOUBLE PRECISION DNWTST, GHINVG, GNORM, GNORM0, NRED, PRED, RAD,
+ 1 T, T1, T2, TI, X0I, XI
+ DOUBLE PRECISION HALF, MEPS2, ONE, TWO, ZERO
+C
+C *** V SUBSCRIPTS ***
+C
+ INTEGER DGNORM, DST0, DSTNRM, GRDFAC, GTHG, GTSTEP, NREDUC,
+ 1 NWTFAC, PREDUC, RADIUS, STPPAR
+C
+ PARAMETER (DGNORM=1, DST0=3, DSTNRM=2, GRDFAC=45, GTHG=44,
+ 1 GTSTEP=4, NREDUC=6, NWTFAC=46, PREDUC=7, RADIUS=8,
+ 2 STPPAR=5)
+ PARAMETER (HALF=0.5D+0, ONE=1.D+0, TWO=2.D+0, ZERO=0.D+0)
+ SAVE MEPS2
+ DATA MEPS2/0.D+0/
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ IF (MEPS2 .LE. ZERO) MEPS2 = TWO * DR7MDC(3)
+ GNORM0 = V(DGNORM)
+ V(DSTNRM) = ZERO
+ IF (KA .LT. 0) GO TO 10
+ DNWTST = V(DST0)
+ NRED = V(NREDUC)
+ 10 PRED = ZERO
+ V(STPPAR) = ZERO
+ RAD = V(RADIUS)
+ IF (PC .GT. 0) GO TO 20
+ DNWTST = ZERO
+ CALL DV7SCP(P, STEP, ZERO)
+ GO TO 140
+C
+ 20 P1 = PC
+ CALL DV7CPY(P, TD, D)
+ CALL DV7IPR(P, IPIV, TD)
+ CALL DV7SCP(PC, DST, ZERO)
+ CALL DV7CPY(P, TG, G)
+ CALL DV7IPR(P, IPIV, TG)
+C
+ 30 CALL DL7IVM(P1, NWTST, L, TG)
+ GHINVG = DD7TPR(P1, NWTST, NWTST)
+ V(NREDUC) = HALF * GHINVG
+ CALL DL7ITV(P1, NWTST, L, NWTST)
+ CALL DV7VMP(P1, STEP, NWTST, TD, 1)
+ V(DST0) = DV2NRM(PC, STEP)
+ IF (KA .GE. 0) GO TO 40
+ KA = 0
+ DNWTST = V(DST0)
+ NRED = V(NREDUC)
+ 40 V(RADIUS) = RAD - V(DSTNRM)
+ IF (V(RADIUS) .LE. ZERO) GO TO 100
+ CALL DV7VMP(P1, DIG, TG, TD, -1)
+ GNORM = DV2NRM(P1, DIG)
+ IF (GNORM .LE. ZERO) GO TO 100
+ V(DGNORM) = GNORM
+ CALL DV7VMP(P1, DIG, DIG, TD, -1)
+ CALL DL7TVM(P1, W, L, DIG)
+ V(GTHG) = DV2NRM(P1, W)
+ KA = KA + 1
+ CALL DD7DOG(DIG, LV, P1, NWTST, STEP, V)
+C
+C *** FIND T SUCH THAT X - T*STEP IS STILL FEASIBLE.
+C
+ T = ONE
+ K = 0
+ DO 70 I = 1, P1
+ J = IPIV(I)
+ X0I = X0(J) + DST(I)/TD(I)
+ XI = X0I + STEP(I)
+ IF (XI .LT. B(1,J)) GO TO 50
+ IF (XI .LE. B(2,J)) GO TO 70
+ TI = (B(2,J) - X0I) / STEP(I)
+ J = I
+ GO TO 60
+ 50 TI = (B(1,J) - X0I) / STEP(I)
+ J = -I
+ 60 IF (T .LE. TI) GO TO 70
+ K = J
+ T = TI
+ 70 CONTINUE
+C
+C *** UPDATE DST, TG, AND PRED ***
+C
+ CALL DV7VMP(P1, STEP, STEP, TD, 1)
+ CALL DV2AXY(P1, DST, T, STEP, DST)
+ V(DSTNRM) = DV2NRM(PC, DST)
+ T1 = T * V(GRDFAC)
+ T2 = T * V(NWTFAC)
+ PRED = PRED - T1*GNORM * ((T2 + ONE)*GNORM)
+ 1 - T2 * (ONE + HALF*T2)*GHINVG
+ 2 - HALF * (V(GTHG)*T1)**2
+ IF (K .EQ. 0) GO TO 100
+ CALL DL7VML(P1, W, L, W)
+ T2 = ONE - T2
+ DO 80 I = 1, P1
+ 80 TG(I) = T2*TG(I) - T1*W(I)
+C
+C *** PERMUTE L, ETC. IF NECESSARY ***
+C
+ P1M1 = P1 - 1
+ J = IABS(K)
+ IF (J .EQ. P1) GO TO 90
+ CALL DQ7RSH(J, P1, .FALSE., TG, L, W)
+ CALL I7SHFT(P1, J, IPIV)
+ CALL DV7SHF(P1, J, TG)
+ CALL DV7SHF(P1, J, TD)
+ CALL DV7SHF(P1, J, DST)
+ 90 IF (K .LT. 0) IPIV(P1) = -IPIV(P1)
+ P1 = P1M1
+ IF (P1 .GT. 0) GO TO 30
+C
+C *** UNSCALE STEP, UPDATE X AND DIHDI ***
+C
+ 100 CALL DV7SCP(P, STEP, ZERO)
+ DO 110 I = 1, PC
+ J = IABS(IPIV(I))
+ STEP(J) = DST(I) / TD(I)
+ 110 CONTINUE
+C
+C *** FUDGE STEP TO ENSURE THAT IT FORCES APPROPRIATE COMPONENTS
+C *** TO THEIR BOUNDS ***
+C
+ IF (P1 .GE. PC) GO TO 140
+ CALL DV2AXY(P, TD, ONE, STEP, X0)
+ K = P1 + 1
+ DO 130 I = K, PC
+ J = IPIV(I)
+ T = MEPS2
+ IF (J .GT. 0) GO TO 120
+ T = -T
+ J = -J
+ IPIV(I) = J
+ 120 T = T * DMAX1(DABS(TD(J)), DABS(X0(J)))
+ STEP(J) = STEP(J) + T
+ 130 CONTINUE
+C
+ 140 V(DGNORM) = GNORM0
+ V(NREDUC) = NRED
+ V(PREDUC) = PRED
+ V(RADIUS) = RAD
+ V(DST0) = DNWTST
+ V(GTSTEP) = DD7TPR(P, STEP, G)
+C
+ RETURN
+C *** LAST LINE OF DD7DGB FOLLOWS ***
+ END
+ SUBROUTINE DQ7RFH(IERR, IPIVOT, N, NN, NOPIVK, P, Q, R, RLEN, W)
+C
+C *** COMPUTE QR FACTORIZATION VIA HOUSEHOLDER TRANSFORMATIONS
+C *** WITH COLUMN PIVOTING ***
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER IERR, N, NN, NOPIVK, P, RLEN
+ INTEGER IPIVOT(P)
+ DOUBLE PRECISION Q(NN,P), R(RLEN), W(P)
+C DIMENSION R(P*(P+1)/2)
+C
+C---------------------------- DESCRIPTION ----------------------------
+C
+C THIS ROUTINE COMPUTES A QR FACTORIZATION (VIA HOUSEHOLDER TRANS-
+C FORMATIONS) OF THE MATRIX A THAT ON INPUT IS STORED IN Q.
+C IF NOPIVK ALLOWS IT, THIS ROUTINE DOES COLUMN PIVOTING -- IF
+C K .GT. NOPIVK, THEN ORIGINAL COLUMN K IS ELIGIBLE FOR PIVOTING.
+C THE Q AND R RETURNED ARE SUCH THAT COLUMN I OF Q*R EQUALS
+C COLUMN IPIVOT(I) OF THE ORIGINAL MATRIX A. THE UPPER TRIANGULAR
+C MATRIX R IS STORED COMPACTLY BY COLUMNS, I.E., THE OUTPUT VECTOR R
+C CONTAINS R(1,1), R(1,2), R(2,2), R(1,3), R(2,3), ..., R(P,P) (IN
+C THAT ORDER). IF ALL GOES WELL, THEN THIS ROUTINE SETS IERR = 0.
+C BUT IF (PERMUTED) COLUMN K OF A IS LINEARLY DEPENDENT ON
+C (PERMUTED) COLUMNS 1,2,...,K-1, THEN IERR IS SET TO K AND THE R
+C MATRIX RETURNED HAS R(I,J) = 0 FOR I .GE. K AND J .GE. K.
+C THE ORIGINAL MATRIX A IS AN N BY P MATRIX. NN IS THE LEAD
+C DIMENSION OF THE ARRAY Q AND MUST SATISFY NN .GE. N. NO
+C PARAMETER CHECKING IS DONE.
+C PIVOTING IS DONE AS THOUGH ALL COLUMNS OF Q WERE FIRST
+C SCALED TO HAVE THE SAME NORM. IF COLUMN K IS ELIGIBLE FOR
+C PIVOTING AND ITS (SCALED) NORM**2 LOSS IS MORE THAN THE
+C MINIMUM SUCH LOSS (OVER COLUMNS K THRU P), THEN COLUMN K IS
+C SWAPPED WITH THE COLUMN OF LEAST NORM**2 LOSS.
+C
+C CODED BY DAVID M. GAY (FALL 1979, SPRING 1984).
+C
+C-------------------------- LOCAL VARIABLES --------------------------
+C
+ INTEGER I, II, J, K, KK, KM1, KP1, NK1
+ DOUBLE PRECISION AK, QKK, S, SINGTL, T, T1, WK
+ DOUBLE PRECISION DD7TPR, DR7MDC, DV2NRM
+ EXTERNAL DD7TPR, DR7MDC,DV2AXY, DV7SCL, DV7SCP,DV7SWP, DV2NRM
+C/+
+ DOUBLE PRECISION DSQRT
+C/
+ DOUBLE PRECISION BIG, BIGRT, MEPS10, ONE, TEN, TINY, TINYRT,
+ 1 WTOL, ZERO
+ PARAMETER (ONE=1.0D+0, TEN=1.D+1, WTOL=0.75D+0, ZERO=0.0D+0)
+ SAVE BIGRT, MEPS10, TINY, TINYRT
+ DATA BIGRT/0.0D+0/, MEPS10/0.0D+0/, TINY/0.D+0/, TINYRT/0.D+0/
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ IERR = 0
+ IF (MEPS10 .GT. ZERO) GO TO 10
+ BIGRT = DR7MDC(5)
+ MEPS10 = TEN * DR7MDC(3)
+ TINYRT = DR7MDC(2)
+ TINY = DR7MDC(1)
+ BIG = DR7MDC(6)
+ IF (TINY*BIG .LT. ONE) TINY = ONE / BIG
+ 10 SINGTL = DBLE(MAX0(N,P)) * MEPS10
+C
+C *** INITIALIZE W, IPIVOT, AND DIAG(R) ***
+C
+ J = 0
+ DO 40 I = 1, P
+ IPIVOT(I) = I
+ T = DV2NRM(N, Q(1,I))
+ IF (T .GT. ZERO) GO TO 20
+ W(I) = ONE
+ GO TO 30
+ 20 W(I) = ZERO
+ 30 J = J + I
+ R(J) = T
+ 40 CONTINUE
+C
+C *** MAIN LOOP ***
+C
+ KK = 0
+ NK1 = N + 1
+ DO 130 K = 1, P
+ IF (NK1 .LE. 1) GO TO 999
+ NK1 = NK1 - 1
+ KK = KK + K
+ KP1 = K + 1
+ IF (K .LE. NOPIVK) GO TO 60
+ IF (K .GE. P) GO TO 60
+C
+C *** FIND COLUMN WITH MINIMUM WEIGHT LOSS ***
+C
+ T = W(K)
+ IF (T .LE. ZERO) GO TO 60
+ J = K
+ DO 50 I = KP1, P
+ IF (W(I) .GE. T) GO TO 50
+ T = W(I)
+ J = I
+ 50 CONTINUE
+ IF (J .EQ. K) GO TO 60
+C
+C *** INTERCHANGE COLUMNS K AND J ***
+C
+ I = IPIVOT(K)
+ IPIVOT(K) = IPIVOT(J)
+ IPIVOT(J) = I
+ W(J) = W(K)
+ W(K) = T
+ I = J*(J+1)/2
+ T1 = R(I)
+ R(I) = R(KK)
+ R(KK) = T1
+ CALL DV7SWP(N, Q(1,K), Q(1,J))
+ IF (K .LE. 1) GO TO 60
+ I = I - J + 1
+ J = KK - K + 1
+ CALL DV7SWP(K-1, R(I), R(J))
+C
+C *** COLUMN K OF Q SHOULD BE NEARLY ORTHOGONAL TO THE PREVIOUS
+C *** COLUMNS. NORMALIZE IT, TEST FOR SINGULARITY, AND DECIDE
+C *** WHETHER TO REORTHOGONALIZE IT.
+C
+ 60 AK = R(KK)
+ IF (AK .LE. ZERO) GO TO 140
+ WK = W(K)
+C
+C *** SET T TO THE NORM OF (Q(K,K),...,Q(N,K))
+C *** AND CHECK FOR SINGULARITY.
+C
+ IF (WK .LT. WTOL) GO TO 70
+ T = DV2NRM(NK1, Q(K,K))
+ IF (T / AK .LE. SINGTL) GO TO 140
+ GO TO 80
+ 70 T = DSQRT(ONE - WK)
+ IF (T .LE. SINGTL) GO TO 140
+ T = T * AK
+C
+C *** DETERMINE HOUSEHOLDER TRANSFORMATION ***
+C
+ 80 QKK = Q(K,K)
+ IF (T .LE. TINYRT) GO TO 90
+ IF (T .GE. BIGRT) GO TO 90
+ IF (QKK .LT. ZERO) T = -T
+ QKK = QKK + T
+ S = DSQRT(T * QKK)
+ GO TO 110
+ 90 S = DSQRT(T)
+ IF (QKK .LT. ZERO) GO TO 100
+ QKK = QKK + T
+ S = S * DSQRT(QKK)
+ GO TO 110
+ 100 T = -T
+ QKK = QKK + T
+ S = S * DSQRT(-QKK)
+ 110 Q(K,K) = QKK
+C
+C *** SCALE (Q(K,K),...,Q(N,K)) TO HAVE NORM SQRT(2) ***
+C
+ IF (S .LE. TINY) GO TO 140
+ CALL DV7SCL(NK1, Q(K,K), ONE/S, Q(K,K))
+C
+ R(KK) = -T
+C
+C *** COMPUTE R(K,I) FOR I = K+1,...,P AND UPDATE Q ***
+C
+ IF (K .GE. P) GO TO 999
+ J = KK + K
+ II = KK
+ DO 120 I = KP1, P
+ II = II + I
+ CALL DV2AXY(NK1, Q(K,I), -DD7TPR(NK1,Q(K,K),Q(K,I)),
+ 1 Q(K,K), Q(K,I))
+ T = Q(K,I)
+ R(J) = T
+ J = J + I
+ T1 = R(II)
+ IF (T1 .GT. ZERO) W(I) = W(I) + (T/T1)**2
+ 120 CONTINUE
+ 130 CONTINUE
+C
+C *** SINGULAR Q ***
+C
+ 140 IERR = K
+ KM1 = K - 1
+ J = KK
+ DO 150 I = K, P
+ CALL DV7SCP(I-KM1, R(J), ZERO)
+ J = J + I
+ 150 CONTINUE
+C
+ 999 RETURN
+C *** LAST CARD OF DQ7RFH FOLLOWS ***
+ END
+ SUBROUTINE DF7DHB(B, D, G, IRT, IV, LIV, LV, P, V, X)
+C
+C *** COMPUTE FINITE-DIFFERENCE HESSIAN, STORE IT IN V STARTING
+C *** AT V(IV(FDH)) = V(-IV(H)). HONOR SIMPLE BOUNDS IN B.
+C
+C *** IF IV(COVREQ) .GE. 0 THEN DF7DHB USES GRADIENT DIFFERENCES,
+C *** OTHERWISE FUNCTION DIFFERENCES. STORAGE IN V IS AS IN DG7LIT.
+C
+C IRT VALUES...
+C 1 = COMPUTE FUNCTION VALUE, I.E., V(F).
+C 2 = COMPUTE G.
+C 3 = DONE.
+C
+C
+C *** PARAMETER DECLARATIONS ***
+C
+ INTEGER IRT, LIV, LV, P
+ INTEGER IV(LIV)
+ DOUBLE PRECISION B(2,P), D(P), G(P), V(LV), X(P)
+C
+C *** LOCAL VARIABLES ***
+C
+ LOGICAL OFFSID
+ INTEGER GSAVE1, HES, HMI, HPI, HPM, I, K, KIND, L, M, MM1, MM1O2,
+ 1 NEWM1, PP1O2, STPI, STPM, STP0
+ DOUBLE PRECISION DEL, DEL0, T, XM, XM1
+ DOUBLE PRECISION HALF, HLIM, ONE, TWO, ZERO
+C
+C *** EXTERNAL SUBROUTINES ***
+C
+ EXTERNAL DV7CPY, DV7SCP
+C
+C DV7CPY.... COPY ONE VECTOR TO ANOTHER.
+C DV7SCP... COPY SCALAR TO ALL COMPONENTS OF A VECTOR.
+C
+C *** SUBSCRIPTS FOR IV AND V ***
+C
+ INTEGER COVREQ, DELTA, DELTA0, DLTFDC, F, FDH, FX, H, KAGQT, MODE,
+ 1 NFGCAL, SAVEI, SWITCH, TOOBIG, W, XMSAVE
+C
+ PARAMETER (HALF=0.5D+0, HLIM=0.1D+0, ONE=1.D+0, TWO=2.D+0,
+ 1 ZERO=0.D+0)
+C
+ PARAMETER (COVREQ=15, DELTA=52, DELTA0=44, DLTFDC=42, F=10,
+ 1 FDH=74, FX=53, H=56, KAGQT=33, MODE=35, NFGCAL=7,
+ 2 SAVEI=63, SWITCH=12, TOOBIG=2, W=65, XMSAVE=51)
+C
+C+++++++++++++++++++++++++++++++ BODY ++++++++++++++++++++++++++++++++
+C
+ IRT = 4
+ KIND = IV(COVREQ)
+ M = IV(MODE)
+ IF (M .GT. 0) GO TO 10
+ HES = IABS(IV(H))
+ IV(H) = -HES
+ IV(FDH) = 0
+ IV(KAGQT) = -1
+ V(FX) = V(F)
+C *** SUPPLY ZEROS IN CASE B(1,I) = B(2,I) FOR SOME I ***
+ CALL DV7SCP(P*(P+1)/2, V(HES), ZERO)
+ 10 IF (M .GT. P) GO TO 999
+ IF (KIND .LT. 0) GO TO 120
+C
+C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING BOTH FUNCTION AND
+C *** GRADIENT VALUES.
+C
+ GSAVE1 = IV(W) + P
+ IF (M .GT. 0) GO TO 20
+C *** FIRST CALL ON DF7DHB. SET GSAVE = G, TAKE FIRST STEP ***
+ CALL DV7CPY(P, V(GSAVE1), G)
+ IV(SWITCH) = IV(NFGCAL)
+ GO TO 80
+C
+ 20 DEL = V(DELTA)
+ X(M) = V(XMSAVE)
+ IF (IV(TOOBIG) .EQ. 0) GO TO 30
+C
+C *** HANDLE OVERSIZE V(DELTA) ***
+C
+ DEL0 = V(DELTA0) * DMAX1(ONE/D(M), DABS(X(M)))
+ DEL = HALF * DEL
+ IF (DABS(DEL/DEL0) .LE. HLIM) GO TO 140
+C
+ 30 HES = -IV(H)
+C
+C *** SET G = (G - GSAVE)/DEL ***
+C
+ DEL = ONE / DEL
+ DO 40 I = 1, P
+ G(I) = DEL * (G(I) - V(GSAVE1))
+ GSAVE1 = GSAVE1 + 1
+ 40 CONTINUE
+C
+C *** ADD G AS NEW COL. TO FINITE-DIFF. HESSIAN MATRIX ***
+C
+ K = HES + M*(M-1)/2
+ L = K + M - 2
+ IF (M .EQ. 1) GO TO 60
+C
+C *** SET H(I,M) = 0.5 * (H(I,M) + G(I)) FOR I = 1 TO M-1 ***
+C
+ MM1 = M - 1
+ DO 50 I = 1, MM1
+ IF (B(1,I) .LT. B(2,I)) V(K) = HALF * (V(K) + G(I))
+ K = K + 1
+ 50 CONTINUE
+C
+C *** ADD H(I,M) = G(I) FOR I = M TO P ***
+C
+ 60 L = L + 1
+ DO 70 I = M, P
+ IF (B(1,I) .LT. B(2,I)) V(L) = G(I)
+ L = L + I
+ 70 CONTINUE
+C
+ 80 M = M + 1
+ IV(MODE) = M
+ IF (M .GT. P) GO TO 340
+ IF (B(1,M) .GE. B(2,M)) GO TO 80
+C
+C *** CHOOSE NEXT FINITE-DIFFERENCE STEP, RETURN TO GET G THERE ***
+C
+ DEL = V(DELTA0) * DMAX1(ONE/D(M), DABS(X(M)))
+ XM = X(M)
+ IF (XM .LT. ZERO) GO TO 90
+ XM1 = XM + DEL
+ IF (XM1 .LE. B(2,M)) GO TO 110
+ XM1 = XM - DEL
+ IF (XM1 .GE. B(1,M)) GO TO 100
+ GO TO 280
+ 90 XM1 = XM - DEL
+ IF (XM1 .GE. B(1,M)) GO TO 100
+ XM1 = XM + DEL
+ IF (XM1 .LE. B(2,M)) GO TO 110
+ GO TO 280
+C
+ 100 DEL = -DEL
+ 110 V(XMSAVE) = XM
+ X(M) = XM1
+ V(DELTA) = DEL
+ IRT = 2
+ GO TO 999
+C
+C *** COMPUTE FINITE-DIFFERENCE HESSIAN USING FUNCTION VALUES ONLY.
+C
+ 120 STP0 = IV(W) + P - 1
+ MM1 = M - 1
+ MM1O2 = M*MM1/2
+ HES = -IV(H)
+ IF (M .GT. 0) GO TO 130
+C *** FIRST CALL ON DF7DHB. ***
+ IV(SAVEI) = 0
+ GO TO 240
+C
+ 130 IF (IV(TOOBIG) .EQ. 0) GO TO 150
+C *** PUNT IN THE EVENT OF AN OVERSIZE STEP ***
+ 140 IV(FDH) = -2
+ GO TO 350
+ 150 I = IV(SAVEI)
+ IF (I .GT. 0) GO TO 190
+C
+C *** SAVE F(X + STP(M)*E(M)) IN H(P,M) ***
+C
+ PP1O2 = P * (P-1) / 2
+ HPM = HES + PP1O2 + MM1
+ V(HPM) = V(F)
+C
+C *** START COMPUTING ROW M OF THE FINITE-DIFFERENCE HESSIAN H. ***
+C
+ NEWM1 = 1
+ GO TO 260
+ 160 HMI = HES + MM1O2
+ IF (MM1 .EQ. 0) GO TO 180
+ HPI = HES + PP1O2
+ DO 170 I = 1, MM1
+ T = ZERO
+ IF (B(1,I) .LT. B(2,I)) T = V(FX) - (V(F) + V(HPI))
+ V(HMI) = T
+ HMI = HMI + 1
+ HPI = HPI + 1
+ 170 CONTINUE
+ 180 V(HMI) = V(F) - TWO*V(FX)
+ IF (OFFSID) V(HMI) = V(FX) - TWO*V(F)
+C
+C *** COMPUTE FUNCTION VALUES NEEDED TO COMPLETE ROW M OF H. ***
+C
+ I = 0
+ GO TO 200
+C
+ 190 X(I) = V(DELTA)
+C
+C *** FINISH COMPUTING H(M,I) ***
+C
+ STPI = STP0 + I
+ HMI = HES + MM1O2 + I - 1
+ STPM = STP0 + M
+ V(HMI) = (V(HMI) + V(F)) / (V(STPI)*V(STPM))
+ 200 I = I + 1
+ IF (I .GT. M) GO TO 230
+ IF (B(1,I) .LT. B(2,I)) GO TO 210
+ GO TO 200
+C
+ 210 IV(SAVEI) = I
+ STPI = STP0 + I
+ V(DELTA) = X(I)
+ X(I) = X(I) + V(STPI)
+ IRT = 1
+ IF (I .LT. M) GO TO 999
+ NEWM1 = 2
+ GO TO 260
+ 220 X(M) = V(XMSAVE) - DEL
+ IF (OFFSID) X(M) = V(XMSAVE) + TWO*DEL
+ GO TO 999
+C
+ 230 IV(SAVEI) = 0
+ X(M) = V(XMSAVE)
+C
+ 240 M = M + 1
+ IV(MODE) = M
+ IF (M .GT. P) GO TO 330
+ IF (B(1,M) .LT. B(2,M)) GO TO 250
+ GO TO 240
+C
+C *** PREPARE TO COMPUTE ROW M OF THE FINITE-DIFFERENCE HESSIAN H.
+C *** COMPUTE M-TH STEP SIZE STP(M), THEN RETURN TO OBTAIN
+C *** F(X + STP(M)*E(M)), WHERE E(M) = M-TH STD. UNIT VECTOR.
+C
+ 250 V(XMSAVE) = X(M)
+ NEWM1 = 3
+ 260 XM = V(XMSAVE)
+ DEL = V(DLTFDC) * DMAX1(ONE/D(M), DABS(XM))
+ XM1 = XM + DEL
+ OFFSID = .FALSE.
+ IF (XM1 .LE. B(2,M)) GO TO 270
+ OFFSID = .TRUE.
+ XM1 = XM - DEL
+ IF (XM - TWO*DEL .GE. B(1,M)) GO TO 300
+ GO TO 280
+ 270 IF (XM-DEL .GE. B(1,M)) GO TO 290
+ OFFSID = .TRUE.
+ IF (XM + TWO*DEL .LE. B(2,M)) GO TO 310
+C
+ 280 IV(FDH) = -2
+ GO TO 350
+C
+ 290 IF (XM .GE. ZERO) GO TO 310
+ XM1 = XM - DEL
+ 300 DEL = -DEL
+ 310 GO TO (160, 220, 320), NEWM1
+ 320 X(M) = XM1
+ STPM = STP0 + M
+ V(STPM) = DEL
+ IRT = 1
+ GO TO 999
+C
+C *** HANDLE SPECIAL CASE OF B(1,P) = B(2,P) -- CLEAR SCRATCH VALUES
+C *** FROM LAST ROW OF FDH...
+C
+ 330 IF (B(1,P) .LT. B(2,P)) GO TO 340
+ I = HES + P*(P-1)/2
+ CALL DV7SCP(P, V(I), ZERO)
+C
+C *** RESTORE V(F), ETC. ***
+C
+ 340 IV(FDH) = HES
+ 350 V(F) = V(FX)
+ IRT = 3
+ IF (KIND .LT. 0) GO TO 999
+ IV(NFGCAL) = IV(SWITCH)
+ GSAVE1 = IV(W) + P
+ CALL DV7CPY(P, G, V(GSAVE1))
+ GO TO 999
+C
+ 999 RETURN
+C *** LAST LINE OF DF7DHB FOLLOWS ***
+ END
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/prho.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/prho.c
new file mode 100644
index 0000000000..65a6a9b0d0
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/prho.c
@@ -0,0 +1,157 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2000-2016 The R Core Team
+ * Copyright (C) 2003 The R Foundation
+ * based on AS 89 (C) 1975 Royal Statistical Society
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/
+ *
+ */
+
+#include <math.h>
+#include <Rmath.h>
+
+/* Was
+ double precision function prho(n, is, ifault)
+
+ Changed to subroutine by KH to allow for .Fortran interfacing.
+ Also, change `prho' argument in the code to `pv'.
+ And, fix a bug.
+
+ From R ver. 1.1.x [March, 2000] by MM:
+ - Translate Fortran to C
+ - use pnorm() instead of less precise alnorm().
+ - new argument lower_tail --> potentially increased precision in extreme cases.
+*/
+void
+prho(int n, double is, double *pv, int ifault, int lower_tail)
+{
+/* Algorithm AS 89 Appl. Statist. (1975) Vol.24, No. 3, P377.
+
+ To evaluate the probability Pr[ S >= is ]
+ {or Pr [ S < is] if(lower_tail) }, where
+
+ S = (n^3 - n) * (1-R)/6,
+ is = (n^3 - n) * (1-r)/6,
+ R,r = Spearman's rho (r.v. and observed), and n >= 2
+*/
+
+ /* Edgeworth coefficients : */
+ const double
+ c1 = .2274,
+ c2 = .2531,
+ c3 = .1745,
+ c4 = .0758,
+ c5 = .1033,
+ c6 = .3932,
+ c7 = .0879,
+ c8 = .0151,
+ c9 = .0072,
+ c10= .0831,
+ c11= .0131,
+ c12= 4.6e-4;
+
+ /* Local variables */
+ double b, u, x, y, n3;/*, js */
+
+#define n_small 9
+/* originally: n_small = 6 (speed!);
+ * even n_small = 10 (and n = 10) needs quite a bit longer than the approx!
+ * larger than 12 ==> integer overflow in nfac and (probably) ifr
+*/
+ int l[n_small];
+ int nfac, i, m, mt, ifr, ise, n1;
+
+ /* Test admissibility of arguments and initialize */
+ *pv = lower_tail ? 0. : 1.;
+ if (n <= 1) { ifault = 1; return; }
+
+ ifault = 0;
+ if (is <= 0.) return;/* with p = 1 */
+
+ n3 = (double)n;
+ n3 *= (n3 * n3 - 1.) / 3.;/* = (n^3 - n)/3 */
+ if (is > n3) { /* larger than maximal value */
+ *pv = 1 - *pv; return;
+ }
+ /* NOT rounding to even anymore: with ties, S, may even be non-integer!
+ * js = is;
+ * if(fmod(js, 2.) != 0.) ++js;
+ */
+ if (n <= n_small) { /* 2 <= n <= n_small :
+ * Exact evaluation of probability */
+ nfac = 1.;
+ for (i = 1; i <= n; ++i) {
+ nfac *= i;
+ l[i - 1] = i;
+ }
+ /* KH mod next line: was `!=' in the code but `.eq.' in the paper */
+ if (is == n3) {
+ ifr = 1;
+ }
+ else {
+ ifr = 0;
+ for (m = 0; m < nfac; ++m) {
+ ise = 0;
+ for (i = 0; i < n; ++i) {
+ n1 = i + 1 - l[i];
+ ise += n1 * n1;
+ }
+ if (is <= ise)
+ ++ifr;
+
+ n1 = n;
+ do {
+ mt = l[0];
+ for (i = 1; i < n1; ++i)
+ l[i - 1] = l[i];
+ --n1;
+ l[n1] = mt;
+ } while (mt == n1+1 && n1 > 1);
+ }
+ }
+ *pv = (lower_tail ? nfac-ifr : ifr) / (double) nfac;
+ } /* exact for n <= n_small */
+
+ else { /* n >= 7 : Evaluation by Edgeworth series expansion */
+
+ y = (double) n;
+ b = 1 / y;
+ x = (6. * (is - 1) * b / (y * y - 1) - 1) * sqrt(y - 1);
+ /* = rho * sqrt(n-1) == rho / sqrt(var(rho)) ~ (0,1) */
+ y = x * x;
+ u = x * b * (c1 + b * (c2 + c3 * b) +
+ y * (-c4 + b * (c5 + c6 * b) -
+ y * b * (c7 + c8 * b -
+ y * (c9 - c10 * b + y * b * (c11 - c12 * y))
+ )));
+ y = u / exp(y / 2.);
+ *pv = (lower_tail ? -y : y) +
+ pnorm(x, 0., 1., lower_tail, /*log_p = */FALSE);
+ /* above was call to alnorm() [algorithm AS 66] */
+ if (*pv < 0) *pv = 0.;
+ if (*pv > 1) *pv = 1.;
+ }
+ return;
+} /* prho */
+
+#include <Rinternals.h>
+SEXP pRho(SEXP q, SEXP sn, SEXP lower)
+{
+ double s = asReal(q), p;
+ int n = asInteger(sn), ltail = asInteger(lower), ifault = 0;
+ prho(n, s, &p, ifault, ltail);
+ return ScalarReal(p);
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/rWishart.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/rWishart.c
new file mode 100644
index 0000000000..0e14e7c3b0
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/rWishart.c
@@ -0,0 +1,119 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2012-2016 The R Core Team
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <math.h>
+#include <string.h> // memset, memcpy
+#include <R.h>
+#include <Rinternals.h>
+#include <Rmath.h>
+#include <R_ext/Lapack.h> /* for Lapack (dpotrf, etc.) and BLAS */
+
+#include "stats.h" // for _()
+#include "statsR.h"
+
+
+/**
+ * Simulate the Cholesky factor of a standardized Wishart variate with
+ * dimension p and nu degrees of freedom.
+ *
+ * @param nu degrees of freedom
+ * @param p dimension of the Wishart distribution
+ * @param upper if 0 the result is lower triangular, otherwise upper
+ triangular
+ * @param ans array of size p * p to hold the result
+ *
+ * @return ans
+ */
+static double
+*std_rWishart_factor(double nu, int p, int upper, double ans[])
+{
+ int pp1 = p + 1;
+
+ if (nu < (double) p || p <= 0)
+ error(_("inconsistent degrees of freedom and dimension"));
+
+ memset(ans, 0, p * p * sizeof(double));
+ for (int j = 0; j < p; j++) { /* jth column */
+ ans[j * pp1] = sqrt(rchisq(nu - (double) j));
+ for (int i = 0; i < j; i++) {
+ int uind = i + j * p, /* upper triangle index */
+ lind = j + i * p; /* lower triangle index */
+ ans[(upper ? uind : lind)] = norm_rand();
+ ans[(upper ? lind : uind)] = 0;
+ }
+ }
+ return ans;
+}
+
+/**
+ * Simulate a sample of random matrices from a Wishart distribution
+ *
+ * @param ns Number of samples to generate
+ * @param nuP Degrees of freedom
+ * @param scal Positive-definite scale matrix
+ *
+ * @return
+ */
+SEXP
+rWishart(SEXP ns, SEXP nuP, SEXP scal)
+{
+ SEXP ans;
+ int *dims = INTEGER(getAttrib(scal, R_DimSymbol)), info,
+ n = asInteger(ns), psqr;
+ double *scCp, *ansp, *tmp, nu = asReal(nuP), one = 1, zero = 0;
+
+ if (!isMatrix(scal) || !isReal(scal) || dims[0] != dims[1])
+ error(_("'scal' must be a square, real matrix"));
+ if (n <= 0) n = 1;
+ // allocate early to avoid memory leaks in Callocs below.
+ PROTECT(ans = alloc3DArray(REALSXP, dims[0], dims[0], n));
+ psqr = dims[0] * dims[0];
+ tmp = Calloc(psqr, double);
+ scCp = Calloc(psqr, double);
+
+ Memcpy(scCp, REAL(scal), psqr);
+ memset(tmp, 0, psqr * sizeof(double));
+ F77_CALL(dpotrf)("U", &(dims[0]), scCp, &(dims[0]), &info);
+ if (info)
+ error(_("'scal' matrix is not positive-definite"));
+ ansp = REAL(ans);
+ GetRNGstate();
+ for (int j = 0; j < n; j++) {
+ double *ansj = ansp + j * psqr;
+ std_rWishart_factor(nu, dims[0], 1, tmp);
+ F77_CALL(dtrmm)("R", "U", "N", "N", dims, dims,
+ &one, scCp, dims, tmp, dims);
+ F77_CALL(dsyrk)("U", "T", &(dims[1]), &(dims[1]),
+ &one, tmp, &(dims[1]),
+ &zero, ansj, &(dims[1]));
+
+ for (int i = 1; i < dims[0]; i++)
+ for (int k = 0; k < i; k++)
+ ansj[i + k * dims[0]] = ansj[k + i * dims[0]];
+ }
+
+ PutRNGstate();
+ Free(scCp); Free(tmp);
+ UNPROTECT(1);
+ return ans;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/smooth.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/smooth.c
new file mode 100644
index 0000000000..cec481f0e9
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/smooth.c
@@ -0,0 +1,312 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 1997-2016 The R Core Team.
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/
+ */
+
+/* Tukey Median Smoothing */
+
+#ifdef HAVE_CONFIG_H
+#include <config.h>
+#endif
+
+#include <stdlib.h> /* for abs */
+#include <math.h>
+
+#include <Rinternals.h> /* Arith.h, Boolean.h, Error.h, Memory.h .. */
+
+typedef enum {
+ sm_NO_ENDRULE, sm_COPY_ENDRULE, sm_TUKEY_ENDRULE
+} R_SM_ENDRULE;
+
+#ifdef ENABLE_NLS
+#include <libintl.h>
+#define _(String) dgettext ("stats", String)
+#else
+#define _(String) (String)
+#endif
+
+static double med3(double u, double v, double w)
+{
+ /* Median(u,v,w): */
+ if((u <= v && v <= w) ||
+ (u >= v && v >= w)) return v;
+ if((u <= w && w <= v) ||
+ (u >= w && w >= v)) return w;
+ /* else */ return u;
+}
+/* Note: Velleman & Hoaglin use a smarter version, which returns "change"
+ ----
+ and change = TRUE, when med3(u,v,w) != v ==> makes "R" (in "3R") faster
+*/
+static int imed3(double u, double v, double w)
+{
+ /* Return (Index-1) of median(u,v,w) , i.e.,
+ -1 : u
+ 0 : v
+ 1 : w
+ */
+ if((u <= v && v <= w) ||
+ (u >= v && v >= w)) return 0;
+ if((u <= w && w <= v) ||
+ (u >= w && w >= v)) return 1;
+ /* else */ return -1;
+}
+
+static Rboolean sm_3(double *x, double *y, R_xlen_t n, int end_rule)
+{
+ /* y[] := Running Median of three (x) = "3 (x[])" with "copy ends"
+ * --- return chg := ( y != x ) */
+ R_xlen_t i;
+ int j;
+ Rboolean chg = FALSE;
+
+ if (n <= 2) {
+ for(i=0; i < n; i++)
+ y[i] = x[i];
+ return FALSE;
+ }
+
+ for(i = 1; i < n-1; i++) {
+ j = imed3(x[i-1], x[i], x[i+1]);
+ y[i] = x[i + j];
+ chg = chg || j;
+ }
+/* [y, chg] := sm_DO_ENDRULE(x, y, end_rule, chg) : */
+#define sm_DO_ENDRULE(y) \
+ switch(end_rule) { \
+ case sm_NO_ENDRULE: \
+ /* do nothing : don't even assign them */ break; \
+ \
+ case sm_COPY_ENDRULE: /* 1 */ \
+ y[0] = x[0]; \
+ y[n-1] = x[n-1]; \
+ break; \
+ \
+ case sm_TUKEY_ENDRULE: /* 2 */ \
+ y[0] = med3(3*y[1] - 2*y[2], x[0], y[1]); \
+ chg = chg || (y[0] != x[0]); \
+ y[n-1] = med3(y[n-2], x[n-1], 3*y[n-2] - 2*y[n-3]); \
+ chg = chg || (y[n-1] != x[n-1]); \
+ break; \
+ \
+ default: \
+ error(_("invalid end-rule for running median of 3: %d"), \
+ end_rule); \
+ }
+
+ sm_DO_ENDRULE(y);
+
+ return chg;
+}
+
+static int sm_3R(double *x, double *y, double *z, R_xlen_t n, int end_rule)
+{
+ /* y[] := "3R"(x) ; 3R = Median of three, repeated until convergence */
+ int iter;
+ Rboolean chg;
+
+ iter = chg = sm_3(x, y, n, sm_COPY_ENDRULE);
+
+ while(chg) {
+ if((chg = sm_3(y, z, n, sm_NO_ENDRULE))) {
+ iter++;
+ for(R_xlen_t i=1; i < n-1; i++)
+ y[i] = z[i];
+ }
+ }
+
+ if (n > 2) sm_DO_ENDRULE(y);/* => chg = TRUE iff ends changed */
+
+ return(iter ? iter : chg);
+ /* = 0 <==> only one "3" w/o any change
+ = 1 <==> either ["3" w/o change + endchange]
+ or [two "3"s, 2nd w/o change ]
+ */
+}
+
+
+static Rboolean sptest(double *x, R_xlen_t i)
+{
+ /* Split test:
+ Are we at a /-\ or \_/ location => split should be made ?
+ */
+ if(x[i] != x[i+1]) return FALSE;
+ if((x[i-1] <= x[i] && x[i+1] <= x[i+2]) ||
+ (x[i-1] >= x[i] && x[i+1] >= x[i+2])) return FALSE;
+ /* else */ return TRUE;
+}
+
+
+static Rboolean sm_split3(double *x, double *y, R_xlen_t n, Rboolean do_ends)
+{
+ /* y[] := S(x[]) where S() = "sm_split3" */
+ R_xlen_t i;
+ Rboolean chg = FALSE;
+
+ for(i=0; i < n; i++)
+ y[i] = x[i];
+
+ if (n <= 4) return FALSE;
+
+ /* Colin Goodall doesn't do splits near ends
+ in spl() in Statlib's "smoother" code !! */
+ if(do_ends && sptest(x, 1)) {
+ chg = TRUE;
+ y[1] = x[0];
+ y[2] = med3(x[2], x[3], 3*x[3] - 2*x[4]);
+ }
+
+ for(i=2; i < n-3; i++)
+ if(sptest(x, i)) { /* plateau at x[i] == x[i+1] */
+ int j;
+ /* at left : */
+ if(-1 < (j = imed3(x[i ], x[i-1], 3*x[i-1] - 2*x[i-2]))) {
+ y[i] = /* med3(.) = */ (j == 0)? x[i-1] : 3*x[i-1] - 2*x[i-2];
+ chg = y[i] != x[i];
+ }
+ /* at right : */
+ if(-1 < (j = imed3(x[i+1], x[i+2], 3*x[i+2] - 2*x[i+3]))) {
+ y[i+1] = /* med3(.) = */ (j == 0)? x[i+2] : 3*x[i+2] - 2*x[i+3];
+ chg = y[i+1] != x[i+1];
+ }
+ }
+ if(do_ends && sptest(x, n-3)) {
+ chg = TRUE;
+ y[n-2] = x[n-1];
+ y[n-3] = med3(x[n-3], x[n-4], 3*x[n-4] - 2*x[n-5]);
+ }
+ return(chg);
+}
+
+static int sm_3RS3R(double *x, double *y, double *z, double *w, R_xlen_t n,
+ int end_rule, Rboolean split_ends)
+{
+ /* y[1:n] := "3R S 3R"(x[1:n]); z = "work"; */
+ int iter;
+ Rboolean chg;
+
+ iter = sm_3R (x, y, z, n, end_rule);
+ chg = sm_split3(y, z, n, split_ends);
+ if(chg)
+ iter += sm_3R(z, y, w, n, end_rule);
+ /* else y == z already */
+ return(iter + (int)chg);
+}
+
+static int sm_3RSS(double *x, double *y, double *z, R_xlen_t n,
+ int end_rule, Rboolean split_ends)
+{
+ /* y[1:n] := "3RSS"(x[1:n]); z = "work"; */
+ int iter;
+ Rboolean chg;
+
+ iter = sm_3R (x, y, z, n, end_rule);
+ chg = sm_split3(y, z, n, split_ends);
+ if(chg)
+ sm_split3(z, y, n, split_ends);
+ /* else y == z already */
+ return(iter + (int)chg);
+}
+
+static int sm_3RSR(double *x, double *y, double *z, double *w, R_xlen_t n,
+ int end_rule, Rboolean split_ends)
+{
+ /* y[1:n] := "3RSR"(x[1:n]); z := residuals; w = "work"; */
+
+/*== "SR" (as follows) is stupid ! (MM) ==*/
+
+ R_xlen_t i;
+ int iter;
+ Rboolean chg, ch2;
+
+ iter = sm_3R(x, y, z, n, end_rule);
+
+ do {
+ iter++;
+ chg = sm_split3(y, z, n, split_ends);
+ ch2 = sm_3R(z, y, w, n, end_rule);
+ chg = chg || ch2;
+
+ if(!chg) break;
+ if(iter > 2*n) break;/* INF.LOOP stopper */
+ for(i=0; i < n; i++)
+ z[i] = x[i] - y[i];
+
+ } while (chg);
+
+ return(iter);
+}
+
+
+/*-------- These are called from R : -----------*/
+
+#include <Rinternals.h>
+SEXP Rsm(SEXP x, SEXP stype, SEXP send)
+{
+ int iend = asInteger(send), type = asInteger(stype);
+ R_xlen_t n = XLENGTH(x);
+ SEXP ans = PROTECT(allocVector(VECSXP, 2));
+ SEXP y = allocVector(REALSXP, n);
+ SET_VECTOR_ELT(ans, 0, y);
+ SEXP nm = allocVector(STRSXP, 2);
+ setAttrib(ans, R_NamesSymbol, nm);
+ SET_STRING_ELT(nm, 0, mkChar("y"));
+ if (type <= 5) {
+ int iter = 0 /* -Wall */;
+ switch(type){
+ case 1:
+ {
+ double *z = (double *) R_alloc(n, sizeof(double));
+ double *w = (double *) R_alloc(n, sizeof(double));
+ iter = sm_3RS3R(REAL(x), REAL(y), z, w, n, abs(iend),
+ /* split_ends: */ (iend < 0) ? TRUE : FALSE);
+ break;
+ }
+ case 2:
+ {
+ double *z = (double *) R_alloc(n, sizeof(double));
+ iter = sm_3RSS(REAL(x), REAL(y), z, n, abs(iend),
+ /* split_ends: */ (iend < 0) ? TRUE : FALSE);
+ break;
+ }
+ case 3:
+ {
+ double *z = (double *) R_alloc(n, sizeof(double));
+ double *w = (double *) R_alloc(n, sizeof(double));
+ iter = sm_3RSR(REAL(x), REAL(y), z, w, n, abs(iend),
+ /* split_ends: */ (iend < 0) ? TRUE : FALSE);
+ break;
+ }
+ case 4: // "3R"
+ {
+ double *z = (double *) R_alloc(n, sizeof(double));
+ iter = sm_3R(REAL(x), REAL(y), z, n, iend);
+ }
+ break;
+ case 5: // "3"
+ iter = sm_3(REAL(x), REAL(y), n, iend);
+ }
+ SET_VECTOR_ELT(ans, 1, ScalarInteger(iter));
+ SET_STRING_ELT(nm, 1, mkChar("iter"));
+ } else { // type > 5 ==> =~ "S"
+ int changed = sm_split3(REAL(x), REAL(y), n, (Rboolean) iend);
+ SET_VECTOR_ELT(ans, 1, ScalarLogical(changed));
+ SET_STRING_ELT(nm, 1, mkChar("changed"));
+ }
+ UNPROTECT(1);
+ return ans;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/starma.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/starma.c
new file mode 100644
index 0000000000..1b17de1fe1
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/starma.c
@@ -0,0 +1,521 @@
+/* R : A Computer Language for Statistical Data Analysis
+ *
+ * Copyright (C) 1999-2002 The R Core Team
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/.
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <R.h>
+#include "ts.h"
+
+
+#ifndef max
+#define max(a,b) ((a < b)?(b):(a))
+#endif
+#ifndef min
+#define min(a,b) ((a > b)?(b):(a))
+#endif
+
+/* Code in this file based on Applied Statistics algorithms AS154/182
+ (C) Royal Statistical Society 1980, 1982 */
+
+static void
+inclu2(int np, double *xnext, double *xrow, double ynext,
+ double *d, double *rbar, double *thetab)
+{
+ double cbar, sbar, di, xi, xk, rbthis, dpi;
+ int i, k, ithisr;
+
+/* This subroutine updates d, rbar, thetab by the inclusion
+ of xnext and ynext. */
+
+ for (i = 0; i < np; i++) xrow[i] = xnext[i];
+
+ for (ithisr = 0, i = 0; i < np; i++) {
+ if (xrow[i] != 0.0) {
+ xi = xrow[i];
+ di = d[i];
+ dpi = di + xi * xi;
+ d[i] = dpi;
+ cbar = di / dpi;
+ sbar = xi / dpi;
+ for (k = i + 1; k < np; k++) {
+ xk = xrow[k];
+ rbthis = rbar[ithisr];
+ xrow[k] = xk - xi * rbthis;
+ rbar[ithisr++] = cbar * rbthis + sbar * xk;
+ }
+ xk = ynext;
+ ynext = xk - xi * thetab[i];
+ thetab[i] = cbar * thetab[i] + sbar * xk;
+ if (di == 0.0) return;
+ } else ithisr = ithisr + np - i - 1;
+ }
+}
+
+void starma(Starma G, int *ifault)
+{
+ int p = G->p, q = G->q, r = G->r, np = G->np, nrbar = G->nrbar;
+ double *phi = G->phi, *theta = G->theta, *a = G->a,
+ *P = G->P, *V = G->V, *thetab = G->thetab, *xnext = G->xnext,
+ *xrow = G->xrow, *rbar = G->rbar;
+ int indi, indj, indn;
+ double phii, phij, ynext, vj, bi;
+ int i, j, k, ithisr, ind, npr, ind1, ind2, npr1, im, jm;
+
+/* Invoking this subroutine sets the values of v and phi, and
+ obtains the initial values of a and p. */
+
+/* Check if ar(1) */
+
+ if (!(q > 0 || p > 1)) {
+ V[0] = 1.0;
+ a[0] = 0.0;
+ P[0] = 1.0 / (1.0 - phi[0] * phi[0]);
+ return;
+ }
+
+/* Check for failure indication. */
+ *ifault = 0;
+ if (p < 0) *ifault = 1;
+ if (q < 0) *ifault += 2;
+ if (p == 0 && q == 0) *ifault = 4;
+ k = q + 1;
+ if (k < p) k = p;
+ if (r != k) *ifault = 5;
+ if (np != r * (r + 1) / 2) *ifault = 6;
+ if (nrbar != np * (np - 1) / 2) *ifault = 7;
+ if (r == 1) *ifault = 8;
+ if (*ifault != 0) return;
+
+/* Now set a(0), V and phi. */
+
+ for (i = 1; i < r; i++) {
+ a[i] = 0.0;
+ if (i >= p) phi[i] = 0.0;
+ V[i] = 0.0;
+ if (i < q + 1) V[i] = theta[i - 1];
+ }
+ a[0] = 0.0;
+ if (p == 0) phi[0] = 0.0;
+ V[0] = 1.0;
+ ind = r;
+ for (j = 1; j < r; j++) {
+ vj = V[j];
+ for (i = j; i < r; i++) V[ind++] = V[i] * vj;
+ }
+
+/* Now find p(0). */
+
+ if (p > 0) {
+/* The set of equations s * vec(p(0)) = vec(v) is solved for
+ vec(p(0)). s is generated row by row in the array xnext. The
+ order of elements in p is changed, so as to bring more leading
+ zeros into the rows of s. */
+
+ for (i = 0; i < nrbar; i++) rbar[i] = 0.0;
+ for (i = 0; i < np; i++) {
+ P[i] = 0.0;
+ thetab[i] = 0.0;
+ xnext[i] = 0.0;
+ }
+ ind = 0;
+ ind1 = -1;
+ npr = np - r;
+ npr1 = npr + 1;
+ indj = npr;
+ ind2 = npr - 1;
+ for (j = 0; j < r; j++) {
+ phij = phi[j];
+ xnext[indj++] = 0.0;
+ indi = npr1 + j;
+ for (i = j; i < r; i++) {
+ ynext = V[ind++];
+ phii = phi[i];
+ if (j != r - 1) {
+ xnext[indj] = -phii;
+ if (i != r - 1) {
+ xnext[indi] -= phij;
+ xnext[++ind1] = -1.0;
+ }
+ }
+ xnext[npr] = -phii * phij;
+ if (++ind2 >= np) ind2 = 0;
+ xnext[ind2] += 1.0;
+ inclu2(np, xnext, xrow, ynext, P, rbar, thetab);
+ xnext[ind2] = 0.0;
+ if (i != r - 1) {
+ xnext[indi++] = 0.0;
+ xnext[ind1] = 0.0;
+ }
+ }
+ }
+
+ ithisr = nrbar - 1;
+ im = np - 1;
+ for (i = 0; i < np; i++) {
+ bi = thetab[im];
+ for (jm = np - 1, j = 0; j < i; j++)
+ bi -= rbar[ithisr--] * P[jm--];
+ P[im--] = bi;
+ }
+
+/* now re-order p. */
+
+ ind = npr;
+ for (i = 0; i < r; i++) xnext[i] = P[ind++];
+ ind = np - 1;
+ ind1 = npr - 1;
+ for (i = 0; i < npr; i++) P[ind--] = P[ind1--];
+ for (i = 0; i < r; i++) P[i] = xnext[i];
+ } else {
+
+/* P(0) is obtained by backsubstitution for a moving average process. */
+
+ indn = np;
+ ind = np;
+ for (i = 0; i < r; i++)
+ for (j = 0; j <= i; j++) {
+ --ind;
+ P[ind] = V[ind];
+ if (j != 0) P[ind] += P[--indn];
+ }
+ }
+}
+
+void karma(Starma G, double *sumlog, double *ssq, int iupd, int *nit)
+{
+ int p = G->p, q = G->q, r = G->r, n = G->n, nu = 0;
+ double *phi = G->phi, *theta = G->theta, *a = G->a, *P = G->P,
+ *V = G->V, *w = G->w, *resid = G->resid, *work = G->xnext;
+
+ int i, j, l, ii, ind, indn, indw;
+ double a1, dt, et, ft, g, ut, phij, phijdt;
+
+/* Invoking this subroutine updates a, P, sumlog and ssq by inclusion
+ of data values w(1) to w(n). the corresponding values of resid are
+ also obtained. When ft is less than (1 + delta), quick recursions
+ are used. */
+
+/* for non-zero values of nit, perform quick recursions. */
+
+ if (*nit == 0) {
+ for (i = 0; i < n; i++) {
+
+/* prediction. */
+
+ if (iupd != 1 || i > 0) {
+
+/* here dt = ft - 1.0 */
+
+ dt = (r > 1) ? P[r] : 0.0;
+ if (dt < G->delta) goto L610;
+ a1 = a[0];
+ for (j = 0; j < r - 1; j++) a[j] = a[j + 1];
+ a[r - 1] = 0.0;
+ for (j = 0; j < p; j++) a[j] += phi[j] * a1;
+ if(P[0] == 0.0) { /* last obs was available */
+ ind = -1;
+ indn = r;
+ for (j = 0; j < r; j++)
+ for (l = j; l < r; l++) {
+ ++ind;
+ P[ind] = V[ind];
+ if (l < r - 1) P[ind] += P[indn++];
+ }
+ } else {
+ for (j = 0; j < r; j++) work[j] = P[j];
+ ind = -1;
+ indn = r;
+ dt = P[0];
+ for (j = 0; j < r; j++) {
+ phij = phi[j];
+ phijdt = phij * dt;
+ for(l = j; l < r; l++) {
+ ++ind;
+ P[ind] = V[ind] + phi[l] * phijdt;
+ if (j < r - 1) P[ind] += work[j+1] * phi[l];
+ if (l < r - 1)
+ P[ind] += work[l+1] * phij + P[indn++];
+ }
+ }
+ }
+ }
+
+/* updating. */
+
+ ft = P[0];
+ if(!ISNAN(w[i])) {
+ ut = w[i] - a[0];
+ if (r > 1)
+ for (j = 1, ind = r; j < r; j++) {
+ g = P[j] / ft;
+ a[j] += g * ut;
+ for (l = j; l < r; l++) P[ind++] -= g * P[l];
+ }
+ a[0] = w[i];
+ resid[i] = ut / sqrt(ft);
+ *ssq += ut * ut / ft;
+ *sumlog += log(ft);
+ nu++;
+ for (l = 0; l < r; l++) P[l] = 0.0;
+ } else resid[i] = NA_REAL;
+
+ }
+ *nit = n;
+
+ } else {
+
+/* quick recursions: never used with missing values */
+
+ i = 0;
+ L610:
+ *nit = i;
+ for (ii = i; ii < n; ii++) {
+ et = w[ii];
+ indw = ii;
+ for (j = 0; j < p; j++) {
+ if (--indw < 0) break;
+ et -= phi[j] * w[indw];
+ }
+ for (j = 0; j < min(ii, q); j++)
+ et -= theta[j] * resid[ii - j - 1];
+ resid[ii] = et;
+ *ssq += et * et;
+ nu++;
+ }
+ }
+ G->nused = nu;
+}
+
+
+/* start of AS 182 */
+void
+forkal(Starma G, int d, int il, double *delta, double *y, double *amse,
+ int *ifault)
+{
+ int p = G->p, q = G->q, r = G->r, n = G->n, np = G->np;
+ double *phi = G->phi, *V = G->V, *w = G->w, *xrow = G->xrow;
+ double *a, *P, *store;
+ int rd = r + d, rz = rd*(rd + 1)/2;
+ double phii, phij, sigma2, a1, aa, dt, phijdt, ams, tmp;
+ int i, j, k, l, nu = 0;
+ int k1;
+ int i45, jj, kk, lk, ll;
+ int nt;
+ int kk1, lk1;
+ int ind, jkl, kkk;
+ int ind1, ind2;
+
+/* Finite sample prediction from ARIMA processes. */
+
+/* This routine will calculate the finite sample predictions
+ and their conditional mean square errors for any ARIMA process. */
+
+/* invoking this routine will calculate the finite sample predictions */
+/* and their conditional mean square errors for any arima process. */
+
+ store = (double *) R_alloc(rd, sizeof(double));
+ Free(G->a); G->a = a = Calloc(rd, double);
+ Free(G->P); G->P = P = Calloc(rz, double);
+
+/* check for input faults. */
+ *ifault = 0;
+ if (p < 0) *ifault = 1;
+ if (q < 0) *ifault += 2;
+ if (p * p + q * q == 0) *ifault = 4;
+ if (r != max(p, q + 1)) *ifault = 5;
+ if (np != r * (r + 1) / 2) *ifault = 6;
+ if (d < 0) *ifault = 8;
+ if (il < 1) *ifault = 11;
+ if (*ifault != 0) return;
+
+/* Find initial likelihood conditions. */
+
+ if (r == 1) {
+ a[0] = 0.0;
+ V[0] = 1.0;
+ P[0] = 1.0 / (1.0 - phi[0] * phi[0]);
+ } else starma(G, ifault);
+
+/* Calculate data transformations */
+
+ nt = n - d;
+ if (d > 0) {
+ for (j = 0; j < d; j++) {
+ store[j] = w[n - j - 2];
+ if(ISNAN(store[j]))
+ error(_("missing value in last %d observations"), d);
+ }
+ for (i = 0; i < nt; i++) {
+ aa = 0.0;
+ for (k = 0; k < d; ++k) aa -= delta[k] * w[d + i - k - 1];
+ w[i] = w[i + d] + aa;
+ }
+ }
+
+/* Evaluate likelihood to obtain final Kalman filter conditions */
+
+ {
+ double sumlog = 0.0, ssq = 0.0;
+ int nit = 0;
+ G->n = nt;
+ karma(G, &sumlog, &ssq, 1, &nit);
+ }
+
+
+/* Calculate m.l.e. of sigma squared */
+
+ sigma2 = 0.0;
+ for (j = 0; j < nt; j++) {
+ /* macOS/gcc 3.5 didn't have isnan defined properly */
+ tmp = G->resid[j];
+ if(!ISNAN(tmp)) { nu++; sigma2 += tmp * tmp; }
+ }
+
+ sigma2 /= nu;
+
+/* reset the initial a and P when differencing occurs */
+
+ if (d > 0) {
+ for (i = 0; i < np; i++) xrow[i] = P[i];
+ for (i = 0; i < rz; i++) P[i] = 0.0;
+ ind = 0;
+ for (j = 0; j < r; j++) {
+ k = j * (rd + 1) - j * (j + 1) / 2;
+ for (i = j; i < r; i++) P[k++] = xrow[ind++];
+ }
+ for (j = 0; j < d; j++) a[r + j] = store[j];
+ }
+
+ i45 = 2*rd + 1;
+ jkl = r * (2*d + r + 1) / 2;
+
+ for (l = 0; l < il; ++l) {
+
+/* predict a */
+
+ a1 = a[0];
+ for (i = 0; i < r - 1; i++) a[i] = a[i + 1];
+ a[r - 1] = 0.0;
+ for (j = 0; j < p; j++) a[j] += phi[j] * a1;
+ if (d > 0) {
+ for (j = 0; j < d; j++) a1 += delta[j] * a[r + j];
+ for (i = rd - 1; i > r; i--) a[i] = a[i - 1];
+ a[r] = a1;
+ }
+
+/* predict P */
+
+ if (d > 0) {
+ for (i = 0; i < d; i++) {
+ store[i] = 0.0;
+ for (j = 0; j < d; j++) {
+ ll = max(i, j);
+ k = min(i, j);
+ jj = jkl + (ll - k) + k * (2*d + 2 - k - 1) / 2;
+ store[i] += delta[j] * P[jj];
+ }
+ }
+ if (d > 1) {
+ for (j = 0; j < d - 1; j++) {
+ jj = d - j - 1;
+ lk = (jj - 1) * (2*d + 2 - jj) / 2 + jkl;
+ lk1 = jj * (2*d + 1 - jj) / 2 + jkl;
+ for (i = 0; i <= j; i++) P[lk1++] = P[lk++];
+ }
+ for (j = 0; j < d - 1; j++)
+ P[jkl + j + 1] = store[j] + P[r + j];
+ }
+ P[jkl] = P[0];
+ for (i = 0; i < d; i++)
+ P[jkl] += delta[i] * (store[i] + 2.0 * P[r + i]);
+ for (i = 0; i < d; i++) store[i] = P[r + i];
+ for (j = 0; j < r; j++) {
+ kk1 = (j+1) * (2*rd - j - 2) / 2 + r;
+ k1 = j * (2*rd - j - 1) / 2 + r;
+ for (i = 0; i < d; i++) {
+ kk = kk1 + i;
+ k = k1 + i;
+ P[k] = phi[j] * store[i];
+ if (j < r - 1) P[k] += P[kk];
+ }
+ }
+
+ for (j = 0; j < r; j++) {
+ store[j] = 0.0;
+ kkk = (j + 1) * (i45 - j - 1) / 2 - d;
+ for (i = 0; i < d; i++) store[j] += delta[i] * P[kkk++];
+ }
+ for (j = 0; j < r; j++) {
+ k = (j + 1) * (rd + 1) - (j + 1) * (j + 2) / 2;
+ for (i = 0; i < d - 1; i++) {
+ --k;
+ P[k] = P[k - 1];
+ }
+ }
+ for (j = 0; j < r; j++) {
+ k = j * (2*rd - j - 1) / 2 + r;
+ P[k] = store[j] + phi[j] * P[0];
+ if (j < r - 1) P[k] += P[j + 1];
+ }
+ }
+ for (i = 0; i < r; i++) store[i] = P[i];
+
+ ind = 0;
+ dt = P[0];
+ for (j = 0; j < r; j++) {
+ phij = phi[j];
+ phijdt = phij * dt;
+ ind2 = j * (2*rd - j + 1) / 2 - 1;
+ ind1 = (j + 1) * (i45 - j - 1) / 2 - 1;
+ for (i = j; i < r; i++) {
+ ++ind2;
+ phii = phi[i];
+ P[ind2] = V[ind++] + phii * phijdt;
+ if (j < r - 1) P[ind2] += store[j + 1] * phii;
+ if (i < r - 1)
+ P[ind2] += store[i + 1] * phij + P[++ind1];
+ }
+ }
+
+/* predict y */
+
+ y[l] = a[0];
+ for (j = 0; j < d; j++) y[l] += a[r + j] * delta[j];
+
+/* calculate m.s.e. of y */
+
+ ams = P[0];
+ if (d > 0) {
+ for (j = 0; j < d; j++) {
+ k = r * (i45 - r) / 2 + j * (2*d + 1 - j) / 2;
+ tmp = delta[j];
+ ams += 2.0 * tmp * P[r + j] + P[k] * tmp * tmp;
+ }
+ for (j = 0; j < d - 1; j++) {
+ k = r * (i45 - r) / 2 + 1 + j * (2*d + 1 - j) / 2;
+ for (i = j + 1; i < d; i++)
+ ams += 2.0 * delta[i] * delta[j] * P[k++];
+ }
+ }
+ amse[l] = ams * sigma2;
+ }
+ return;
+}
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/swilk.c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/swilk.c
new file mode 100644
index 0000000000..263ee60587
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/swilk.c
@@ -0,0 +1,214 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2000-2016 The R Core Team.
+ *
+ * Based on Applied Statistics algorithms AS181, R94
+ * (C) Royal Statistical Society 1982, 1995
+ *
+ * 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, a copy is available at
+ * https://www.R-project.org/Licenses/
+ */
+
+/* swilk.f -- translated by f2c (version 19980913).
+ * ------- and produced by f2c-clean,v 1.8 --- and hand polished: M.Maechler
+ */
+
+#include <math.h>
+#include <Rmath.h>
+
+#ifndef min
+# define min(a, b) ((a) > (b) ? (b) : (a))
+#endif
+
+static double poly(const double *, int, double);
+
+static void
+swilk(double *x, int n, double *w, double *pw, int *ifault)
+{
+ int nn2 = n / 2;
+ double a[nn2 + 1]; /* 1-based */
+
+/* ALGORITHM AS R94 APPL. STATIST. (1995) vol.44, no.4, 547-551.
+
+ Calculates the Shapiro-Wilk W test and its significance level
+*/
+
+ double small = 1e-19;
+
+ /* polynomial coefficients */
+ double g[2] = { -2.273,.459 };
+ double c1[6] = { 0.,.221157,-.147981,-2.07119, 4.434685, -2.706056 };
+ double c2[6] = { 0.,.042981,-.293762,-1.752461,5.682633, -3.582633 };
+ double c3[4] = { .544,-.39978,.025054,-6.714e-4 };
+ double c4[4] = { 1.3822,-.77857,.062767,-.0020322 };
+ double c5[4] = { -1.5861,-.31082,-.083751,.0038915 };
+ double c6[3] = { -.4803,-.082676,.0030302 };
+
+ /* Local variables */
+ int i, j, i1;
+
+ double ssassx, summ2, ssumm2, gamma, range;
+ double a1, a2, an, m, s, sa, xi, sx, xx, y, w1;
+ double fac, asa, an25, ssa, sax, rsn, ssx, xsx;
+
+ *pw = 1.;
+ if (n < 3) { *ifault = 1; return;}
+
+ an = (double) n;
+
+ if (n == 3) {
+ a[1] = 0.70710678;/* = sqrt(1/2) */
+ } else {
+ an25 = an + .25;
+ summ2 = 0.;
+ for (i = 1; i <= nn2; i++) {
+ a[i] = qnorm((i - 0.375) / an25, 0., 1., 1, 0);
+ double r__1 = a[i];
+ summ2 += r__1 * r__1;
+ }
+ summ2 *= 2.;
+ ssumm2 = sqrt(summ2);
+ rsn = 1. / sqrt(an);
+ a1 = poly(c1, 6, rsn) - a[1] / ssumm2;
+
+ /* Normalize a[] */
+ if (n > 5) {
+ i1 = 3;
+ a2 = -a[2] / ssumm2 + poly(c2, 6, rsn);
+ fac = sqrt((summ2 - 2. * (a[1] * a[1]) - 2. * (a[2] * a[2]))
+ / (1. - 2. * (a1 * a1) - 2. * (a2 * a2)));
+ a[2] = a2;
+ } else {
+ i1 = 2;
+ fac = sqrt((summ2 - 2. * (a[1] * a[1])) /
+ ( 1. - 2. * (a1 * a1)));
+ }
+ a[1] = a1;
+ for (i = i1; i <= nn2; i++) a[i] /= - fac;
+ }
+
+/* Check for zero range */
+
+ range = x[n - 1] - x[0];
+ if (range < small) {*ifault = 6; return;}
+
+/* Check for correct sort order on range - scaled X */
+
+ /* *ifault = 7; <-- a no-op, since it is changed below, in ANY CASE! */
+ *ifault = 0;
+ xx = x[0] / range;
+ sx = xx;
+ sa = -a[1];
+ for (i = 1, j = n - 1; i < n; j--) {
+ xi = x[i] / range;
+ if (xx - xi > small) {
+ /* Fortran had: print *, "ANYTHING"
+ * but do NOT; it *does* happen with sorted x (on Intel GNU/linux 32bit):
+ * shapiro.test(c(-1.7, -1,-1,-.73,-.61,-.5,-.24, .45,.62,.81,1))
+ */
+ *ifault = 7;
+ }
+ sx += xi;
+ i++;
+ if (i != j) sa += sign(i - j) * a[min(i, j)];
+ xx = xi;
+ }
+ if (n > 5000) *ifault = 2;
+
+/* Calculate W statistic as squared correlation
+ between data and coefficients */
+
+ sa /= n;
+ sx /= n;
+ ssa = ssx = sax = 0.;
+ for (i = 0, j = n - 1; i < n; i++, j--) {
+ if (i != j) asa = sign(i - j) * a[1 + min(i, j)] - sa; else asa = -sa;
+ xsx = x[i] / range - sx;
+ ssa += asa * asa;
+ ssx += xsx * xsx;
+ sax += asa * xsx;
+ }
+
+/* W1 equals (1-W) calculated to avoid excessive rounding error
+ for W very near 1 (a potential problem in very large samples) */
+
+ ssassx = sqrt(ssa * ssx);
+ w1 = (ssassx - sax) * (ssassx + sax) / (ssa * ssx);
+ *w = 1. - w1;
+
+/* Calculate significance level for W */
+
+ if (n == 3) {/* exact P value : */
+ double pi6 = 1.90985931710274, /* = 6/pi */
+ stqr = 1.04719755119660; /* = asin(sqrt(3/4)) */
+ *pw = pi6 * (asin(sqrt(*w)) - stqr);
+ if(*pw < 0.) *pw = 0.;
+ return;
+ }
+ y = log(w1);
+ xx = log(an);
+ if (n <= 11) {
+ gamma = poly(g, 2, an);
+ if (y >= gamma) {
+ *pw = 1e-99;/* an "obvious" value, was 'small' which was 1e-19f */
+ return;
+ }
+ y = -log(gamma - y);
+ m = poly(c3, 4, an);
+ s = exp(poly(c4, 4, an));
+ } else {/* n >= 12 */
+ m = poly(c5, 4, xx);
+ s = exp(poly(c6, 3, xx));
+ }
+ /*DBG printf("c(w1=%g, w=%g, y=%g, m=%g, s=%g)\n",w1,*w,y,m,s); */
+
+ *pw = pnorm(y, m, s, 0/* upper tail */, 0);
+
+ return;
+} /* swilk */
+
+static double poly(const double *cc, int nord, double x)
+{
+/* Algorithm AS 181.2 Appl. Statist. (1982) Vol. 31, No. 2
+
+ Calculates the algebraic polynomial of order nord-1 with
+ array of coefficients cc. Zero order coefficient is cc(1) = cc[0]
+*/
+ double p, ret_val;
+
+ ret_val = cc[0];
+ if (nord > 1) {
+ p = x * cc[nord-1];
+ for (int j = nord - 2; j > 0; j--) p = (p + cc[j]) * x;
+ ret_val += p;
+ }
+ return ret_val;
+} /* poly */
+
+
+#include <Rinternals.h>
+SEXP SWilk(SEXP x)
+{
+ int n, ifault = 0;
+ double W = 0, pw; /* original version tested W on entry */
+ x = PROTECT(coerceVector(x, REALSXP));
+ n = LENGTH(x);
+ swilk(REAL(x), n, &W, &pw, &ifault);
+ if (ifault > 0 && ifault != 7)
+ error("ifault=%d. This should not happen", ifault);
+ SEXP ans = PROTECT(allocVector(REALSXP, 2));
+ REAL(ans)[0] = W, REAL(ans)[1] = pw;
+ UNPROTECT(2);
+ return ans;
+}
--
GitLab