/* 274.f -- translated by f2c (version 20030320).  */

#include "f2cdefs.h"

/* Notes on AS 274 "Least-squares routines to supplement those of Gentleman" */
/* by Alan Miller. */

/* This algorithm provides a set of high accuracy least squares routines which */
/* expand upon those provided by Gentleman in AS 75.   In particular, it includes */
/* facilities for (weighted) least-squares for a subset of the variables, for */
/* changing the order of the variables, for testing for singularities, and for */
/* calculating an estimated covariance matrix for the regression coefficients. */

/* The algorithm is NOT consistent with those which have been published in the */
/* same journal by Clarke (AS 163), Stirling (AS 164) or Smith (AS 268), in that */
/* the orthogonal reduction is stored in a different way.   It is unfortunate */
/* that these authors have not used the same format as Gentleman. */

/* The basic algorithm is the same as Gentleman's.   As each new case is added, */
/* the orthogonal reduction is updated.   In traditional least-squares notation, */
/* the algorithm goes straight from the X-matrix (the 'design' matrix) to the */
/* Cholesky factorization WITHOUT the intermediate step of forming a sum of */
/* squares and products matrix.   Thus it avoids squaring the condition number. */
/* To be pedantic, it is actually the Banachiewicz factorization which is used. */
/* We use: */

/*                   Q X = sqrt(D) R */

/* where Q is an orthonormal matrix such that Q'Q = I, D is a diagonal matrix */
/* (sqrt(D) is my crude way of indicating a diagonal matrix with elements on the */
/* diagonal which are the square roots of the elements stored in array D in the */
/* routines), and R is an upper triangular matrix with 1's on the diagonal.   The */
/* array R is stored in a 1-dimensional array with elements stored by rows as */
/* shown below (the 1's on the diagonal are NOT stored). */

/* Storage of R:    (1)  1   2   3   4   5 */
/*                      (1)  6   7   8   9 */
/*                          (1) 10  11  12 */
/*                              (1) 13  14 */
/*                                  (1) 15 */
/*                                      (1) */
/* N.B. The matrix Q is a product of planar-rotation matrices (Jacobi/Givens */
/* rotations); it is not calculated or stored. */
/* N.B. If you want to fit a constant (intercept) in your model, you can do it */
/* by putting the first element of each row of X equal to 1.0. */
/* N.B. You may like to dimension XROW as XROW(0:K) in your calling program, */
/* where K is the number of variables (other than the constant).   The parameter */
/* NP passed to routine INCLUD (and others) then takes the value K+1. */

/* To perform the calculation of regression coefficients (and nothing else), you */
/* need to call the following routines in the order given: */
/* 1. clear           - initializes arrays */
/* 2. includ          - call once for each case to update the orthogonal reduction */
/* 3. tolset          - calculates tolerances for each variable */
/* 4. sing (optional) - tests for singularities */
/* 5. regcf           - calculates regression coefficients for the first NREQ */
/*                      variables */

/* You can then add extra data and recalculate the regression coefficients. */

/* Other routines (all require that 1 and 2 above have been used first). */
/* ss    calculates array RSS such that RSS(I) = the residual sum of squares with */
/*       the first I variables in the model */
/* cov   calculates the estimated covariance matrix of the regression coefficients */
/*       (the user must input a value for the residual variance VAR, usually the */
/*       residual sum of squares SSERR divided by NOBS - NP for all variables, */
/*       or RSS(I) divided by NOBS - I for the first I variables). */
/* pcorr calculates partial correlations with the first IN variables in the model. */
/*       If IN = 1 and the first variable is identically equal to 1 then these are */
/*       the usual full correlations.   If IN = 0 it gives the cross products (not */
/*       centered) divided by the square root of the product of the second moments */
/*       (about zero) of the two variables. */
/* vmove moves the variable in position FROM to position TO. */
/* reordr calls vmove repeatedly to re-order the variables from the current order */
/*       in integer array VORDER to that in the integer array LIST. */
/* hdiag calculates the diagonal elements of the `hat' matrix used in various */
/*       diagnostic statistics. */

/* For vmove and reordr, the user must first set up an integer array VORDER which */
/* assigns a unique integer value with each variable.   You may like to associate */
/* the value 0 with the constant in the model. */

/* For cov, vmove, reordr and hdiag you must call tolset first. */

/* *** Warning *** Routine INCLUD (from Gentleman's AS 75) overwrites the elements */
/* in array XROW. */

/* Alan Miller */
/* 25 November 1991 */


/* Notes on handling singularities */
/* ------------------------------- */
/* If there is a singularity amongst your X-variables and routine SING is not */
/* used, you will get wrong answers from most routines.   The orthogonal reduction */
/* can be written as: */

/*         X  =  Q' sqrt(D) R */

/* If we denote the columns of X as X1, X2, ..., Xk, and the columns of Q' as */
/* q1, q2, ..., qk, then we have: */

/*        x1  =  r(11).q1 */
/*        x2  =  r(12).q1  +  r(22).q2 */
/*        x3  =  r(13).q1  +  r(23).q2  + r(33).q3 */

/* etc., where r(ij) = the (i,j)-element of R multiplied by the square root of the */
/* i-th diagonal element of D.   That is x1 is equal to the first orthogonal */
/* direction, q1, multiplied by a scaling factor.   x2 = a projection of length */
/* r(12) in the first direction, q1, plus a projection of length r(22) in a new */
/* direction, q2, which is orthogonal to q1, etc.   If the X-directions are all */
/* orthogonal then all of the r(ij)'s for off-diagonal elements of R will be zero. */

/* Let us suppose that there is a singularity amongst the X-variables, that is */
/* that one of the X-variables is exactly linearly related to some of the others. */
/* For simplicity, let us suppose that x3 = a.x1 + b.x2.   The direction q3 is */
/* formed from x3 by subtracting its projections in directions q1 and q2 and then */
/* scaling so that it has length equal to 1.   When the projections in directions */
/* q1 and q2 are subtracted in this case, there should be nothing left.   In */
/* practice, there will be almost always be small rounding errors.   Direction */
/* q3 will be formed from these rounding errors.   Thus we will have a rogue */
/* direction in the columns of Q'.   The projections of the dependant variable */
/* on this direction can be large.   It is like correlating the Y-variable on a */
/* variable formed by using random numbers or a column of numbers from the phone */
/* directory. */

/* Routine SING sets the projections on this direction equal to zero. */

/* In the case just mentioned, a full rank X could be obtained by removing any */
/* one of the variables x1, x2 or x3.   In AS274, the equivalent to removing a */
/* variable is to move it to the last position and then to only use the first */
/* (k-1) variables in subsequent calculations.   You still tell routines such */
/* as REGCF that there are NP variables, but you set NREQ = NP - 1. */

/* If you just want properties of a subset of variables, then you use either VMOVE */
/* or REORDR to re-order the variables so that the first ones are those which you */
/* are interested in, and you set NREQ equal to the number of those variables. */
/* In most cases, the constant (intercept) will be included in the model and so */
/* will be included in the count of variables, NREQ (N-required). */

/* Features NOT included in AS274 */
/* ------------------------------ */
/* There is no facility for removing or adding variables (columns).   This could */
/* be done but adding variables requires the storage of the Q-matrix, or at least */
/* of the rotations used to form it. */

/* There is no facility for two or more dependant variables, though this is fairly */
/* easy to program.   The extra dependant variables can be treated as X-variables. */
/* Thus if we have dependant variables Y1, Y2 and Y3, then Y2 and Y3 can be added */
/* at the end of the list of X-variables.   When looking at the properties of Y1 */
/* related to the X-variables, use only the first (NP-2) columns by setting */
/* NREQ = NP-2.   When you want to look at Y2, just copy column (NP-1) of RBAR */
/* into THETAB - this requires a little thought to work out just where those */
/* elements are stored.   You may want to first copy the original THETAB, or to */
/* copy the column of RBAR into a different array, perhaps THETAB2 say.   The */
/* residual sum of squares, SSERR, for variable Y2 is D(NP-1). */

/* Y3 is a little more difficult.   You must first change the order of the */
/* variables so that Y3 is before Y2, otherwise you will be regressing Y3 on Y2, */
/* and you probably don't want to do that. */

/* The easy way of thinking about the above is by considering each column of R */
/* (after scaling by the square roots of the diagonal elements of D) as the */
/* projections of the corresponding variable on all of those which have preceded */
/* it.   The Y-variable is just another variable being projected upon a set of */
/* orthogonal directions formed by the variables which came before it.   The */
/* vector THETAB is stored separately just for fast access as most users */
/* will have only one Y-variable; it could have been incorporated as the last */
/* column of RBAR. */

/* Alan Miller */
/* 2 May 1993 */
/* ----------------------------------------------------------------------- */
/* Subroutine */ int includ_(integer *np, integer *nrbar, doublereal *weight, 
	doublereal *xrow, doublereal *yelem, doublereal *d__, doublereal *
	rbar, doublereal *thetab, doublereal *sserr, integer *ier)
{
    /* Initialized data */

    static doublereal zero = 0.;

    /* System generated locals */
    integer i__1, i__2;

    /* Local variables */
    static integer i__, k;
    static doublereal w, y, di, xi, xk, dpi, wxi, cbar, sbar;
    static integer nextr;


/*     ALGORITHM AS274.1  APPL. STATIST. (1992) VOL 41, NO. 2 */

/*     DOUBLE PRECISION VERSION */

/*     Calling this routine updates d, rbar, thetab and sserr by the */
/*     inclusion of xrow, yelem with the specified weight. */
/*     This version has been modified to make it slightly faster when the */
/*     early elements of XROW are not zeroes. */

/*     *** WARNING ***   The elements of XROW are over-written. */


/*     Local variables */


    /* Parameter adjustments */
    --thetab;
    --d__;
    --xrow;
    --rbar;

    /* Function Body */

/*     Some checks. */

    *ier = 0;
    if (*np < 1) {
	*ier = 1;
    }
    if (*nrbar < *np * (*np - 1) / 2) {
	*ier += 2;
    }
    if (*ier != 0) {
	return 0;
    }

    w = *weight;
    y = *yelem;
    nextr = 1;
    i__1 = *np;
    for (i__ = 1; i__ <= i__1; ++i__) {

/*     Skip unnecessary transformations.   Test on exact zeroes must be */
/*     used or stability can be destroyed. */

	if (w == zero) {
	    return 0;
	}
	xi = xrow[i__];
	if (xi == zero) {
	    nextr = nextr + *np - i__;
	    goto L30;
	}
	di = d__[i__];
	wxi = w * xi;
	dpi = di + wxi * xi;
	cbar = di / dpi;
	sbar = wxi / dpi;
	w = cbar * w;
	d__[i__] = dpi;
	if (i__ == *np) {
	    goto L20;
	}
	i__2 = *np;
	for (k = i__ + 1; k <= i__2; ++k) {
	    xk = xrow[k];
	    xrow[k] = xk - xi * rbar[nextr];
	    rbar[nextr] = cbar * rbar[nextr] + sbar * xk;
	    ++nextr;
/* L10: */
	}
L20:
	xk = y;
	y = xk - xi * thetab[i__];
	thetab[i__] = cbar * thetab[i__] + sbar * xk;
L30:
	;
    }

/*     Y * SQRT(W) is now equal to the Brown, Durbin & Evans recursive */
/*     residual. */

    *sserr += w * y * y;

    return 0;
} /* includ_ */


/* Subroutine */ int clear_(integer *np, integer *nrbar, doublereal *d__, 
	doublereal *rbar, doublereal *thetab, doublereal *sserr, integer *ier)
{
    /* Initialized data */

    static doublereal zero = 0.;

    /* System generated locals */
    integer i__1;

    /* Local variables */
    static integer i__;


/*     ALGORITHM AS274.2  APPL. STATIST. (1992) VOL.41, NO.2 */

/*     Sets arrays to zero prior to calling AS75.1 */


/*     Local variables */


    /* Parameter adjustments */
    --thetab;
    --d__;
    --rbar;

    /* Function Body */

/*     Some checks. */

    *ier = 0;
    if (*np < 1) {
	*ier = 1;
    }
    if (*nrbar < *np * (*np - 1) / 2) {
	*ier += 2;
    }
    if (*ier != 0) {
	return 0;
    }

    i__1 = *np;
    for (i__ = 1; i__ <= i__1; ++i__) {
	d__[i__] = zero;
	thetab[i__] = zero;
/* L10: */
    }
    i__1 = *nrbar;
    for (i__ = 1; i__ <= i__1; ++i__) {
/* L20: */
	rbar[i__] = zero;
    }
    *sserr = zero;
    return 0;
} /* clear_ */


/* Subroutine */ int regcf_(integer *np, integer *nrbar, doublereal *d__, 
	doublereal *rbar, doublereal *thetab, doublereal *tol, doublereal *
	beta, integer *nreq, integer *ier)
{
    /* Initialized data */

    static doublereal zero = 0.;

    /* System generated locals */
    integer i__1;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    static integer i__, j, nextr;


/*     ALGORITHM AS274.3  APPL. STATIST. (1992) VOL 41, NO.2 */

/*     Modified version of AS75.4 to calculate regression coefficients */
/*     for the first NREQ variables, given an orthogonal reduction from */
/*     AS75.1. */


/*     Local variables */


    /* Parameter adjustments */
    --beta;
    --tol;
    --thetab;
    --d__;
    --rbar;

    /* Function Body */

/*     Some checks. */

    *ier = 0;
    if (*np < 1) {
	*ier = 1;
    }
    if (*nrbar < *np * (*np - 1) / 2) {
	*ier += 2;
    }
    if (*nreq < 1 || *nreq > *np) {
	*ier += 4;
    }
    if (*ier != 0) {
	return 0;
    }

    for (i__ = *nreq; i__ >= 1; --i__) {
	if (sqrt(d__[i__]) < tol[i__]) {
	    beta[i__] = zero;
	    d__[i__] = zero;
	    goto L20;
	}
	beta[i__] = thetab[i__];
	nextr = (i__ - 1) * (*np + *np - i__) / 2 + 1;
	i__1 = *nreq;
	for (j = i__ + 1; j <= i__1; ++j) {
	    beta[i__] -= rbar[nextr] * beta[j];
	    ++nextr;
/* L10: */
	}
L20:
	;
    }

    return 0;
} /* regcf_ */


/* Subroutine */ int tolset_(integer *np, integer *nrbar, doublereal *d__, 
	doublereal *rbar, doublereal *tol, doublereal *work, integer *ier)
{
    /* Initialized data */

    static doublereal eps = 1e-15;

    /* System generated locals */
    integer i__1, i__2;
    doublereal d__1;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    static integer col, pos;
    static doublereal sum;
    static integer row;


/*     ALGORITHM AS274.4  APPL. STATIST. (1992) VOL 41, NO.2 */

/*     Sets up array TOL for testing for zeroes in an orthogonal */
/*     reduction formed using AS75.1. */


/*     Local variables. */


/*     EPS is a machine-dependent constant.   For compilers which use */
/*     the IEEE format for floating-point numbers, recommended values */
/*     are 1.E-06 for single precision and 1.E-15 for double precision. */

    /* Parameter adjustments */
    --work;
    --tol;
    --d__;
    --rbar;

    /* Function Body */

/*     Some checks. */

    *ier = 0;
    if (*np < 1) {
	*ier = 1;
    }
    if (*nrbar < *np * (*np - 1) / 2) {
	*ier += 2;
    }
    if (*ier != 0) {
	return 0;
    }

/*     Set TOL(I) = sum of absolute values in column I of RBAR after */
/*     scaling each element by the square root of its row multiplier. */

    i__1 = *np;
    for (col = 1; col <= i__1; ++col) {
/* L10: */
	work[col] = sqrt(d__[col]);
    }
    i__1 = *np;
    for (col = 1; col <= i__1; ++col) {
	pos = col - 1;
	sum = work[col];
	i__2 = col - 1;
	for (row = 1; row <= i__2; ++row) {
	    sum += (d__1 = rbar[pos], abs(d__1)) * work[row];
	    pos = pos + *np - row - 1;
/* L20: */
	}
	tol[col] = eps * sum;
/* L30: */
    }

    return 0;
} /* tolset_ */


/* Subroutine */ int sing_(integer *np, integer *nrbar, doublereal *d__, 
	doublereal *rbar, doublereal *thetab, doublereal *sserr, doublereal *
	tol, logical *lindep, doublereal *work, integer *ier)
{
    /* Initialized data */

    static doublereal zero = 0.;

    /* System generated locals */
    integer i__1, i__2;
    doublereal d__1;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    static integer np2, col, pos, row, pos2;
    static doublereal temp;
    extern /* Subroutine */ int includ_(integer *, integer *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, integer *);


/*     ALGORITHM AS274.5  APPL. STATIST. (1992) VOL 41, NO.2 */

/*     Checks for singularities, reports, and adjusts orthogonal */
/*     reductions produced by AS75.1. */


/*     Local variables */


    /* Parameter adjustments */
    --work;
    --lindep;
    --tol;
    --thetab;
    --d__;
    --rbar;

    /* Function Body */

/*     Check input parameters */

    *ier = 0;
    if (*np <= 0) {
	*ier = 1;
    }
    if (*nrbar < *np * (*np - 1) / 2) {
	*ier += 2;
    }
    if (*ier != 0) {
	return 0;
    }

    i__1 = *np;
    for (col = 1; col <= i__1; ++col) {
/* L10: */
	work[col] = sqrt(d__[col]);
    }

    i__1 = *np;
    for (col = 1; col <= i__1; ++col) {

/*     Set elements within RBAR to zero if they are less than TOL(COL) in */
/*     absolute value after being scaled by the square root of their row */
/*     multiplier. */

	temp = tol[col];
	pos = col - 1;
	i__2 = col - 1;
	for (row = 1; row <= i__2; ++row) {
	    if ((d__1 = rbar[pos], abs(d__1)) * work[row] < temp) {
		rbar[pos] = zero;
	    }
	    pos = pos + *np - row - 1;
/* L30: */
	}

/*     If diagonal element is near zero, set it to zero, set appropriate */
/*     element of LINDEP, and use INCLUD to augment the projections in */
/*     the lower rows of the orthogonalization. */

	lindep[col] = FALSE_;
	if (work[col] < temp) {
	    lindep[col] = TRUE_;
	    --(*ier);
	    if (col < *np) {
		np2 = *np - col;
		pos2 = pos + *np - col + 1;
		i__2 = np2 * (np2 - 1) / 2;
		includ_(&np2, &i__2, &d__[col], &rbar[pos + 1], &thetab[col], 
			&d__[col + 1], &rbar[pos2], &thetab[col + 1], sserr, 
			ier);
	    } else {
/* Computing 2nd power */
		d__1 = thetab[col];
		*sserr += d__[col] * (d__1 * d__1);
	    }
	    d__[col] = zero;
	    work[col] = zero;
	    thetab[col] = zero;
	}
/* L40: */
    }
    return 0;
} /* sing_ */


/* Subroutine */ int ss_(integer *np, doublereal *d__, doublereal *thetab, 
	doublereal *sserr, doublereal *rss, integer *ier)
{
    /* System generated locals */
    doublereal d__1;

    /* Local variables */
    static integer i__;
    static doublereal sum;


/*     ALGORITHM AS274.6  APPL. STATIST. (1992) VOL 41, NO.2 */

/*     Calculates partial residual sums of squares from an orthogonal */
/*     reduction from AS75.1. */


/*     Local variables */


/*     Some checks. */

    /* Parameter adjustments */
    --rss;
    --thetab;
    --d__;

    /* Function Body */
    *ier = 0;
    if (*np < 1) {
	*ier = 1;
    }
    if (*ier != 0) {
	return 0;
    }

    sum = *sserr;
    rss[*np] = *sserr;
    for (i__ = *np; i__ >= 2; --i__) {
/* Computing 2nd power */
	d__1 = thetab[i__];
	sum += d__[i__] * (d__1 * d__1);
	rss[i__ - 1] = sum;
/* L10: */
    }
    return 0;
} /* ss_ */


/* Subroutine */ int cov_(integer *np, integer *nrbar, doublereal *d__, 
	doublereal *rbar, integer *nreq, doublereal *rinv, doublereal *var, 
	doublereal *covmat, integer *dimcov, doublereal *sterr, integer *ier)
{
    /* Initialized data */

    static doublereal zero = 0.;
    static doublereal one = 1.;

    /* System generated locals */
    integer i__1, i__2, i__3;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    static integer k, col;
    extern /* Subroutine */ int inv_(integer *, integer *, doublereal *, 
	    integer *, doublereal *);
    static integer pos;
    static doublereal sum;
    static integer row, pos1, pos2, start;


/*     ALGORITHM AS274.7  APPL. STATIST. (1992) VOL 41, NO.2 */

/*     Calculate covariance matrix for regression coefficients for the */
/*     first NREQ variables, from an orthogonal reduction produced from */
/*     AS75.1. */

/*     Auxiliary routine called: INV */


/*     Local variables. */


    /* Parameter adjustments */
    --sterr;
    --d__;
    --rbar;
    --rinv;
    --covmat;

    /* Function Body */

/*     Some checks. */

    *ier = 0;
    if (*np < 1) {
	*ier = 1;
    }
    if (*nrbar < *np * (*np - 1) / 2) {
	*ier += 2;
    }
    if (*dimcov < *nreq * (*nreq + 1) / 2) {
	*ier += 4;
    }
    i__1 = *nreq;
    for (row = 1; row <= i__1; ++row) {
	if (d__[row] == zero) {
	    *ier = -row;
	}
/* L10: */
    }
    if (*ier != 0) {
	return 0;
    }

    inv_(np, nrbar, &rbar[1], nreq, &rinv[1]);
    pos = 1;
    start = 1;
    i__1 = *nreq;
    for (row = 1; row <= i__1; ++row) {
	pos2 = start;
	i__2 = *nreq;
	for (col = row; col <= i__2; ++col) {
	    pos1 = start + col - row;
	    if (row == col) {
		sum = one / d__[col];
	    } else {
		sum = rinv[pos1 - 1] / d__[col];
	    }
	    i__3 = *nreq;
	    for (k = col + 1; k <= i__3; ++k) {
		sum += rinv[pos1] * rinv[pos2] / d__[k];
		++pos1;
		++pos2;
/* L20: */
	    }
	    covmat[pos] = sum * *var;
	    if (row == col) {
		sterr[row] = sqrt(covmat[pos]);
	    }
	    ++pos;
/* L30: */
	}
	start = start + *nreq - row;
/* L40: */
    }

    return 0;
} /* cov_ */


/* Subroutine */ int inv_(integer *np, integer *nrbar, doublereal *rbar, 
	integer *nreq, doublereal *rinv)
{
    /* Initialized data */

    static doublereal zero = 0.;

    /* System generated locals */
    integer i__1, i__2;

    /* Local variables */
    static integer k, col, pos;
    static doublereal sum;
    static integer row, pos1, pos2, start;


/*     ALGORITHM AS274.8  APPL. STATIST. (1992) VOL 41, NO.2 */

/*     Invert first NREQ rows and columns of Cholesky factorization */
/*     produced by AS75.1. */


/*     Local variables. */


    /* Parameter adjustments */
    --rinv;
    --rbar;

    /* Function Body */

/*     Invert RBAR ignoring row multipliers, from the bottom up. */

    pos = *nreq * (*nreq - 1) / 2;
    for (row = *nreq - 1; row >= 1; --row) {
	start = (row - 1) * (*np + *np - row) / 2 + 1;
	i__1 = row + 1;
	for (col = *nreq; col >= i__1; --col) {
	    pos1 = start;
	    pos2 = pos;
	    sum = zero;
	    i__2 = col - 1;
	    for (k = row + 1; k <= i__2; ++k) {
		pos2 = pos2 + *nreq - k;
		sum -= rbar[pos1] * rinv[pos2];
		++pos1;
/* L10: */
	    }
	    rinv[pos] = sum - rbar[pos1];
	    --pos;
/* L20: */
	}
/* L30: */
    }

    return 0;
} /* inv_ */


/* Subroutine */ int pcorr_(integer *np, integer *nrbar, doublereal *d__, 
	doublereal *rbar, doublereal *thetab, doublereal *sserr, integer *in, 
	doublereal *work, doublereal *cormat, integer *dimc, doublereal *
	ycorr, integer *ier)
{
    /* Initialized data */

    static doublereal zero = 0.;

    /* System generated locals */
    integer i__1;

    /* Local variables */
    static integer i__, in1;
    extern /* Subroutine */ int cor_(integer *, doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *);
    static integer start;


/*     ALGORITHM AS274.9  APPL. STATIST. (1992) VOL 41, NO.2 */

/*     Calculate partial correlations after the first IN variables */
/*     have been forced into the regression. */

/*     Auxiliary routine called: COR */


/*     Local variables. */


    /* Parameter adjustments */
    --work;
    --thetab;
    --d__;
    --rbar;
    --cormat;

    /* Function Body */

/*     Some checks. */

    *ier = 0;
    if (*np < 1) {
	*ier = 1;
    }
    if (*nrbar < *np * (*np - 1) / 2) {
	*ier += 2;
    }
    if (*in < 0 || *in > *np - 1) {
	*ier += 4;
    }
    if (*dimc < (*np - *in) * (*np - *in - 1) / 2) {
	*ier += 8;
    }
    if (*ier != 0) {
	return 0;
    }

    start = *in * (*np + *np - *in - 1) / 2 + 1;
    in1 = *in + 1;
    i__1 = *np - *in;
    cor_(&i__1, &d__[in1], &rbar[start], &thetab[in1], sserr, &work[1], &
	    cormat[1], ycorr);

/*     Check for zeroes. */

    i__1 = *np - *in;
    for (i__ = 1; i__ <= i__1; ++i__) {
	if (work[i__] <= zero) {
	    *ier = -i__;
	}
/* L10: */
    }

    return 0;
} /* pcorr_ */


/* Subroutine */ int cor_(integer *np, doublereal *d__, doublereal *rbar, 
	doublereal *thetab, doublereal *sserr, doublereal *work, doublereal *
	cormat, doublereal *ycorr)
{
    /* Initialized data */

    static doublereal zero = 0.;

    /* System generated locals */
    integer i__1, i__2;
    doublereal d__1;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    static integer pos;
    static doublereal sum;
    static integer row, col1, col2, pos1, pos2, diff;
    static doublereal sumy;


/*     ALGORITHM AS274.10  APPL. STATIST. (1992) VOL 41, NO.2 */

/*     Calculate correlations from an orthogonal reduction.   This */
/*     routine will usually be called from PCORR, which will have */
/*     removed the appropriate number of rows at the start. */


/*     Local variables. */


    /* Parameter adjustments */
    --ycorr;
    --work;
    --thetab;
    --d__;
    --rbar;
    --cormat;

    /* Function Body */

/*     Process by columns, including the projections of the dependent */
/*     variable (THETAB). */

    sumy = *sserr;
    i__1 = *np;
    for (row = 1; row <= i__1; ++row) {
/* L10: */
/* Computing 2nd power */
	d__1 = thetab[row];
	sumy += d__[row] * (d__1 * d__1);
    }
    sumy = sqrt(sumy);
    pos = *np * (*np - 1) / 2;
    for (col1 = *np; col1 >= 1; --col1) {

/*     Calculate the length of column COL1. */

	sum = d__[col1];
	pos1 = col1 - 1;
	i__1 = col1 - 1;
	for (row = 1; row <= i__1; ++row) {
/* Computing 2nd power */
	    d__1 = rbar[pos1];
	    sum += d__[row] * (d__1 * d__1);
	    pos1 = pos1 + *np - row - 1;
/* L20: */
	}
	work[col1] = sqrt(sum);

/*     If SUM = 0, set all correlations with this variable to zero. */

	if (sum == zero) {
	    ycorr[col1] = zero;
	    i__1 = col1 + 1;
	    for (col2 = *np; col2 >= i__1; --col2) {
		cormat[pos] = zero;
		--pos;
/* L30: */
	    }
	    goto L70;
	}

/*     Form cross-products, then divide by product of column lengths. */

	sum = d__[col1] * thetab[col1];
	pos1 = col1 - 1;
	i__1 = col1 - 1;
	for (row = 1; row <= i__1; ++row) {
	    sum += d__[row] * rbar[pos1] * thetab[row];
	    pos1 = pos1 + *np - row - 1;
/* L40: */
	}
	ycorr[col1] = sum / (sumy * work[col1]);

	i__1 = col1 + 1;
	for (col2 = *np; col2 >= i__1; --col2) {
	    if (work[col2] > zero) {
		pos1 = col1 - 1;
		pos2 = col2 - 1;
		diff = col2 - col1;
		sum = zero;
		i__2 = col1 - 1;
		for (row = 1; row <= i__2; ++row) {
		    sum += d__[row] * rbar[pos1] * rbar[pos2];
		    pos1 = pos1 + *np - row - 1;
		    pos2 = pos1 + diff;
/* L50: */
		}
		sum += d__[col1] * rbar[pos2];
		cormat[pos] = sum / (work[col1] * work[col2]);
	    } else {
		cormat[pos] = zero;
	    }
	    --pos;
/* L60: */
	}
L70:
	;
    }

    return 0;
} /* cor_ */


/* Subroutine */ int vmove_(integer *np, integer *nrbar, integer *vorder, 
	doublereal *d__, doublereal *rbar, doublereal *thetab, doublereal *
	rss, integer *from, integer *to, doublereal *tol, integer *ier)
{
    /* Initialized data */

    static doublereal zero = 0.;
    static doublereal one = 1.;

    /* System generated locals */
    integer i__1, i__2, i__3;
    doublereal d__1;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    static integer m;
    static doublereal x, y, d1, d2;
    static integer m1, m2, mp1, inc, col, pos, row;
    static doublereal cbar, sbar;
    static integer last;
    static doublereal d1new, d2new;
    static integer first;


/*     ALGORITHM AS274.11 APPL. STATIST. (1992) VOL 41, NO.2 */

/*     Move variable from position FROM to position TO in an */
/*     orthogonal reduction produced by AS75.1. */


/*     Local variables */


    /* Parameter adjustments */
    --tol;
    --rss;
    --thetab;
    --d__;
    --vorder;
    --rbar;

    /* Function Body */

/*     Check input parameters */

    *ier = 0;
    if (*np <= 0) {
	*ier = 1;
    }
    if (*nrbar < *np * (*np - 1) / 2) {
	*ier += 2;
    }
    if (*from < 1 || *from > *np) {
	*ier += 4;
    }
    if (*to < 1 || *to > *np) {
	*ier += 8;
    }
    if (*ier != 0) {
	return 0;
    }

    if (*from == *to) {
	return 0;
    }

    if (*from < *to) {
	first = *from;
	last = *to - 1;
	inc = 1;
    } else {
	first = *from - 1;
	last = *to;
	inc = -1;
    }
    i__1 = last;
    i__2 = inc;
    for (m = first; i__2 < 0 ? m >= i__1 : m <= i__1; m += i__2) {

/*     Find addresses of first elements of RBAR in rows M and (M+1). */

	m1 = (m - 1) * (*np + *np - m) / 2 + 1;
	m2 = m1 + *np - m;
	mp1 = m + 1;
	d1 = d__[m];
	d2 = d__[mp1];

/*     Special cases. */

	if (d1 == zero && d2 == zero) {
	    goto L40;
	}
	x = rbar[m1];
	if (abs(x) * sqrt(d1) < tol[mp1]) {
	    x = zero;
	}
	if (d1 == zero || x == zero) {
	    d__[m] = d2;
	    d__[mp1] = d1;
	    rbar[m1] = zero;
	    i__3 = *np;
	    for (col = m + 2; col <= i__3; ++col) {
		++m1;
		x = rbar[m1];
		rbar[m1] = rbar[m2];
		rbar[m2] = x;
		++m2;
/* L10: */
	    }
	    x = thetab[m];
	    thetab[m] = thetab[mp1];
	    thetab[mp1] = x;
	    goto L40;
	} else if (d2 == zero) {
/* Computing 2nd power */
	    d__1 = x;
	    d__[m] = d1 * (d__1 * d__1);
	    rbar[m1] = one / x;
	    i__3 = *np;
	    for (col = m + 2; col <= i__3; ++col) {
		++m1;
		rbar[m1] /= x;
/* L20: */
	    }
	    thetab[m] /= x;
	    goto L40;
	}

/*     Planar rotation in regular case. */

/* Computing 2nd power */
	d__1 = x;
	d1new = d2 + d1 * (d__1 * d__1);
	cbar = d2 / d1new;
	sbar = x * d1 / d1new;
	d2new = d1 * cbar;
	d__[m] = d1new;
	d__[mp1] = d2new;
	rbar[m1] = sbar;
	i__3 = *np;
	for (col = m + 2; col <= i__3; ++col) {
	    ++m1;
	    y = rbar[m1];
	    rbar[m1] = cbar * rbar[m2] + sbar * y;
	    rbar[m2] = y - x * rbar[m2];
	    ++m2;
/* L30: */
	}
	y = thetab[m];
	thetab[m] = cbar * thetab[mp1] + sbar * y;
	thetab[mp1] = y - x * thetab[mp1];

/*     Swap columns M and (M+1) down to row (M-1). */

L40:
	if (m == 1) {
	    goto L60;
	}
	pos = m;
	i__3 = m - 1;
	for (row = 1; row <= i__3; ++row) {
	    x = rbar[pos];
	    rbar[pos] = rbar[pos - 1];
	    rbar[pos - 1] = x;
	    pos = pos + *np - row - 1;
/* L50: */
	}

/*     Adjust variable order (VORDER), the tolerances (TOL) and */
/*     the vector of residual sums of squares (RSS). */

L60:
	m1 = vorder[m];
	vorder[m] = vorder[mp1];
	vorder[mp1] = m1;
	x = tol[m];
	tol[m] = tol[mp1];
	tol[mp1] = x;
/* Computing 2nd power */
	d__1 = thetab[mp1];
	rss[m] = rss[mp1] + d__[mp1] * (d__1 * d__1);
/* L70: */
    }

    return 0;
} /* vmove_ */


/* Subroutine */ int reordr_(integer *np, integer *nrbar, integer *vorder, 
	doublereal *d__, doublereal *rbar, doublereal *thetab, doublereal *
	rss, doublereal *tol, integer *list, integer *n, integer *pos1, 
	integer *ier)
{
    /* System generated locals */
    integer i__1;

    /* Local variables */
    static integer i__, j, l, next;
    extern /* Subroutine */ int vmove_(integer *, integer *, integer *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, integer *,
	     integer *, doublereal *, integer *);


/*     ALGORITHM AS274.12  APPL. STATIST. (1992) VOL 41, NO.2 */

/*     Re-order the variables in an orthogonal reduction produced by */
/*     AS75.1 so that the N variables in LIST start at position POS1, */
/*     though will not necessarily be in the same order as in LIST. */
/*     Any variables in VORDER before position POS1 are not moved. */

/*     Auxiliary routine called: VMOVE */


/*     Local variables. */


/*     Check N. */

    /* Parameter adjustments */
    --tol;
    --rss;
    --thetab;
    --d__;
    --vorder;
    --rbar;
    --list;

    /* Function Body */
    *ier = 0;
    if (*np < 1) {
	*ier = 1;
    }
    if (*nrbar < *np * (*np - 1) / 2) {
	*ier += 2;
    }
    if (*n < 1 || *n >= *np + 1 - *pos1) {
	*ier += 4;
    }
    if (*ier != 0) {
	return 0;
    }

/*     Work through VORDER finding variables which are in LIST. */

    next = *pos1;
    i__ = *pos1;
L10:
    l = vorder[i__];
    i__1 = *n;
    for (j = 1; j <= i__1; ++j) {
	if (l == list[j]) {
	    goto L40;
	}
/* L20: */
    }
L30:
    ++i__;
    if (i__ <= *np) {
	goto L10;
    }

/*     If this point is reached, one or more variables in LIST has not */
/*     been found. */

    *ier = 8;
    return 0;

/*     Variable L is in LIST; move it up to position NEXT if it is not */
/*     already there. */

L40:
    if (i__ > next) {
	vmove_(np, nrbar, &vorder[1], &d__[1], &rbar[1], &thetab[1], &rss[1], 
		&i__, &next, &tol[1], ier);
    }
    ++next;
    if (next < *n + *pos1) {
	goto L30;
    }

    return 0;
} /* reordr_ */


/* Subroutine */ int hdiag_(doublereal *xrow, integer *np, integer *nrbar, 
	doublereal *d__, doublereal *rbar, doublereal *tol, integer *nreq, 
	doublereal *hii, doublereal *wk, integer *ifault)
{
    /* Initialized data */

    static doublereal zero = 0.;

    /* System generated locals */
    integer i__1, i__2;
    doublereal d__1;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    static integer col, pos;
    static doublereal sum;
    static integer row;


/*     ALGORITHM AS274.13  APPL. STATIST. (1992) VOL.41, NO.2 */


/*     Local variables */


    /* Parameter adjustments */
    --wk;
    --tol;
    --d__;
    --xrow;
    --rbar;

    /* Function Body */

/*     Some checks */

    *ifault = 0;
    if (*np < 1) {
	*ifault = 1;
    }
    if (*nrbar < *np * (*np - 1) / 2) {
	*ifault += 2;
    }
    if (*nreq > *np) {
	*ifault += 4;
    }
    if (*ifault != 0) {
	return 0;
    }

/*     The elements of XROW.inv(RBAR).sqrt(D) are calculated and stored */
/*     in WK. */

    *hii = zero;
    i__1 = *nreq;
    for (col = 1; col <= i__1; ++col) {
	if (sqrt(d__[col]) <= tol[col]) {
	    wk[col] = zero;
	    goto L20;
	}
	pos = col - 1;
	sum = xrow[col];
	i__2 = col - 1;
	for (row = 1; row <= i__2; ++row) {
	    sum -= wk[row] * rbar[pos];
	    pos = pos + *np - row - 1;
/* L10: */
	}
	wk[col] = sum;
/* Computing 2nd power */
	d__1 = sum;
	*hii += d__1 * d__1 / d__[col];
L20:
	;
    }

    return 0;
} /* hdiag_ */

