/*! _dsymatrix*double operator */
inline _dsymatrix operator*(const _dsymatrix& mat, const double& d)
{
#ifdef CPPL_VERBOSE
std::cerr << "# [MARK] operator*(const _dsymatrix&, const double&)"
<< std::endl;
#endif//CPPL_VERBOSE
dscal_(mat.N*mat.N, d, mat.Array, 1);
return mat;
}
void EucQuadratic::Grad(Variable *x, Vector *gf) const
{
double *gfTV = gf->ObtainWriteEntireData();
const SharedSpace *Temp = x->ObtainReadTempData("Ax");
const double *v = Temp->ObtainReadData();
integer N = Dim, inc = 1;
dcopy_(&N, const_cast<double *> (v), &inc, gfTV, &inc);
double two = 2;
dscal_(&N, &two, gfTV, &inc);
};
/* ************************************************************
TIME-CRITICAL PROCEDURE -- isscalarmul(x,alpha,n)
Computes x *= alpha using BLAS.
************************************************************ */
void isscalarmul(double *x, const double alpha, const mwIndex n)
{
mwIndex one=1;
#ifdef PC
dscal(&n,&alpha,x,&one);
#endif
#ifdef UNIX
dscal_(&n,&alpha,x,&one);
#endif
return;
}
void StieSumBrockett::EucHessianEta(Variable *x, Vector *etax, Vector *exix) const
{
ProductElement *prodx = dynamic_cast<ProductElement *> (x);
ProductElement *prodetax = dynamic_cast<ProductElement *> (etax);
ProductElement *prodexix = dynamic_cast<ProductElement *> (exix);
prodexix->NewMemoryOnWrite();
ProductManifold *ProdDomain = dynamic_cast<ProductManifold *> (Domain);
const double *etax1TV = prodetax->GetElement(0)->ObtainReadData();
double *exix1TV = prodexix->GetElement(0)->ObtainWriteEntireData();
char *transn = const_cast<char *> ("n");
integer N = n, P = p, inc = 1, Length = N * P;
double one = 1, zero = 0, negone = -1, two = 2;
dgemm_(transn, transn, &N, &P, &N, &one, B1, &N, const_cast<double *> (etax1TV), &N, &zero, exix1TV, &N);
for (integer i = 0; i < p; i++)
{
dscal_(&N, &D1[i], exix1TV + i * n, &inc);
}
ProdDomain->GetManifold(0)->ScaleTimesVector(prodx->GetElement(0), 2.0, prodexix->GetElement(0), prodexix->GetElement(0));
const double *etax2TV = prodetax->GetElement(1)->ObtainReadData();
double *exix2TV = prodexix->GetElement(1)->ObtainWriteEntireData();
dgemm_(transn, transn, &N, &P, &N, &one, B2, &N, const_cast<double *> (etax2TV), &N, &zero, exix2TV, &N);
for (integer i = 0; i < p; i++)
{
dscal_(&N, &D2[i], exix2TV + i * n, &inc);
}
ProdDomain->GetManifold(0)->ScaleTimesVector(prodx->GetElement(1), 2.0, prodexix->GetElement(1), prodexix->GetElement(1));
const double *etax3TV = prodetax->GetElement(2)->ObtainReadData();
double *exix3TV = prodexix->GetElement(2)->ObtainWriteEntireData();
integer M = m, Q = q;
Length = N * P;
dgemm_(transn, transn, &M, &Q, &M, &one, B3, &M, const_cast<double *> (etax3TV), &M, &zero, exix3TV, &M);
for (integer i = 0; i < q; i++)
{
dscal_(&M, &D3[i], exix3TV + i * m, &inc);
}
ProdDomain->GetManifold(1)->ScaleTimesVector(prodx->GetElement(2), 2.0, prodexix->GetElement(2), prodexix->GetElement(2));
};
void EucQuadratic::Grad(Variable *x, Vector *gf) const
{
double *gfTV = gf->ObtainWriteEntireData();
const SharedSpace *Temp = x->ObtainReadTempData("Ax");
const double *v = Temp->ObtainReadData();
integer N = Dim, inc = 1;
// gfTV <- v, details: http://www.netlib.org/lapack/explore-html/da/d6c/dcopy_8f.html
dcopy_(&N, const_cast<double *> (v), &inc, gfTV, &inc);
double two = 2;
// gfTV <- 2 * gfTV, details: http://www.netlib.org/lapack/explore-html/da/d6c/dcopy_8f.html
dscal_(&N, &two, gfTV, &inc);
};
/* Subroutine */ int waxpby_(integer *n, doublereal *w, doublereal *alpha,
doublereal *x, real *beta, doublereal *y, doublereal *yy)
{
static integer incx, incy;
extern /* Subroutine */ int dscal_(integer *, real *, doublereal *,
integer *), dcopy_(integer *, doublereal *, integer *, doublereal
*, integer *), daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
/* WAXPBY */
/* in */
/* alpha : scalar, */
/* x : vector, */
/* beta : scalar, */
/* y : vector */
/* out */
/* w : vector */
/* { */
/* w = alpha * x + beta * y */
/* } */
/* Parameter adjustments */
--yy;
--y;
--x;
--w;
/* Function Body */
incx = 1;
incy = 1;
/* Copy y into yy so that input is not overwritten. */
dcopy_(n, &y[1], &incx, &yy[1], &incy);
/* Put beta*yy into yy */
dscal_(n, beta, &yy[1], &incx);
/* Put x + yy into yy */
daxpy_(n, alpha, &x[1], &incx, &yy[1], &incy);
/* Copy yy into w. */
dcopy_(n, &yy[1], &incx, &w[1], &incy);
return 0;
} /* waxpby_ */
void L2SphereVariable::RandInManifold(void)
{
this->RandGaussian();
double norm = Space[0] * Space[0] / 2;
for (integer i = 1; i < length - 1; i++)
{
norm += Space[i] * Space[i];
}
norm += Space[length - 1] * Space[length - 1] / 2;
norm /= (length - 1);
norm = sqrt(norm);
double a = 1.0 / norm;
integer inc = 1;
dscal_(&length, &a, Space, &inc);
};
void L2SphereVariable::RandInManifold(void)
{
this->RandGaussian();
double norm = Space[0] * Space[0] / 2;
for (integer i = 1; i < length - 1; i++)
{
norm += Space[i] * Space[i];
}
norm += Space[length - 1] * Space[length - 1] / 2;
norm /= (length - 1);
norm = sqrt(norm);
double a = 1.0 / norm;
integer inc = 1;
// Space <- a * Space, details: http://www.netlib.org/lapack/explore-html/d4/dd0/dscal_8f.html
dscal_(&length, &a, Space, &inc);
};
PyObject* scal(PyObject *self, PyObject *args)
{
Py_complex alpha;
PyArrayObject* x;
if (!PyArg_ParseTuple(args, "DO", &alpha, &x))
return NULL;
int n = PyArray_DIMS(x)[0];
for (int d = 1; d < PyArray_NDIM(x); d++)
n *= PyArray_DIMS(x)[d];
int incx = 1;
if (PyArray_DESCR(x)->type_num == NPY_DOUBLE)
dscal_(&n, &(alpha.real), DOUBLEP(x), &incx);
else
zscal_(&n, &alpha, (void*)COMPLEXP(x), &incx);
Py_RETURN_NONE;
}
int TRON::trcg(double *g, double *s, double *r, int num_sample, long int *num_data)
{
int i, inc = 1;
int n = fun_obj->get_nr_variable();
double one = 1;
double *d = new double[n];
double *Hd = new double[n];
double rTr, rnewTrnew, alpha, beta, cgtol;
for (i=0; i<n; i++)
{
Hd[i] = 0.0;
s[i] = 0.0;
r[i] = -g[i];
d[i] = r[i];
}
cgtol = 0.1*dnrm2_(&n, g, &inc);
int cg_iter = 0;
rTr = ddot_(&n, r, &inc, r, &inc);
while (1)
{
if (dnrm2_(&n, r, &inc) <= cgtol || cg_iter >= max_cg_iter)
break;
cg_iter++;
fun_obj->sample_Hv(d, Hd, num_data);
alpha = rTr/ddot_(&n, d, &inc, Hd, &inc);
daxpy_(&n, &alpha, d, &inc, s, &inc);
alpha = -alpha;
daxpy_(&n, &alpha, Hd, &inc, r, &inc);
rnewTrnew = ddot_(&n, r, &inc, r, &inc);
beta = rnewTrnew/rTr;
dscal_(&n, &beta, d, &inc);
daxpy_(&n, &one, r, &inc, d, &inc);
rTr = rnewTrnew;
}
delete[] d;
delete[] Hd;
return(cg_iter);
}
/*** x(:,j) *= alpha ***/
void
mm_real_xj_scale (mm_real *x, const int j, const double alpha)
{
int n;
double *data;
if (mm_real_is_symmetric (x)) error_and_exit ("mm_real_xj_scale", "matrix must be general.", __FILE__, __LINE__);
if (j < 0 || x->n <= j) error_and_exit ("mm_real_xj_scale", "index out of range.", __FILE__, __LINE__);
if (mm_real_is_sparse (x)) {
int p = x->p[j];
n = x->p[j + 1] - p;
data = x->data + p;
} else {
n = x->m;
data = x->data + j * x->m;
}
dscal_ (&n, &alpha, data, &ione);
return;
}
/* Subroutine */ int dpptri_(char *uplo, integer *n, doublereal *ap, integer *
info)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer j, jc, jj;
doublereal ajj;
integer jjn;
logical upper;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DPPTRI computes the inverse of a real symmetric positive definite */
/* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T */
/* computed by DPPTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangular factor is stored in AP; */
/* = 'L': Lower triangular factor is stored in AP. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* On entry, the triangular factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T, packed columnwise as */
/* a linear array. The j-th column of U or L is stored in the */
/* array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
/* On exit, the upper or lower triangle of the (symmetric) */
/* inverse of A, overwriting the input factor U or L. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the (i,i) element of the factor U or L is */
/* zero, and the inverse could not be computed. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DPPTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Invert the triangular Cholesky factor U or L. */
dtptri_(uplo, "Non-unit", n, &ap[1], info);
if (*info > 0) {
return 0;
}
if (upper) {
/* Compute the product inv(U) * inv(U)'. */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jc = jj + 1;
jj += j;
if (j > 1) {
i__2 = j - 1;
dspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]);
}
ajj = ap[jj];
dscal_(&j, &ajj, &ap[jc], &c__1);
}
} else {
/* Compute the product inv(L)' * inv(L). */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jjn = jj + *n - j + 1;
i__2 = *n - j + 1;
ap[jj] = ddot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1);
if (j < *n) {
i__2 = *n - j;
dtpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[
jj + 1], &c__1);
}
jj = jjn;
}
}
return 0;
/* End of DPPTRI */
} /* dpptri_ */
/*< SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) >*/
/* Subroutine */ int dsptrf_(char *uplo, integer *n, doublereal *ap, integer *ipiv,
integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal c__;
integer j, k;
doublereal s, t, r1, r2;
integer kc, kk, kp, kx, knc, kpc=0, npp, imax=0, jmax;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *), dspr_(char *
, integer *, doublereal *, doublereal *, integer *, doublereal *,
ftnlen);
doublereal alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(const char *, const char *, ftnlen, ftnlen);
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer kstep;
logical upper;
extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
doublereal absakk;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
doublereal colmax, rowmax;
(void)uplo_len;
/* -- LAPACK routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/*< CHARACTER UPLO >*/
/*< INTEGER INFO, N >*/
/* .. */
/* .. Array Arguments .. */
/*< INTEGER IPIV( * ) >*/
/*< DOUBLE PRECISION AP( * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* DSPTRF computes the factorization of a real symmetric matrix A stored */
/* in packed format using the Bunch-Kaufman diagonal pivoting method: */
/* A = U*D*U**T or A = L*D*L**T */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, and D is symmetric and block diagonal with */
/* 1-by-1 and 2-by-2 diagonal blocks. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the symmetric matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L, stored as a packed triangular */
/* matrix overwriting A (see below for further details). */
/* IPIV (output) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D. */
/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
/* has been completed, but the block diagonal matrix D is */
/* exactly singular, and division by zero will occur if it */
/* is used to solve a system of equations. */
/* Further Details */
/* =============== */
/* If UPLO = 'U', then A = U*D*U', where */
/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
/* ( I v 0 ) k-s */
/* U(k) = ( 0 I 0 ) s */
/* ( 0 0 I ) n-k */
/* k-s s n-k */
/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
/* If UPLO = 'L', then A = L*D*L', where */
/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
/* ( I 0 0 ) k-1 */
/* L(k) = ( 0 I 0 ) s */
/* ( 0 v I ) n-k-s+1 */
/* k-1 s n-k-s+1 */
/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
/* ===================================================================== */
/* .. Parameters .. */
/*< DOUBLE PRECISION ZERO, ONE >*/
/*< PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) >*/
/*< DOUBLE PRECISION EIGHT, SEVTEN >*/
/*< PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< LOGICAL UPPER >*/
/*< >*/
/*< DOUBLE PRECISION ABSAKK, ALPHA, C, COLMAX, R1, R2, ROWMAX, S, T >*/
/* .. */
/* .. External Functions .. */
/*< LOGICAL LSAME >*/
/*< INTEGER IDAMAX >*/
/*< EXTERNAL LSAME, IDAMAX >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL DLAEV2, DROT, DSCAL, DSPR, DSWAP, XERBLA >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC ABS, MAX, SQRT >*/
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/*< INFO = 0 >*/
/* Parameter adjustments */
--ipiv;
--ap;
/* Function Body */
*info = 0;
/*< UPPER = LSAME( UPLO, 'U' ) >*/
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
/*< IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN >*/
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
/*< INFO = -1 >*/
*info = -1;
/*< ELSE IF( N.LT.0 ) THEN >*/
} else if (*n < 0) {
/*< INFO = -2 >*/
*info = -2;
/*< END IF >*/
}
/*< IF( INFO.NE.0 ) THEN >*/
if (*info != 0) {
/*< CALL XERBLA( 'DSPTRF', -INFO ) >*/
i__1 = -(*info);
xerbla_("DSPTRF", &i__1, (ftnlen)6);
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/* Initialize ALPHA for use in choosing pivot block size. */
/*< ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT >*/
alpha = (sqrt(17.) + 1.) / 8.;
/*< IF( UPPER ) THEN >*/
if (upper) {
/* Factorize A as U*D*U' using the upper triangle of A */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2 */
/*< K = N >*/
k = *n;
/*< KC = ( N-1 )*N / 2 + 1 >*/
kc = (*n - 1) * *n / 2 + 1;
/*< 10 CONTINUE >*/
L10:
/*< KNC = KC >*/
knc = kc;
/* If K < 1, exit from loop */
/*< >*/
if (k < 1) {
goto L70;
}
/*< KSTEP = 1 >*/
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
/*< ABSAKK = ABS( AP( KC+K-1 ) ) >*/
absakk = (d__1 = ap[kc + k - 1], abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
/*< IF( K.GT.1 ) THEN >*/
if (k > 1) {
/*< IMAX = IDAMAX( K-1, AP( KC ), 1 ) >*/
i__1 = k - 1;
imax = idamax_(&i__1, &ap[kc], &c__1);
/*< COLMAX = ABS( AP( KC+IMAX-1 ) ) >*/
colmax = (d__1 = ap[kc + imax - 1], abs(d__1));
/*< ELSE >*/
} else {
/*< COLMAX = ZERO >*/
colmax = 0.;
/*< END IF >*/
}
/*< IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN >*/
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
/*< >*/
if (*info == 0) {
*info = k;
}
/*< KP = K >*/
kp = k;
/*< ELSE >*/
} else {
/*< IF( ABSAKK.GE.ALPHA*COLMAX ) THEN >*/
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
/*< KP = K >*/
kp = k;
/*< ELSE >*/
} else {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
/*< ROWMAX = ZERO >*/
rowmax = 0.;
/*< JMAX = IMAX >*/
jmax = imax;
/*< KX = IMAX*( IMAX+1 ) / 2 + IMAX >*/
kx = imax * (imax + 1) / 2 + imax;
/*< DO 20 J = IMAX + 1, K >*/
i__1 = k;
for (j = imax + 1; j <= i__1; ++j) {
/*< IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN >*/
if ((d__1 = ap[kx], abs(d__1)) > rowmax) {
/*< ROWMAX = ABS( AP( KX ) ) >*/
rowmax = (d__1 = ap[kx], abs(d__1));
/*< JMAX = J >*/
jmax = j;
/*< END IF >*/
}
/*< KX = KX + J >*/
kx += j;
/*< 20 CONTINUE >*/
/* L20: */
}
/*< KPC = ( IMAX-1 )*IMAX / 2 + 1 >*/
kpc = (imax - 1) * imax / 2 + 1;
/*< IF( IMAX.GT.1 ) THEN >*/
if (imax > 1) {
/*< JMAX = IDAMAX( IMAX-1, AP( KPC ), 1 ) >*/
i__1 = imax - 1;
jmax = idamax_(&i__1, &ap[kpc], &c__1);
/*< ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-1 ) ) ) >*/
/* Computing MAX */
d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - 1], abs(
d__1));
rowmax = max(d__2,d__3);
/*< END IF >*/
}
/*< IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN >*/
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
/*< KP = K >*/
kp = k;
/*< ELSE IF( ABS( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN >*/
} else if ((d__1 = ap[kpc + imax - 1], abs(d__1)) >= alpha *
rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
/*< KP = IMAX >*/
kp = imax;
/*< ELSE >*/
} else {
/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
/* pivot block */
/*< KP = IMAX >*/
kp = imax;
/*< KSTEP = 2 >*/
kstep = 2;
/*< END IF >*/
}
/*< END IF >*/
}
/*< KK = K - KSTEP + 1 >*/
kk = k - kstep + 1;
/*< >*/
if (kstep == 2) {
knc = knc - k + 1;
}
/*< IF( KP.NE.KK ) THEN >*/
if (kp != kk) {
/* Interchange rows and columns KK and KP in the leading */
/* submatrix A(1:k,1:k) */
/*< CALL DSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 ) >*/
i__1 = kp - 1;
dswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1);
/*< KX = KPC + KP - 1 >*/
kx = kpc + kp - 1;
/*< DO 30 J = KP + 1, KK - 1 >*/
i__1 = kk - 1;
for (j = kp + 1; j <= i__1; ++j) {
/*< KX = KX + J - 1 >*/
kx = kx + j - 1;
/*< T = AP( KNC+J-1 ) >*/
t = ap[knc + j - 1];
/*< AP( KNC+J-1 ) = AP( KX ) >*/
ap[knc + j - 1] = ap[kx];
/*< AP( KX ) = T >*/
ap[kx] = t;
/*< 30 CONTINUE >*/
/* L30: */
}
/*< T = AP( KNC+KK-1 ) >*/
t = ap[knc + kk - 1];
/*< AP( KNC+KK-1 ) = AP( KPC+KP-1 ) >*/
ap[knc + kk - 1] = ap[kpc + kp - 1];
/*< AP( KPC+KP-1 ) = T >*/
ap[kpc + kp - 1] = t;
/*< IF( KSTEP.EQ.2 ) THEN >*/
if (kstep == 2) {
/*< T = AP( KC+K-2 ) >*/
t = ap[kc + k - 2];
/*< AP( KC+K-2 ) = AP( KC+KP-1 ) >*/
ap[kc + k - 2] = ap[kc + kp - 1];
/*< AP( KC+KP-1 ) = T >*/
ap[kc + kp - 1] = t;
/*< END IF >*/
}
/*< END IF >*/
}
/* Update the leading submatrix */
/*< IF( KSTEP.EQ.1 ) THEN >*/
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = U(k)*D(k) */
/* where U(k) is the k-th column of U */
/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
/*< R1 = ONE / AP( KC+K-1 ) >*/
r1 = 1. / ap[kc + k - 1];
/*< CALL DSPR( UPLO, K-1, -R1, AP( KC ), 1, AP ) >*/
i__1 = k - 1;
d__1 = -r1;
dspr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1], (ftnlen)1);
/* Store U(k) in column k */
/*< CALL DSCAL( K-1, R1, AP( KC ), 1 ) >*/
i__1 = k - 1;
dscal_(&i__1, &r1, &ap[kc], &c__1);
/*< ELSE >*/
} else {
/* 2-by-2 pivot block D(k): columns k and k-1 now hold */
/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */
/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */
/* of U */
/* Perform a rank-2 update of A(1:k-2,1:k-2) as */
/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' */
/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
/* Convert this to two rank-1 updates by using the eigen- */
/* decomposition of D(k) */
/*< >*/
dlaev2_(&ap[kc - 1], &ap[kc + k - 2], &ap[kc + k - 1], &r1, &
r2, &c__, &s);
/*< R1 = ONE / R1 >*/
r1 = 1. / r1;
/*< R2 = ONE / R2 >*/
r2 = 1. / r2;
/*< CALL DROT( K-2, AP( KNC ), 1, AP( KC ), 1, C, S ) >*/
i__1 = k - 2;
drot_(&i__1, &ap[knc], &c__1, &ap[kc], &c__1, &c__, &s);
/*< CALL DSPR( UPLO, K-2, -R1, AP( KNC ), 1, AP ) >*/
i__1 = k - 2;
d__1 = -r1;
dspr_(uplo, &i__1, &d__1, &ap[knc], &c__1, &ap[1], (ftnlen)1);
/*< CALL DSPR( UPLO, K-2, -R2, AP( KC ), 1, AP ) >*/
i__1 = k - 2;
d__1 = -r2;
dspr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1], (ftnlen)1);
/* Store U(k) and U(k-1) in columns k and k-1 */
/*< CALL DSCAL( K-2, R1, AP( KNC ), 1 ) >*/
i__1 = k - 2;
dscal_(&i__1, &r1, &ap[knc], &c__1);
/*< CALL DSCAL( K-2, R2, AP( KC ), 1 ) >*/
i__1 = k - 2;
dscal_(&i__1, &r2, &ap[kc], &c__1);
/*< CALL DROT( K-2, AP( KNC ), 1, AP( KC ), 1, C, -S ) >*/
i__1 = k - 2;
d__1 = -s;
drot_(&i__1, &ap[knc], &c__1, &ap[kc], &c__1, &c__, &d__1);
/*< END IF >*/
}
/*< END IF >*/
}
/* Store details of the interchanges in IPIV */
/*< IF( KSTEP.EQ.1 ) THEN >*/
if (kstep == 1) {
/*< IPIV( K ) = KP >*/
ipiv[k] = kp;
/*< ELSE >*/
} else {
/*< IPIV( K ) = -KP >*/
ipiv[k] = -kp;
/*< IPIV( K-1 ) = -KP >*/
ipiv[k - 1] = -kp;
/*< END IF >*/
}
/* Decrease K and return to the start of the main loop */
/*< K = K - KSTEP >*/
k -= kstep;
/*< KC = KNC - K >*/
kc = knc - k;
/*< GO TO 10 >*/
goto L10;
/*< ELSE >*/
} else {
/* Factorize A as L*D*L' using the lower triangle of A */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2 */
/*< K = 1 >*/
k = 1;
/*< KC = 1 >*/
kc = 1;
/*< NPP = N*( N+1 ) / 2 >*/
npp = *n * (*n + 1) / 2;
/*< 40 CONTINUE >*/
L40:
/*< KNC = KC >*/
knc = kc;
/* If K > N, exit from loop */
/*< >*/
if (k > *n) {
goto L70;
}
/*< KSTEP = 1 >*/
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
/*< ABSAKK = ABS( AP( KC ) ) >*/
absakk = (d__1 = ap[kc], abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
/*< IF( K.LT.N ) THEN >*/
if (k < *n) {
/*< IMAX = K + IDAMAX( N-K, AP( KC+1 ), 1 ) >*/
i__1 = *n - k;
imax = k + idamax_(&i__1, &ap[kc + 1], &c__1);
/*< COLMAX = ABS( AP( KC+IMAX-K ) ) >*/
colmax = (d__1 = ap[kc + imax - k], abs(d__1));
/*< ELSE >*/
} else {
/*< COLMAX = ZERO >*/
colmax = 0.;
/*< END IF >*/
}
/*< IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN >*/
if (max(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
/*< >*/
if (*info == 0) {
*info = k;
}
/*< KP = K >*/
kp = k;
/*< ELSE >*/
} else {
/*< IF( ABSAKK.GE.ALPHA*COLMAX ) THEN >*/
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
/*< KP = K >*/
kp = k;
/*< ELSE >*/
} else {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
/*< ROWMAX = ZERO >*/
rowmax = 0.;
/*< KX = KC + IMAX - K >*/
kx = kc + imax - k;
/*< DO 50 J = K, IMAX - 1 >*/
i__1 = imax - 1;
for (j = k; j <= i__1; ++j) {
/*< IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN >*/
if ((d__1 = ap[kx], abs(d__1)) > rowmax) {
/*< ROWMAX = ABS( AP( KX ) ) >*/
rowmax = (d__1 = ap[kx], abs(d__1));
/*< JMAX = J >*/
jmax = j;
/*< END IF >*/
}
/*< KX = KX + N - J >*/
kx = kx + *n - j;
/*< 50 CONTINUE >*/
/* L50: */
}
/*< KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1 >*/
kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
/*< IF( IMAX.LT.N ) THEN >*/
if (imax < *n) {
/*< JMAX = IMAX + IDAMAX( N-IMAX, AP( KPC+1 ), 1 ) >*/
i__1 = *n - imax;
jmax = imax + idamax_(&i__1, &ap[kpc + 1], &c__1);
/*< ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-IMAX ) ) ) >*/
/* Computing MAX */
d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - imax], abs(
d__1));
rowmax = max(d__2,d__3);
/*< END IF >*/
}
/*< IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN >*/
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
/*< KP = K >*/
kp = k;
/*< ELSE IF( ABS( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN >*/
} else if ((d__1 = ap[kpc], abs(d__1)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
/*< KP = IMAX >*/
kp = imax;
/*< ELSE >*/
} else {
/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
/* pivot block */
/*< KP = IMAX >*/
kp = imax;
/*< KSTEP = 2 >*/
kstep = 2;
/*< END IF >*/
}
/*< END IF >*/
}
/*< KK = K + KSTEP - 1 >*/
kk = k + kstep - 1;
/*< >*/
if (kstep == 2) {
knc = knc + *n - k + 1;
}
/*< IF( KP.NE.KK ) THEN >*/
if (kp != kk) {
/* Interchange rows and columns KK and KP in the trailing */
/* submatrix A(k:n,k:n) */
/*< >*/
if (kp < *n) {
i__1 = *n - kp;
dswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1],
&c__1);
}
/*< KX = KNC + KP - KK >*/
kx = knc + kp - kk;
/*< DO 60 J = KK + 1, KP - 1 >*/
i__1 = kp - 1;
for (j = kk + 1; j <= i__1; ++j) {
/*< KX = KX + N - J + 1 >*/
kx = kx + *n - j + 1;
/*< T = AP( KNC+J-KK ) >*/
t = ap[knc + j - kk];
/*< AP( KNC+J-KK ) = AP( KX ) >*/
ap[knc + j - kk] = ap[kx];
/*< AP( KX ) = T >*/
ap[kx] = t;
/*< 60 CONTINUE >*/
/* L60: */
}
/*< T = AP( KNC ) >*/
t = ap[knc];
/*< AP( KNC ) = AP( KPC ) >*/
ap[knc] = ap[kpc];
/*< AP( KPC ) = T >*/
ap[kpc] = t;
/*< IF( KSTEP.EQ.2 ) THEN >*/
if (kstep == 2) {
/*< T = AP( KC+1 ) >*/
t = ap[kc + 1];
/*< AP( KC+1 ) = AP( KC+KP-K ) >*/
ap[kc + 1] = ap[kc + kp - k];
/*< AP( KC+KP-K ) = T >*/
ap[kc + kp - k] = t;
/*< END IF >*/
}
/*< END IF >*/
}
/* Update the trailing submatrix */
/*< IF( KSTEP.EQ.1 ) THEN >*/
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = L(k)*D(k) */
/* where L(k) is the k-th column of L */
/*< IF( K.LT.N ) THEN >*/
if (k < *n) {
/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
/*< R1 = ONE / AP( KC ) >*/
r1 = 1. / ap[kc];
/*< >*/
i__1 = *n - k;
d__1 = -r1;
dspr_(uplo, &i__1, &d__1, &ap[kc + 1], &c__1, &ap[kc + *n
- k + 1], (ftnlen)1);
/* Store L(k) in column K */
/*< CALL DSCAL( N-K, R1, AP( KC+1 ), 1 ) >*/
i__1 = *n - k;
dscal_(&i__1, &r1, &ap[kc + 1], &c__1);
/*< END IF >*/
}
/*< ELSE >*/
} else {
/* 2-by-2 pivot block D(k): columns K and K+1 now hold */
/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */
/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */
/* of L */
/*< IF( K.LT.N-1 ) THEN >*/
if (k < *n - 1) {
/* Perform a rank-2 update of A(k+2:n,k+2:n) as */
/* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )' */
/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
/* Convert this to two rank-1 updates by using the eigen- */
/* decomposition of D(k) */
/*< >*/
dlaev2_(&ap[kc], &ap[kc + 1], &ap[knc], &r1, &r2, &c__, &
s);
/*< R1 = ONE / R1 >*/
r1 = 1. / r1;
/*< R2 = ONE / R2 >*/
r2 = 1. / r2;
/*< >*/
i__1 = *n - k - 1;
drot_(&i__1, &ap[kc + 2], &c__1, &ap[knc + 1], &c__1, &
c__, &s);
/*< >*/
i__1 = *n - k - 1;
d__1 = -r1;
dspr_(uplo, &i__1, &d__1, &ap[kc + 2], &c__1, &ap[knc + *
n - k], (ftnlen)1);
/*< >*/
i__1 = *n - k - 1;
d__1 = -r2;
dspr_(uplo, &i__1, &d__1, &ap[knc + 1], &c__1, &ap[knc + *
n - k], (ftnlen)1);
/* Store L(k) and L(k+1) in columns k and k+1 */
/*< CALL DSCAL( N-K-1, R1, AP( KC+2 ), 1 ) >*/
i__1 = *n - k - 1;
dscal_(&i__1, &r1, &ap[kc + 2], &c__1);
/*< CALL DSCAL( N-K-1, R2, AP( KNC+1 ), 1 ) >*/
i__1 = *n - k - 1;
dscal_(&i__1, &r2, &ap[knc + 1], &c__1);
/*< >*/
i__1 = *n - k - 1;
d__1 = -s;
drot_(&i__1, &ap[kc + 2], &c__1, &ap[knc + 1], &c__1, &
c__, &d__1);
/*< END IF >*/
}
/*< END IF >*/
}
/*< END IF >*/
}
/* Store details of the interchanges in IPIV */
/*< IF( KSTEP.EQ.1 ) THEN >*/
if (kstep == 1) {
/*< IPIV( K ) = KP >*/
ipiv[k] = kp;
/*< ELSE >*/
} else {
/*< IPIV( K ) = -KP >*/
ipiv[k] = -kp;
/*< IPIV( K+1 ) = -KP >*/
ipiv[k + 1] = -kp;
/*< END IF >*/
}
/* Increase K and return to the start of the main loop */
/*< K = K + KSTEP >*/
k += kstep;
/*< KC = KNC + N - K + 2 >*/
kc = knc + *n - k + 2;
/*< GO TO 40 >*/
goto L40;
/*< END IF >*/
}
/*< 70 CONTINUE >*/
L70:
/*< RETURN >*/
return 0;
/* End of DSPTRF */
/*< END >*/
} /* dsptrf_ */
int dsptrf_(char *uplo, int *n, double *ap, int *
ipiv, int *info)
{
/* System generated locals */
int i__1, i__2;
double d__1, d__2, d__3;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int i__, j, k;
double t, r1, d11, d12, d21, d22;
int kc, kk, kp;
double wk;
int kx, knc, kpc, npp;
double wkm1, wkp1;
int imax, jmax;
extern int dspr_(char *, int *, double *,
double *, int *, double *);
double alpha;
extern int dscal_(int *, double *, double *,
int *);
extern int lsame_(char *, char *);
extern int dswap_(int *, double *, int *,
double *, int *);
int kstep;
int upper;
double absakk;
extern int idamax_(int *, double *, int *);
extern int xerbla_(char *, int *);
double colmax, rowmax;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSPTRF computes the factorization of a float symmetric matrix A stored */
/* in packed format using the Bunch-Kaufman diagonal pivoting method: */
/* A = U*D*U**T or A = L*D*L**T */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, and D is symmetric and block diagonal with */
/* 1-by-1 and 2-by-2 diagonal blocks. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the symmetric matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L, stored as a packed triangular */
/* matrix overwriting A (see below for further details). */
/* IPIV (output) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D. */
/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
/* has been completed, but the block diagonal matrix D is */
/* exactly singular, and division by zero will occur if it */
/* is used to solve a system of equations. */
/* Further Details */
/* =============== */
/* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services */
/* Company */
/* If UPLO = 'U', then A = U*D*U', where */
/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
/* ( I v 0 ) k-s */
/* U(k) = ( 0 I 0 ) s */
/* ( 0 0 I ) n-k */
/* k-s s n-k */
/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
/* If UPLO = 'L', then A = L*D*L', where */
/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
/* ( I 0 0 ) k-1 */
/* L(k) = ( 0 I 0 ) s */
/* ( 0 v I ) n-k-s+1 */
/* k-1 s n-k-s+1 */
/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ipiv;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSPTRF", &i__1);
return 0;
}
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.) + 1.) / 8.;
if (upper) {
/* Factorize A as U*D*U' using the upper triangle of A */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2 */
k = *n;
kc = (*n - 1) * *n / 2 + 1;
L10:
knc = kc;
/* If K < 1, exit from loop */
if (k < 1) {
goto L110;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
absakk = (d__1 = ap[kc + k - 1], ABS(d__1));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
if (k > 1) {
i__1 = k - 1;
imax = idamax_(&i__1, &ap[kc], &c__1);
colmax = (d__1 = ap[kc + imax - 1], ABS(d__1));
} else {
colmax = 0.;
}
if (MAX(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
rowmax = 0.;
jmax = imax;
kx = imax * (imax + 1) / 2 + imax;
i__1 = k;
for (j = imax + 1; j <= i__1; ++j) {
if ((d__1 = ap[kx], ABS(d__1)) > rowmax) {
rowmax = (d__1 = ap[kx], ABS(d__1));
jmax = j;
}
kx += j;
/* L20: */
}
kpc = (imax - 1) * imax / 2 + 1;
if (imax > 1) {
i__1 = imax - 1;
jmax = idamax_(&i__1, &ap[kpc], &c__1);
/* Computing MAX */
d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - 1], ABS(
d__1));
rowmax = MAX(d__2,d__3);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else if ((d__1 = ap[kpc + imax - 1], ABS(d__1)) >= alpha *
rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
} else {
/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
kk = k - kstep + 1;
if (kstep == 2) {
knc = knc - k + 1;
}
if (kp != kk) {
/* Interchange rows and columns KK and KP in the leading */
/* submatrix A(1:k,1:k) */
i__1 = kp - 1;
dswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1);
kx = kpc + kp - 1;
i__1 = kk - 1;
for (j = kp + 1; j <= i__1; ++j) {
kx = kx + j - 1;
t = ap[knc + j - 1];
ap[knc + j - 1] = ap[kx];
ap[kx] = t;
/* L30: */
}
t = ap[knc + kk - 1];
ap[knc + kk - 1] = ap[kpc + kp - 1];
ap[kpc + kp - 1] = t;
if (kstep == 2) {
t = ap[kc + k - 2];
ap[kc + k - 2] = ap[kc + kp - 1];
ap[kc + kp - 1] = t;
}
}
/* Update the leading submatrix */
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = U(k)*D(k) */
/* where U(k) is the k-th column of U */
/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
r1 = 1. / ap[kc + k - 1];
i__1 = k - 1;
d__1 = -r1;
dspr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1]);
/* Store U(k) in column k */
i__1 = k - 1;
dscal_(&i__1, &r1, &ap[kc], &c__1);
} else {
/* 2-by-2 pivot block D(k): columns k and k-1 now hold */
/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */
/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */
/* of U */
/* Perform a rank-2 update of A(1:k-2,1:k-2) as */
/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' */
/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
if (k > 2) {
d12 = ap[k - 1 + (k - 1) * k / 2];
d22 = ap[k - 1 + (k - 2) * (k - 1) / 2] / d12;
d11 = ap[k + (k - 1) * k / 2] / d12;
t = 1. / (d11 * d22 - 1.);
d12 = t / d12;
for (j = k - 2; j >= 1; --j) {
wkm1 = d12 * (d11 * ap[j + (k - 2) * (k - 1) / 2] -
ap[j + (k - 1) * k / 2]);
wk = d12 * (d22 * ap[j + (k - 1) * k / 2] - ap[j + (k
- 2) * (k - 1) / 2]);
for (i__ = j; i__ >= 1; --i__) {
ap[i__ + (j - 1) * j / 2] = ap[i__ + (j - 1) * j /
2] - ap[i__ + (k - 1) * k / 2] * wk - ap[
i__ + (k - 2) * (k - 1) / 2] * wkm1;
/* L40: */
}
ap[j + (k - 1) * k / 2] = wk;
ap[j + (k - 2) * (k - 1) / 2] = wkm1;
/* L50: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
/* Decrease K and return to the start of the main loop */
k -= kstep;
kc = knc - k;
goto L10;
} else {
/* Factorize A as L*D*L' using the lower triangle of A */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2 */
k = 1;
kc = 1;
npp = *n * (*n + 1) / 2;
L60:
knc = kc;
/* If K > N, exit from loop */
if (k > *n) {
goto L110;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
absakk = (d__1 = ap[kc], ABS(d__1));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
if (k < *n) {
i__1 = *n - k;
imax = k + idamax_(&i__1, &ap[kc + 1], &c__1);
colmax = (d__1 = ap[kc + imax - k], ABS(d__1));
} else {
colmax = 0.;
}
if (MAX(absakk,colmax) == 0.) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
rowmax = 0.;
kx = kc + imax - k;
i__1 = imax - 1;
for (j = k; j <= i__1; ++j) {
if ((d__1 = ap[kx], ABS(d__1)) > rowmax) {
rowmax = (d__1 = ap[kx], ABS(d__1));
jmax = j;
}
kx = kx + *n - j;
/* L70: */
}
kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + idamax_(&i__1, &ap[kpc + 1], &c__1);
/* Computing MAX */
d__2 = rowmax, d__3 = (d__1 = ap[kpc + jmax - imax], ABS(
d__1));
rowmax = MAX(d__2,d__3);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else if ((d__1 = ap[kpc], ABS(d__1)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
} else {
/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
kk = k + kstep - 1;
if (kstep == 2) {
knc = knc + *n - k + 1;
}
if (kp != kk) {
/* Interchange rows and columns KK and KP in the trailing */
/* submatrix A(k:n,k:n) */
if (kp < *n) {
i__1 = *n - kp;
dswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1],
&c__1);
}
kx = knc + kp - kk;
i__1 = kp - 1;
for (j = kk + 1; j <= i__1; ++j) {
kx = kx + *n - j + 1;
t = ap[knc + j - kk];
ap[knc + j - kk] = ap[kx];
ap[kx] = t;
/* L80: */
}
t = ap[knc];
ap[knc] = ap[kpc];
ap[kpc] = t;
if (kstep == 2) {
t = ap[kc + 1];
ap[kc + 1] = ap[kc + kp - k];
ap[kc + kp - k] = t;
}
}
/* Update the trailing submatrix */
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = L(k)*D(k) */
/* where L(k) is the k-th column of L */
if (k < *n) {
/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
r1 = 1. / ap[kc];
i__1 = *n - k;
d__1 = -r1;
dspr_(uplo, &i__1, &d__1, &ap[kc + 1], &c__1, &ap[kc + *n
- k + 1]);
/* Store L(k) in column K */
i__1 = *n - k;
dscal_(&i__1, &r1, &ap[kc + 1], &c__1);
}
} else {
/* 2-by-2 pivot block D(k): columns K and K+1 now hold */
/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */
/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */
/* of L */
if (k < *n - 1) {
/* Perform a rank-2 update of A(k+2:n,k+2:n) as */
/* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )' */
/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
d21 = ap[k + 1 + (k - 1) * ((*n << 1) - k) / 2];
d11 = ap[k + 1 + k * ((*n << 1) - k - 1) / 2] / d21;
d22 = ap[k + (k - 1) * ((*n << 1) - k) / 2] / d21;
t = 1. / (d11 * d22 - 1.);
d21 = t / d21;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
wk = d21 * (d11 * ap[j + (k - 1) * ((*n << 1) - k) /
2] - ap[j + k * ((*n << 1) - k - 1) / 2]);
wkp1 = d21 * (d22 * ap[j + k * ((*n << 1) - k - 1) /
2] - ap[j + (k - 1) * ((*n << 1) - k) / 2]);
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
ap[i__ + (j - 1) * ((*n << 1) - j) / 2] = ap[i__
+ (j - 1) * ((*n << 1) - j) / 2] - ap[i__
+ (k - 1) * ((*n << 1) - k) / 2] * wk -
ap[i__ + k * ((*n << 1) - k - 1) / 2] *
wkp1;
/* L90: */
}
ap[j + (k - 1) * ((*n << 1) - k) / 2] = wk;
ap[j + k * ((*n << 1) - k - 1) / 2] = wkp1;
/* L100: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
/* Increase K and return to the start of the main loop */
k += kstep;
kc = knc + *n - k + 2;
goto L60;
}
L110:
return 0;
/* End of DSPTRF */
} /* dsptrf_ */
/* Subroutine */ HYPRE_Int dsyev_(char *jobz, char *uplo, integer *n, doublereal *a,
integer *lda, doublereal *w, doublereal *work, integer *lwork,
integer *info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
DSYEV computes all eigenvalues and, optionally, eigenvectors of a
real symmetric matrix A.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
On entry, the symmetric matrix A. If UPLO = 'U', the
leading N-by-N upper triangular part of A contains the
upper triangular part of the matrix A. If UPLO = 'L',
the leading N-by-N lower triangular part of A contains
the lower triangular part of the matrix A.
On exit, if JOBZ = 'V', then if INFO = 0, A contains the
orthonormal eigenvectors of the matrix A.
If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
or the upper triangle (if UPLO='U') of A, including the
diagonal, is destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
W (output) DOUBLE PRECISION array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of the array WORK. LWORK >= max(1,3*N-1).
For optimal efficiency, LWORK >= (NB+2)*N,
where NB is the blocksize for DSYTRD returned by ILAENV.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the algorithm failed to converge; i
off-diagonal elements of an intermediate tridiagonal
form did not converge to zero.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__0 = 0;
static doublereal c_b17 = 1.;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer inde;
static doublereal anrm;
static integer imax;
static doublereal rmin, rmax;
/***static integer lopt;***/
extern /* Subroutine */ HYPRE_Int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
static logical lower, wantz;
static integer nb;
extern doublereal dlamch_(char *);
static integer iscale;
extern /* Subroutine */ HYPRE_Int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
static doublereal safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ HYPRE_Int xerbla_(char *, integer *);
static doublereal bignum;
static integer indtau;
extern /* Subroutine */ HYPRE_Int dsterf_(integer *, doublereal *, doublereal *,
integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
static integer indwrk;
extern /* Subroutine */ HYPRE_Int dorgtr_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *), dsteqr_(char *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *),
dsytrd_(char *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *);
static integer llwork;
static doublereal smlnum;
static integer lwkopt;
static logical lquery;
static doublereal eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--w;
--work;
/* Function Body */
wantz = lsame_(jobz, "V");
lower = lsame_(uplo, "L");
lquery = *lwork == -1;
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else { /* if(complicated condition) */
/* Computing MAX */
i__1 = 1, i__2 = *n * 3 - 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -8;
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
/* Computing MAX */
i__1 = 1, i__2 = (nb + 2) * *n;
lwkopt = max(i__1,i__2);
work[1] = (doublereal) lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYEV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
work[1] = 1.;
return 0;
}
if (*n == 1) {
w[1] = a_ref(1, 1);
work[1] = 3.;
if (wantz) {
a_ref(1, 1) = 1.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
iscale = 0;
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda,
info);
}
/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */
inde = 1;
indtau = inde + *n;
indwrk = indtau + *n;
llwork = *lwork - indwrk + 1;
dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], &
work[indwrk], &llwork, &iinfo);
/***lopt = (integer) ((*n << 1) + work[indwrk]);***/
/* For eigenvalues only, call DSTERF. For eigenvectors, first call
DORGTR to generate the orthogonal matrix, then call DSTEQR. */
if (! wantz) {
dsterf_(n, &w[1], &work[inde], info);
} else {
dorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], &
llwork, &iinfo);
dsteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau],
info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &w[1], &c__1);
}
/* Set WORK(1) to optimal workspace size. */
work[1] = (doublereal) lwkopt;
return 0;
/* End of DSYEV */
} /* dsyev_ */
/*< SUBROUTINE LSI(W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, IP) >*/
/* Subroutine */ int lsi_(doublereal *w, integer *mdw, integer *ma, integer *
mg, integer *n, doublereal *prgopt, doublereal *x, doublereal *rnorm,
integer *mode, doublereal *ws, integer *ip)
{
/* Initialized data */
static doublereal zero = 0.;
static doublereal drelpr = 0.;
static doublereal one = 1.;
static doublereal half = .5;
/* Format strings */
static char fmt_40[] = "";
static char fmt_60[] = "";
/* System generated locals */
integer w_dim1, w_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k, l, m, n1, n2, n3;
extern /* Subroutine */ int h12_(integer *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, integer *);
integer ii;
doublereal rb;
integer il, im1, ip1, np1;
doublereal fac, gam, tau;
logical cov;
integer key;
doublereal tol;
integer map1, krm1, krp1;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
extern /* Subroutine */ int hfti_(doublereal *, integer *, integer *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *);
integer link;
extern /* Subroutine */ int lpdp_(doublereal *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
integer last, next, igo990, igo994;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
integer krank;
extern doublereal dasum_(integer *, doublereal *, integer *);
doublereal anorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
doublereal xnorm;
integer minman, mdlpdp;
/* Assigned format variables */
static char *igo994_fmt, *igo990_fmt;
/* THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO */
/* DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. */
/* USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. */
/* (START EDITING AT LINE WITH C++ IN COLS. 1-3.) */
/* /REAL (12 BLANKS)/DOUBLE PRECISION/,/DASUM/DASUM/,/DDOT/DDOT/, */
/* / DSQRT/ DSQRT/,/DMAX1/DMAX1/,/DSWAP/DSWAP/, */
/* /DCOPY/DCOPY/,/DSCAL/DSCAL/,/DAXPY/DAXPY/,/D0/D0/,/DRELPR/DRELPR/ */
/* THIS IS A COMPANION SUBPROGRAM TO LSEI( ). */
/* THE DOCUMENTATION FOR LSEI( ) HAS MORE COMPLETE */
/* USAGE INSTRUCTIONS. */
/* WRITTEN BY R. J. HANSON, SLA. */
/* SOLVE.. */
/* AX = B, A MA BY N (LEAST SQUARES EQUATIONS) */
/* SUBJECT TO.. */
/* GX.GE.H, G MG BY N (INEQUALITY CONSTRAINTS) */
/* INPUT.. */
/* W(*,*) CONTAINS (A B) IN ROWS 1,...,MA+MG, COLS 1,...,N+1. */
/* (G H) */
/* MDW,MA,MG,N */
/* CONTAIN (RESP) VAR. DIMENSION OF W(*,*), */
/* AND MATRIX DIMENSIONS. */
/* PRGOPT(*), */
/* PROGRAM OPTION VECTOR. */
/* OUTPUT.. */
/* X(*),RNORM */
/* SOLUTION VECTOR(UNLESS MODE=2), LENGTH OF AX-B. */
/* MODE */
/* =0 INEQUALITY CONSTRAINTS ARE COMPATIBLE. */
/* =2 INEQUALITY CONSTRAINTS CONTRADICTORY. */
/* WS(*), */
/* WORKING STORAGE OF DIMENSION K+N+(MG+2)*(N+7), */
/* WHERE K=MAX(MA+MG,N). */
/* IP(MG+2*N+1) */
/* INTEGER WORKING STORAGE */
/* REVISED OCT. 1, 1981. */
/* SUBROUTINES CALLED */
/* LPDP THIS SUBPROGRAM MINIMIZES A SUM OF SQUARES */
/* OF UNKNOWNS SUBJECT TO LINEAR INEQUALITY */
/* CONSTRAINTS. PART OF THIS PACKAGE. */
/* ++ */
/* DDOT,DSCAL SUBROUTINES FROM THE BLAS PACKAGE. */
/* DAXPY,DASUM, SEE TRANS. MATH. SOFT., VOL. 5, NO. 3, P. 308. */
/* DCOPY,DSWAP */
/* HFTI SOLVES AN UNCONSTRAINED LINEAR LEAST SQUARES */
/* PROBLEM. PART OF THIS PACKAGE. */
/* H12 SUBROUTINE TO CONSTRUCT AND APPLY A HOUSEHOLDER */
/* TRANSFORMATION. */
/* SUBROUTINE LSI(W,MDW,MA,MG,N,PRGOPT,X,RNORM,MODE,WS,IP) */
/*< DOUBLE PRECISION W(MDW,1), PRGOPT(1), RNORM, WS(1), X(1) >*/
/*< INTEGER IP(1) >*/
/*< >*/
/*< DOUBLE PRECISION DASUM, DDOT, DSQRT, DMAX1 >*/
/*< LOGICAL COV >*/
/*< DATA ZERO /0.D0/, DRELPR /0.D0/, ONE /1.D0/, HALF /.5E0/ >*/
#line 77 "../fortran/lsi.f"
/* Parameter adjustments */
#line 77 "../fortran/lsi.f"
w_dim1 = *mdw;
#line 77 "../fortran/lsi.f"
w_offset = 1 + w_dim1;
#line 77 "../fortran/lsi.f"
w -= w_offset;
#line 77 "../fortran/lsi.f"
--prgopt;
#line 77 "../fortran/lsi.f"
--x;
#line 77 "../fortran/lsi.f"
--ws;
#line 77 "../fortran/lsi.f"
--ip;
#line 77 "../fortran/lsi.f"
#line 77 "../fortran/lsi.f"
/* Function Body */
/* COMPUTE MACHINE PRECISION=DRELPR ONLY WHEN NECESSARY. */
/*< IF (.NOT.(DRELPR.EQ.ZERO)) GO TO 30 >*/
#line 80 "../fortran/lsi.f"
if (! (drelpr == zero)) {
#line 80 "../fortran/lsi.f"
goto L30;
#line 80 "../fortran/lsi.f"
}
/*< DRELPR = ONE >*/
#line 81 "../fortran/lsi.f"
drelpr = one;
/*< 10 IF (ONE+DRELPR.EQ.ONE) GO TO 20 >*/
#line 82 "../fortran/lsi.f"
L10:
#line 82 "../fortran/lsi.f"
if (one + drelpr == one) {
#line 82 "../fortran/lsi.f"
goto L20;
#line 82 "../fortran/lsi.f"
}
/*< DRELPR = DRELPR*HALF >*/
#line 83 "../fortran/lsi.f"
drelpr *= half;
/*< GO TO 10 >*/
#line 84 "../fortran/lsi.f"
goto L10;
/*< 20 DRELPR = DRELPR + DRELPR >*/
#line 85 "../fortran/lsi.f"
L20:
#line 85 "../fortran/lsi.f"
drelpr += drelpr;
/*< 30 MODE = 0 >*/
#line 86 "../fortran/lsi.f"
L30:
#line 86 "../fortran/lsi.f"
*mode = 0;
/*< RNORM = ZERO >*/
#line 87 "../fortran/lsi.f"
*rnorm = zero;
/*< M = MA + MG >*/
#line 88 "../fortran/lsi.f"
m = *ma + *mg;
/*< NP1 = N + 1 >*/
#line 89 "../fortran/lsi.f"
np1 = *n + 1;
/*< KRANK = 0 >*/
#line 90 "../fortran/lsi.f"
krank = 0;
/*< IF (N.LE.0 .OR. M.LE.0) GO TO 70 >*/
#line 91 "../fortran/lsi.f"
if (*n <= 0 || m <= 0) {
#line 91 "../fortran/lsi.f"
goto L70;
#line 91 "../fortran/lsi.f"
}
/*< ASSIGN 40 TO IGO994 >*/
#line 92 "../fortran/lsi.f"
igo994 = 0;
#line 92 "../fortran/lsi.f"
igo994_fmt = fmt_40;
/*< GO TO 500 >*/
#line 93 "../fortran/lsi.f"
goto L500;
/* PROCESS-OPTION-VECTOR */
/* COMPUTE MATRIX NORM OF LEAST SQUARES EQUAS. */
/*< 40 ANORM = ZERO >*/
#line 98 "../fortran/lsi.f"
L40:
#line 98 "../fortran/lsi.f"
anorm = zero;
/*< DO 50 J=1,N >*/
#line 99 "../fortran/lsi.f"
i__1 = *n;
#line 99 "../fortran/lsi.f"
for (j = 1; j <= i__1; ++j) {
/*< ANORM = DMAX1(ANORM,DASUM(MA,W(1,J),1)) >*/
/* Computing MAX */
#line 100 "../fortran/lsi.f"
d__1 = anorm, d__2 = dasum_(ma, &w[j * w_dim1 + 1], &c__1);
#line 100 "../fortran/lsi.f"
anorm = max(d__1,d__2);
/*< 50 CONTINUE >*/
#line 101 "../fortran/lsi.f"
/* L50: */
#line 101 "../fortran/lsi.f"
}
/* SET TOL FOR HFTI( ) RANK TEST. */
/*< TAU = TOL*ANORM >*/
#line 104 "../fortran/lsi.f"
tau = tol * anorm;
/* COMPUTE HOUSEHOLDER ORTHOGONAL DECOMP OF MATRIX. */
/*< IF (N.GT.0) WS(1) = ZERO >*/
#line 107 "../fortran/lsi.f"
if (*n > 0) {
#line 107 "../fortran/lsi.f"
ws[1] = zero;
#line 107 "../fortran/lsi.f"
}
/*< CALL DCOPY(N, WS, 0, WS, 1) >*/
#line 108 "../fortran/lsi.f"
dcopy_(n, &ws[1], &c__0, &ws[1], &c__1);
/*< CALL DCOPY(MA, W(1,NP1), 1, WS, 1) >*/
#line 109 "../fortran/lsi.f"
dcopy_(ma, &w[np1 * w_dim1 + 1], &c__1, &ws[1], &c__1);
/*< K = MAX0(M,N) >*/
#line 110 "../fortran/lsi.f"
k = max(m,*n);
/*< MINMAN = MIN0(MA,N) >*/
#line 111 "../fortran/lsi.f"
minman = min(*ma,*n);
/*< N1 = K + 1 >*/
#line 112 "../fortran/lsi.f"
n1 = k + 1;
/*< N2 = N1 + N >*/
#line 113 "../fortran/lsi.f"
n2 = n1 + *n;
/*< >*/
#line 114 "../fortran/lsi.f"
hfti_(&w[w_offset], mdw, ma, n, &ws[1], &c__1, &c__1, &tau, &krank, rnorm,
&ws[n2], &ws[n1], &ip[1]);
/*< FAC = ONE >*/
#line 116 "../fortran/lsi.f"
fac = one;
/*< GAM=MA-KRANK >*/
#line 117 "../fortran/lsi.f"
gam = (doublereal) (*ma - krank);
/*< IF (KRANK.LT.MA) FAC = RNORM**2/GAM >*/
#line 118 "../fortran/lsi.f"
if (krank < *ma) {
/* Computing 2nd power */
#line 118 "../fortran/lsi.f"
d__1 = *rnorm;
#line 118 "../fortran/lsi.f"
fac = d__1 * d__1 / gam;
#line 118 "../fortran/lsi.f"
}
/*< ASSIGN 60 TO IGO990 >*/
#line 119 "../fortran/lsi.f"
igo990 = 0;
#line 119 "../fortran/lsi.f"
igo990_fmt = fmt_60;
/*< GO TO 80 >*/
#line 120 "../fortran/lsi.f"
goto L80;
/* REDUCE-TO-LPDP-AND-SOLVE */
/*< 60 CONTINUE >*/
#line 123 "../fortran/lsi.f"
L60:
/*< 70 IP(1) = KRANK >*/
#line 124 "../fortran/lsi.f"
L70:
#line 124 "../fortran/lsi.f"
ip[1] = krank;
/*< IP(2) = N + MAX0(M,N) + (MG+2)*(N+7) >*/
#line 125 "../fortran/lsi.f"
ip[2] = *n + max(m,*n) + (*mg + 2) * (*n + 7);
/*< RETURN >*/
#line 126 "../fortran/lsi.f"
return 0;
/*< 80 CONTINUE >*/
#line 127 "../fortran/lsi.f"
L80:
/* TO REDUCE-TO-LPDP-AND-SOLVE */
/*< MAP1 = MA + 1 >*/
#line 130 "../fortran/lsi.f"
map1 = *ma + 1;
/* COMPUTE INEQ. RT-HAND SIDE FOR LPDP. */
/*< IF (.NOT.(MA.LT.M)) GO TO 260 >*/
#line 133 "../fortran/lsi.f"
if (! (*ma < m)) {
#line 133 "../fortran/lsi.f"
goto L260;
#line 133 "../fortran/lsi.f"
}
/*< IF (.NOT.(MINMAN.GT.0)) GO TO 160 >*/
#line 134 "../fortran/lsi.f"
if (! (minman > 0)) {
#line 134 "../fortran/lsi.f"
goto L160;
#line 134 "../fortran/lsi.f"
}
/*< DO 90 I=MAP1,M >*/
#line 135 "../fortran/lsi.f"
i__1 = m;
#line 135 "../fortran/lsi.f"
for (i__ = map1; i__ <= i__1; ++i__) {
/*< W(I,NP1) = W(I,NP1) - DDOT(N,W(I,1),MDW,WS,1) >*/
#line 136 "../fortran/lsi.f"
w[i__ + np1 * w_dim1] -= ddot_(n, &w[i__ + w_dim1], mdw, &ws[1], &
c__1);
/*< 90 CONTINUE >*/
#line 137 "../fortran/lsi.f"
/* L90: */
#line 137 "../fortran/lsi.f"
}
/*< DO 100 I=1,MINMAN >*/
#line 138 "../fortran/lsi.f"
i__1 = minman;
#line 138 "../fortran/lsi.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< J = IP(I) >*/
#line 139 "../fortran/lsi.f"
j = ip[i__];
/* APPLY PERMUTATIONS TO COLS OF INEQ. CONSTRAINT MATRIX. */
/*< CALL DSWAP(MG, W(MAP1,I), 1, W(MAP1,J), 1) >*/
#line 142 "../fortran/lsi.f"
dswap_(mg, &w[map1 + i__ * w_dim1], &c__1, &w[map1 + j * w_dim1], &
c__1);
/*< 100 CONTINUE >*/
#line 143 "../fortran/lsi.f"
/* L100: */
#line 143 "../fortran/lsi.f"
}
/* APPLY HOUSEHOLDER TRANSFORMATIONS TO CONSTRAINT MATRIX. */
/*< IF (.NOT.(0.LT.KRANK .AND. KRANK.LT.N)) GO TO 120 >*/
#line 146 "../fortran/lsi.f"
if (! (0 < krank && krank < *n)) {
#line 146 "../fortran/lsi.f"
goto L120;
#line 146 "../fortran/lsi.f"
}
/*< DO 110 II=1,KRANK >*/
#line 147 "../fortran/lsi.f"
i__1 = krank;
#line 147 "../fortran/lsi.f"
for (ii = 1; ii <= i__1; ++ii) {
/*< I = KRANK + 1 - II >*/
#line 148 "../fortran/lsi.f"
i__ = krank + 1 - ii;
/*< L = N1 + I >*/
#line 149 "../fortran/lsi.f"
l = n1 + i__;
/*< >*/
#line 150 "../fortran/lsi.f"
i__2 = krank + 1;
#line 150 "../fortran/lsi.f"
h12_(&c__2, &i__, &i__2, n, &w[i__ + w_dim1], mdw, &ws[l - 1], &w[
map1 + w_dim1], mdw, &c__1, mg);
/*< 110 CONTINUE >*/
#line 152 "../fortran/lsi.f"
/* L110: */
#line 152 "../fortran/lsi.f"
}
/* COMPUTE PERMUTED INEQ. CONSTR. MATRIX TIMES R-INVERSE. */
/*< 120 DO 150 I=MAP1,M >*/
#line 155 "../fortran/lsi.f"
L120:
#line 155 "../fortran/lsi.f"
i__1 = m;
#line 155 "../fortran/lsi.f"
for (i__ = map1; i__ <= i__1; ++i__) {
/*< IF (.NOT.(0.LT.KRANK)) GO TO 140 >*/
#line 156 "../fortran/lsi.f"
if (! (0 < krank)) {
#line 156 "../fortran/lsi.f"
goto L140;
#line 156 "../fortran/lsi.f"
}
/*< DO 130 J=1,KRANK >*/
#line 157 "../fortran/lsi.f"
i__2 = krank;
#line 157 "../fortran/lsi.f"
for (j = 1; j <= i__2; ++j) {
/*< W(I,J) = (W(I,J)-DDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J) >*/
#line 158 "../fortran/lsi.f"
i__3 = j - 1;
#line 158 "../fortran/lsi.f"
w[i__ + j * w_dim1] = (w[i__ + j * w_dim1] - ddot_(&i__3, &w[j *
w_dim1 + 1], &c__1, &w[i__ + w_dim1], mdw)) / w[j + j *
w_dim1];
/*< 130 CONTINUE >*/
#line 159 "../fortran/lsi.f"
/* L130: */
#line 159 "../fortran/lsi.f"
}
/*< 140 CONTINUE >*/
#line 160 "../fortran/lsi.f"
L140:
/*< 150 CONTINUE >*/
#line 161 "../fortran/lsi.f"
/* L150: */
#line 161 "../fortran/lsi.f"
;
#line 161 "../fortran/lsi.f"
}
/* SOLVE THE REDUCED PROBLEM WITH LPDP ALGORITHM, */
/* THE LEAST PROJECTED DISTANCE PROBLEM. */
/*< 160 >*/
#line 165 "../fortran/lsi.f"
L160:
#line 165 "../fortran/lsi.f"
i__1 = *n - krank;
#line 165 "../fortran/lsi.f"
lpdp_(&w[map1 + w_dim1], mdw, mg, &krank, &i__1, &prgopt[1], &x[1], &
xnorm, &mdlpdp, &ws[n2], &ip[*n + 1]);
/*< IF (.NOT.(MDLPDP.EQ.1)) GO TO 240 >*/
#line 167 "../fortran/lsi.f"
if (! (mdlpdp == 1)) {
#line 167 "../fortran/lsi.f"
goto L240;
#line 167 "../fortran/lsi.f"
}
/*< IF (.NOT.(KRANK.GT.0)) GO TO 180 >*/
#line 168 "../fortran/lsi.f"
if (! (krank > 0)) {
#line 168 "../fortran/lsi.f"
goto L180;
#line 168 "../fortran/lsi.f"
}
/* COMPUTE SOLN IN ORIGINAL COORDINATES. */
/*< DO 170 II=1,KRANK >*/
#line 171 "../fortran/lsi.f"
i__1 = krank;
#line 171 "../fortran/lsi.f"
for (ii = 1; ii <= i__1; ++ii) {
/*< I = KRANK + 1 - II >*/
#line 172 "../fortran/lsi.f"
i__ = krank + 1 - ii;
/*< X(I) = (X(I)-DDOT(II-1,W(I,I+1),MDW,X(I+1),1))/W(I,I) >*/
#line 173 "../fortran/lsi.f"
i__2 = ii - 1;
#line 173 "../fortran/lsi.f"
x[i__] = (x[i__] - ddot_(&i__2, &w[i__ + (i__ + 1) * w_dim1], mdw, &x[
i__ + 1], &c__1)) / w[i__ + i__ * w_dim1];
/*< 170 CONTINUE >*/
#line 174 "../fortran/lsi.f"
/* L170: */
#line 174 "../fortran/lsi.f"
}
/* APPLY HOUSEHOLDER TRANS. TO SOLN VECTOR. */
/*< 180 IF (.NOT.(0.LT.KRANK .AND. KRANK.LT.N)) GO TO 200 >*/
#line 177 "../fortran/lsi.f"
L180:
#line 177 "../fortran/lsi.f"
if (! (0 < krank && krank < *n)) {
#line 177 "../fortran/lsi.f"
goto L200;
#line 177 "../fortran/lsi.f"
}
/*< DO 190 I=1,KRANK >*/
#line 178 "../fortran/lsi.f"
i__1 = krank;
#line 178 "../fortran/lsi.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< L = N1 + I >*/
#line 179 "../fortran/lsi.f"
l = n1 + i__;
/*< CALL H12(2, I, KRANK+1, N, W(I,1), MDW, WS(L-1), X, 1, 1, 1) >*/
#line 180 "../fortran/lsi.f"
i__2 = krank + 1;
#line 180 "../fortran/lsi.f"
h12_(&c__2, &i__, &i__2, n, &w[i__ + w_dim1], mdw, &ws[l - 1], &x[1],
&c__1, &c__1, &c__1);
/*< 190 CONTINUE >*/
#line 181 "../fortran/lsi.f"
/* L190: */
#line 181 "../fortran/lsi.f"
}
/*< 200 IF (.NOT.(MINMAN.GT.0)) GO TO 230 >*/
#line 182 "../fortran/lsi.f"
L200:
#line 182 "../fortran/lsi.f"
if (! (minman > 0)) {
#line 182 "../fortran/lsi.f"
goto L230;
#line 182 "../fortran/lsi.f"
}
/* REPERMUTE VARIABLES TO THEIR INPUT ORDER. */
/*< DO 210 II=1,MINMAN >*/
#line 185 "../fortran/lsi.f"
i__1 = minman;
#line 185 "../fortran/lsi.f"
for (ii = 1; ii <= i__1; ++ii) {
/*< I = MINMAN + 1 - II >*/
#line 186 "../fortran/lsi.f"
i__ = minman + 1 - ii;
/*< J = IP(I) >*/
#line 187 "../fortran/lsi.f"
j = ip[i__];
/*< CALL DSWAP(1, X(I), 1, X(J), 1) >*/
#line 188 "../fortran/lsi.f"
dswap_(&c__1, &x[i__], &c__1, &x[j], &c__1);
/*< 210 CONTINUE >*/
#line 189 "../fortran/lsi.f"
/* L210: */
#line 189 "../fortran/lsi.f"
}
/* VARIABLES ARE NOW IN ORIG. COORDINATES. */
/* ADD SOLN OF UNSCONSTRAINED PROB. */
/*< DO 220 I=1,N >*/
#line 193 "../fortran/lsi.f"
i__1 = *n;
#line 193 "../fortran/lsi.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< X(I) = X(I) + WS(I) >*/
#line 194 "../fortran/lsi.f"
x[i__] += ws[i__];
/*< 220 CONTINUE >*/
#line 195 "../fortran/lsi.f"
/* L220: */
#line 195 "../fortran/lsi.f"
}
/* COMPUTE THE RESIDUAL VECTOR NORM. */
/*< RNORM = DSQRT(RNORM**2+XNORM**2) >*/
/* Computing 2nd power */
#line 198 "../fortran/lsi.f"
d__1 = *rnorm;
/* Computing 2nd power */
#line 198 "../fortran/lsi.f"
d__2 = xnorm;
#line 198 "../fortran/lsi.f"
*rnorm = sqrt(d__1 * d__1 + d__2 * d__2);
/*< 230 GO TO 250 >*/
#line 199 "../fortran/lsi.f"
L230:
#line 199 "../fortran/lsi.f"
goto L250;
/*< 240 MODE = 2 >*/
#line 200 "../fortran/lsi.f"
L240:
#line 200 "../fortran/lsi.f"
*mode = 2;
/*< 250 GO TO 270 >*/
#line 201 "../fortran/lsi.f"
L250:
#line 201 "../fortran/lsi.f"
goto L270;
/*< 260 CALL DCOPY(N, WS, 1, X, 1) >*/
#line 202 "../fortran/lsi.f"
L260:
#line 202 "../fortran/lsi.f"
dcopy_(n, &ws[1], &c__1, &x[1], &c__1);
/*< 270 IF (.NOT.(COV .AND. KRANK.GT.0)) GO TO 490 >*/
#line 203 "../fortran/lsi.f"
L270:
#line 203 "../fortran/lsi.f"
if (! (cov && krank > 0)) {
#line 203 "../fortran/lsi.f"
goto L490;
#line 203 "../fortran/lsi.f"
}
/* COMPUTE COVARIANCE MATRIX BASED ON THE ORTHOGONAL DECOMP. */
/* FROM HFTI( ). */
/*< KRM1 = KRANK - 1 >*/
#line 208 "../fortran/lsi.f"
krm1 = krank - 1;
/*< KRP1 = KRANK + 1 >*/
#line 209 "../fortran/lsi.f"
krp1 = krank + 1;
/* COPY DIAG. TERMS TO WORKING ARRAY. */
/*< CALL DCOPY(KRANK, W, MDW+1, WS(N2), 1) >*/
#line 212 "../fortran/lsi.f"
i__1 = *mdw + 1;
#line 212 "../fortran/lsi.f"
dcopy_(&krank, &w[w_offset], &i__1, &ws[n2], &c__1);
/* RECIPROCATE DIAG. TERMS. */
/*< DO 280 J=1,KRANK >*/
#line 215 "../fortran/lsi.f"
i__1 = krank;
#line 215 "../fortran/lsi.f"
for (j = 1; j <= i__1; ++j) {
/*< W(J,J) = ONE/W(J,J) >*/
#line 216 "../fortran/lsi.f"
w[j + j * w_dim1] = one / w[j + j * w_dim1];
/*< 280 CONTINUE >*/
#line 217 "../fortran/lsi.f"
/* L280: */
#line 217 "../fortran/lsi.f"
}
/*< IF (.NOT.(KRANK.GT.1)) GO TO 310 >*/
#line 218 "../fortran/lsi.f"
if (! (krank > 1)) {
#line 218 "../fortran/lsi.f"
goto L310;
#line 218 "../fortran/lsi.f"
}
/* INVERT THE UPPER TRIANGULAR QR FACTOR ON ITSELF. */
/*< DO 300 I=1,KRM1 >*/
#line 221 "../fortran/lsi.f"
i__1 = krm1;
#line 221 "../fortran/lsi.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< IP1 = I + 1 >*/
#line 222 "../fortran/lsi.f"
ip1 = i__ + 1;
/*< DO 290 J=IP1,KRANK >*/
#line 223 "../fortran/lsi.f"
i__2 = krank;
#line 223 "../fortran/lsi.f"
for (j = ip1; j <= i__2; ++j) {
/*< W(I,J) = -DDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J) >*/
#line 224 "../fortran/lsi.f"
i__3 = j - i__;
#line 224 "../fortran/lsi.f"
w[i__ + j * w_dim1] = -ddot_(&i__3, &w[i__ + i__ * w_dim1], mdw, &
w[i__ + j * w_dim1], &c__1) * w[j + j * w_dim1];
/*< 290 CONTINUE >*/
#line 225 "../fortran/lsi.f"
/* L290: */
#line 225 "../fortran/lsi.f"
}
/*< 300 CONTINUE >*/
#line 226 "../fortran/lsi.f"
/* L300: */
#line 226 "../fortran/lsi.f"
}
/* COMPUTE THE INVERTED FACTOR TIMES ITS TRANSPOSE. */
/*< 310 DO 330 I=1,KRANK >*/
#line 229 "../fortran/lsi.f"
L310:
#line 229 "../fortran/lsi.f"
i__1 = krank;
#line 229 "../fortran/lsi.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< DO 320 J=I,KRANK >*/
#line 230 "../fortran/lsi.f"
i__2 = krank;
#line 230 "../fortran/lsi.f"
for (j = i__; j <= i__2; ++j) {
/*< W(I,J) = DDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW) >*/
#line 231 "../fortran/lsi.f"
i__3 = krank + 1 - j;
#line 231 "../fortran/lsi.f"
w[i__ + j * w_dim1] = ddot_(&i__3, &w[i__ + j * w_dim1], mdw, &w[
j + j * w_dim1], mdw);
/*< 320 CONTINUE >*/
#line 232 "../fortran/lsi.f"
/* L320: */
#line 232 "../fortran/lsi.f"
}
/*< 330 CONTINUE >*/
#line 233 "../fortran/lsi.f"
/* L330: */
#line 233 "../fortran/lsi.f"
}
/*< IF (.NOT.(KRANK.LT.N)) GO TO 450 >*/
#line 234 "../fortran/lsi.f"
if (! (krank < *n)) {
#line 234 "../fortran/lsi.f"
goto L450;
#line 234 "../fortran/lsi.f"
}
/* ZERO OUT LOWER TRAPEZOIDAL PART. */
/* COPY UPPER TRI. TO LOWER TRI. PART. */
/*< DO 340 J=1,KRANK >*/
#line 238 "../fortran/lsi.f"
i__1 = krank;
#line 238 "../fortran/lsi.f"
for (j = 1; j <= i__1; ++j) {
/*< CALL DCOPY(J, W(1,J), 1, W(J,1), MDW) >*/
#line 239 "../fortran/lsi.f"
dcopy_(&j, &w[j * w_dim1 + 1], &c__1, &w[j + w_dim1], mdw);
/*< 340 CONTINUE >*/
#line 240 "../fortran/lsi.f"
/* L340: */
#line 240 "../fortran/lsi.f"
}
/*< DO 350 I=KRP1,N >*/
#line 241 "../fortran/lsi.f"
i__1 = *n;
#line 241 "../fortran/lsi.f"
for (i__ = krp1; i__ <= i__1; ++i__) {
/*< W(I,1) = ZERO >*/
#line 242 "../fortran/lsi.f"
w[i__ + w_dim1] = zero;
/*< CALL DCOPY(I, W(I,1), 0, W(I,1), MDW) >*/
#line 243 "../fortran/lsi.f"
dcopy_(&i__, &w[i__ + w_dim1], &c__0, &w[i__ + w_dim1], mdw);
/*< 350 CONTINUE >*/
#line 244 "../fortran/lsi.f"
/* L350: */
#line 244 "../fortran/lsi.f"
}
/* APPLY RIGHT SIDE TRANSFORMATIONS TO LOWER TRI. */
/*< N3 = N2 + KRP1 >*/
#line 247 "../fortran/lsi.f"
n3 = n2 + krp1;
/*< DO 430 I=1,KRANK >*/
#line 248 "../fortran/lsi.f"
i__1 = krank;
#line 248 "../fortran/lsi.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< L = N1 + I >*/
#line 249 "../fortran/lsi.f"
l = n1 + i__;
/*< K = N2 + I >*/
#line 250 "../fortran/lsi.f"
k = n2 + i__;
/*< RB = WS(L-1)*WS(K-1) >*/
#line 251 "../fortran/lsi.f"
rb = ws[l - 1] * ws[k - 1];
/*< IF (.NOT.(RB.LT.ZERO)) GO TO 420 >*/
#line 252 "../fortran/lsi.f"
if (! (rb < zero)) {
#line 252 "../fortran/lsi.f"
goto L420;
#line 252 "../fortran/lsi.f"
}
/* IF RB.GE.ZERO, TRANSFORMATION CAN BE REGARDED AS ZERO. */
/*< RB = ONE/RB >*/
#line 255 "../fortran/lsi.f"
rb = one / rb;
/* STORE UNSCALED RANK-ONE HOUSEHOLDER UPDATE IN WORK ARRAY. */
/*< WS(N3) = ZERO >*/
#line 258 "../fortran/lsi.f"
ws[n3] = zero;
/*< CALL DCOPY(N, WS(N3), 0, WS(N3), 1) >*/
#line 259 "../fortran/lsi.f"
dcopy_(n, &ws[n3], &c__0, &ws[n3], &c__1);
/*< L = N1 + I >*/
#line 260 "../fortran/lsi.f"
l = n1 + i__;
/*< K = N3 + I >*/
#line 261 "../fortran/lsi.f"
k = n3 + i__;
/*< WS(K-1) = WS(L-1) >*/
#line 262 "../fortran/lsi.f"
ws[k - 1] = ws[l - 1];
/*< DO 360 J=KRP1,N >*/
#line 263 "../fortran/lsi.f"
i__2 = *n;
#line 263 "../fortran/lsi.f"
for (j = krp1; j <= i__2; ++j) {
/*< K = N3 + J >*/
#line 264 "../fortran/lsi.f"
k = n3 + j;
/*< WS(K-1) = W(I,J) >*/
#line 265 "../fortran/lsi.f"
ws[k - 1] = w[i__ + j * w_dim1];
/*< 360 CONTINUE >*/
#line 266 "../fortran/lsi.f"
/* L360: */
#line 266 "../fortran/lsi.f"
}
/*< DO 370 J=1,N >*/
#line 267 "../fortran/lsi.f"
i__2 = *n;
#line 267 "../fortran/lsi.f"
for (j = 1; j <= i__2; ++j) {
/*< L = N3 + I >*/
#line 268 "../fortran/lsi.f"
l = n3 + i__;
/*< K = N3 + J >*/
#line 269 "../fortran/lsi.f"
k = n3 + j;
/*< >*/
#line 270 "../fortran/lsi.f"
i__3 = j - i__;
#line 270 "../fortran/lsi.f"
i__4 = *n - j + 1;
#line 270 "../fortran/lsi.f"
ws[j] = ddot_(&i__3, &w[j + i__ * w_dim1], mdw, &ws[l - 1], &c__1)
+ ddot_(&i__4, &w[j + j * w_dim1], &c__1, &ws[k - 1], &
c__1);
/*< WS(J) = WS(J)*RB >*/
#line 272 "../fortran/lsi.f"
ws[j] *= rb;
/*< 370 CONTINUE >*/
#line 273 "../fortran/lsi.f"
/* L370: */
#line 273 "../fortran/lsi.f"
}
/*< L = N3 + I >*/
#line 274 "../fortran/lsi.f"
l = n3 + i__;
/*< GAM = DDOT(N-I+1,WS(L-1),1,WS(I),1)*RB >*/
#line 275 "../fortran/lsi.f"
i__2 = *n - i__ + 1;
#line 275 "../fortran/lsi.f"
gam = ddot_(&i__2, &ws[l - 1], &c__1, &ws[i__], &c__1) * rb;
/*< GAM = GAM*HALF >*/
#line 276 "../fortran/lsi.f"
gam *= half;
/*< CALL DAXPY(N-I+1, GAM, WS(L-1), 1, WS(I), 1) >*/
#line 277 "../fortran/lsi.f"
i__2 = *n - i__ + 1;
#line 277 "../fortran/lsi.f"
daxpy_(&i__2, &gam, &ws[l - 1], &c__1, &ws[i__], &c__1);
/*< DO 410 J=I,N >*/
#line 278 "../fortran/lsi.f"
i__2 = *n;
#line 278 "../fortran/lsi.f"
for (j = i__; j <= i__2; ++j) {
/*< IF (.NOT.(I.GT.1)) GO TO 390 >*/
#line 279 "../fortran/lsi.f"
if (! (i__ > 1)) {
#line 279 "../fortran/lsi.f"
goto L390;
#line 279 "../fortran/lsi.f"
}
/*< IM1 = I - 1 >*/
#line 280 "../fortran/lsi.f"
im1 = i__ - 1;
/*< K = N3 + J >*/
#line 281 "../fortran/lsi.f"
k = n3 + j;
/*< DO 380 L=1,IM1 >*/
#line 282 "../fortran/lsi.f"
i__3 = im1;
#line 282 "../fortran/lsi.f"
for (l = 1; l <= i__3; ++l) {
/*< W(J,L) = W(J,L) + WS(K-1)*WS(L) >*/
#line 283 "../fortran/lsi.f"
w[j + l * w_dim1] += ws[k - 1] * ws[l];
/*< 380 CONTINUE >*/
#line 284 "../fortran/lsi.f"
/* L380: */
#line 284 "../fortran/lsi.f"
}
/*< 390 K = N3 + J >*/
#line 285 "../fortran/lsi.f"
L390:
#line 285 "../fortran/lsi.f"
k = n3 + j;
/*< DO 400 L=I,J >*/
#line 286 "../fortran/lsi.f"
i__3 = j;
#line 286 "../fortran/lsi.f"
for (l = i__; l <= i__3; ++l) {
/*< IL = N3 + L >*/
#line 287 "../fortran/lsi.f"
il = n3 + l;
/*< W(J,L) = W(J,L) + WS(J)*WS(IL-1) + WS(L)*WS(K-1) >*/
#line 288 "../fortran/lsi.f"
w[j + l * w_dim1] = w[j + l * w_dim1] + ws[j] * ws[il - 1] +
ws[l] * ws[k - 1];
/*< 400 CONTINUE >*/
#line 289 "../fortran/lsi.f"
/* L400: */
#line 289 "../fortran/lsi.f"
}
/*< 410 CONTINUE >*/
#line 290 "../fortran/lsi.f"
/* L410: */
#line 290 "../fortran/lsi.f"
}
/*< 420 CONTINUE >*/
#line 291 "../fortran/lsi.f"
L420:
/*< 430 CONTINUE >*/
#line 292 "../fortran/lsi.f"
/* L430: */
#line 292 "../fortran/lsi.f"
;
#line 292 "../fortran/lsi.f"
}
/* COPY LOWER TRI. TO UPPER TRI. TO SYMMETRIZE THE COVARIANCE MATRIX. */
/*< DO 440 I=1,N >*/
#line 295 "../fortran/lsi.f"
i__1 = *n;
#line 295 "../fortran/lsi.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< CALL DCOPY(I, W(I,1), MDW, W(1,I), 1) >*/
#line 296 "../fortran/lsi.f"
dcopy_(&i__, &w[i__ + w_dim1], mdw, &w[i__ * w_dim1 + 1], &c__1);
/*< 440 CONTINUE >*/
#line 297 "../fortran/lsi.f"
/* L440: */
#line 297 "../fortran/lsi.f"
}
/* REPERMUTE ROWS AND COLS. */
/*< 450 DO 470 II=1,MINMAN >*/
#line 300 "../fortran/lsi.f"
L450:
#line 300 "../fortran/lsi.f"
i__1 = minman;
#line 300 "../fortran/lsi.f"
for (ii = 1; ii <= i__1; ++ii) {
/*< I = MINMAN + 1 - II >*/
#line 301 "../fortran/lsi.f"
i__ = minman + 1 - ii;
/*< K = IP(I) >*/
#line 302 "../fortran/lsi.f"
k = ip[i__];
/*< IF (.NOT.(I.NE.K)) GO TO 460 >*/
#line 303 "../fortran/lsi.f"
if (! (i__ != k)) {
#line 303 "../fortran/lsi.f"
goto L460;
#line 303 "../fortran/lsi.f"
}
/*< CALL DSWAP(1, W(I,I), 1, W(K,K), 1) >*/
#line 304 "../fortran/lsi.f"
dswap_(&c__1, &w[i__ + i__ * w_dim1], &c__1, &w[k + k * w_dim1], &
c__1);
/*< CALL DSWAP(I-1, W(1,I), 1, W(1,K), 1) >*/
#line 305 "../fortran/lsi.f"
i__2 = i__ - 1;
#line 305 "../fortran/lsi.f"
dswap_(&i__2, &w[i__ * w_dim1 + 1], &c__1, &w[k * w_dim1 + 1], &c__1);
/*< CALL DSWAP(K-I-1, W(I,I+1), MDW, W(I+1,K), 1) >*/
#line 306 "../fortran/lsi.f"
i__2 = k - i__ - 1;
#line 306 "../fortran/lsi.f"
dswap_(&i__2, &w[i__ + (i__ + 1) * w_dim1], mdw, &w[i__ + 1 + k *
w_dim1], &c__1);
/*< CALL DSWAP(N-K, W(I,K+1), MDW, W(K,K+1), MDW) >*/
#line 307 "../fortran/lsi.f"
i__2 = *n - k;
#line 307 "../fortran/lsi.f"
dswap_(&i__2, &w[i__ + (k + 1) * w_dim1], mdw, &w[k + (k + 1) *
w_dim1], mdw);
/*< 460 CONTINUE >*/
#line 308 "../fortran/lsi.f"
L460:
/*< 470 CONTINUE >*/
#line 309 "../fortran/lsi.f"
/* L470: */
#line 309 "../fortran/lsi.f"
;
#line 309 "../fortran/lsi.f"
}
/* PUT IN NORMALIZED RESIDUAL SUM OF SQUARES SCALE FACTOR */
/* AND SYMMETRIZE THE RESULTING COVARIANCE MARIX. */
/*< DO 480 J=1,N >*/
#line 313 "../fortran/lsi.f"
i__1 = *n;
#line 313 "../fortran/lsi.f"
for (j = 1; j <= i__1; ++j) {
/*< CALL DSCAL(J, FAC, W(1,J), 1) >*/
#line 314 "../fortran/lsi.f"
dscal_(&j, &fac, &w[j * w_dim1 + 1], &c__1);
/*< CALL DCOPY(J, W(1,J), 1, W(J,1), MDW) >*/
#line 315 "../fortran/lsi.f"
dcopy_(&j, &w[j * w_dim1 + 1], &c__1, &w[j + w_dim1], mdw);
/*< 480 CONTINUE >*/
#line 316 "../fortran/lsi.f"
/* L480: */
#line 316 "../fortran/lsi.f"
}
/*< 490 GO TO 540 >*/
#line 317 "../fortran/lsi.f"
L490:
#line 317 "../fortran/lsi.f"
goto L540;
/*< 500 CONTINUE >*/
#line 318 "../fortran/lsi.f"
L500:
/* TO PROCESS-OPTION-VECTOR */
/* THE NOMINAL TOLERANCE USED IN THE CODE, */
/*< TOL = DSQRT(DRELPR) >*/
#line 323 "../fortran/lsi.f"
tol = sqrt(drelpr);
/*< COV = .FALSE. >*/
#line 324 "../fortran/lsi.f"
cov = FALSE_;
/*< LAST = 1 >*/
#line 325 "../fortran/lsi.f"
last = 1;
/*< LINK = PRGOPT(1) >*/
#line 326 "../fortran/lsi.f"
link = (integer) prgopt[1];
/*< 510 IF (.NOT.(LINK.GT.1)) GO TO 520 >*/
#line 327 "../fortran/lsi.f"
L510:
#line 327 "../fortran/lsi.f"
if (! (link > 1)) {
#line 327 "../fortran/lsi.f"
goto L520;
#line 327 "../fortran/lsi.f"
}
/*< KEY = PRGOPT(LAST+1) >*/
#line 328 "../fortran/lsi.f"
key = (integer) prgopt[last + 1];
/*< IF (KEY.EQ.1) COV = PRGOPT(LAST+2).NE.ZERO >*/
#line 329 "../fortran/lsi.f"
if (key == 1) {
#line 329 "../fortran/lsi.f"
cov = prgopt[last + 2] != zero;
#line 329 "../fortran/lsi.f"
}
/*< IF (KEY.EQ.5) TOL = DMAX1(DRELPR,PRGOPT(LAST+2)) >*/
#line 330 "../fortran/lsi.f"
if (key == 5) {
/* Computing MAX */
#line 330 "../fortran/lsi.f"
d__1 = drelpr, d__2 = prgopt[last + 2];
#line 330 "../fortran/lsi.f"
tol = max(d__1,d__2);
#line 330 "../fortran/lsi.f"
}
/*< NEXT = PRGOPT(LINK) >*/
#line 331 "../fortran/lsi.f"
next = (integer) prgopt[link];
/*< LAST = LINK >*/
#line 332 "../fortran/lsi.f"
last = link;
/*< LINK = NEXT >*/
#line 333 "../fortran/lsi.f"
link = next;
/*< GO TO 510 >*/
#line 334 "../fortran/lsi.f"
goto L510;
/*< 520 GO TO 530 >*/
#line 335 "../fortran/lsi.f"
L520:
#line 335 "../fortran/lsi.f"
goto L530;
/*< 530 GO TO IGO994, (40) >*/
#line 336 "../fortran/lsi.f"
L530:
#line 336 "../fortran/lsi.f"
switch (igo994) {
#line 336 "../fortran/lsi.f"
case 0: goto L40;
#line 336 "../fortran/lsi.f"
}
/*< 540 GO TO IGO990, (60) >*/
#line 337 "../fortran/lsi.f"
L540:
#line 337 "../fortran/lsi.f"
switch (igo990) {
#line 337 "../fortran/lsi.f"
case 0: goto L60;
#line 337 "../fortran/lsi.f"
}
/*< END >*/
} /* lsi_ */
/*< SUBROUTINE LPDP(A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, IS) >*/
/* Subroutine */ int lpdp_(doublereal *a, integer *mda, integer *m, integer *
n1, integer *n2, doublereal *prgopt, doublereal *x, doublereal *wnorm,
integer *mode, doublereal *ws, integer *is)
{
/* Initialized data */
static doublereal zero = 0.;
static doublereal one = 1.;
static doublereal fac = .1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
integer i__, j, l, n;
doublereal sc;
integer iw, ix, np1;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *), dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
integer modew;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
doublereal rnorm;
extern /* Subroutine */ int wnnls_(doublereal *, integer *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *);
doublereal ynorm;
/* THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO */
/* DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. */
/* USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. */
/* (START EDITING AT LINE WITH C++ IN COLS. 1-3.) */
/* /REAL (12 BLANKS)/DOUBLE PRECISION/,/DNRM2/DNRM2/,/DDOT/DDOT/, */
/* /DCOPY/DCOPY/,/DSCAL/DSCAL/,/DABS(/DABS(/, DABS/, DABS/,/D0/D0/ */
/* DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1), */
/* WHERE N=N1+N2. THIS IS A SLIGHT OVERESTIMATE FOR WS(*). */
/* WRITTEN BY R. J. HANSON AND K. H. HASKELL, SANDIA LABS */
/* REVISED OCT. 1, 1981. */
/* DETERMINE AN N1-VECTOR W, AND */
/* AN N2-VECTOR Z */
/* WHICH MINIMIZES THE EUCLIDEAN LENGTH OF W */
/* SUBJECT TO G*W+H*Z .GE. Y. */
/* THIS IS THE LEAST PROJECTED DISTANCE PROBLEM, LPDP. */
/* THE MATRICES G AND H ARE OF RESPECTIVE */
/* DIMENSIONS M BY N1 AND M BY N2. */
/* CALLED BY SUBPROGRAM LSI( ). */
/* THE MATRIX */
/* (G H Y) */
/* OCCUPIES ROWS 1,...,M AND COLS 1,...,N1+N2+1 OF A(*,*). */
/* THE SOLUTION (W) IS RETURNED IN X(*). */
/* (Z) */
/* THE VALUE OF MODE INDICATES THE STATUS OF */
/* THE COMPUTATION AFTER RETURNING TO THE USER. */
/* MODE=1 THE SOLUTION WAS SUCCESSFULLY OBTAINED. */
/* MODE=2 THE INEQUALITIES ARE INCONSISTENT. */
/* SUBROUTINES CALLED */
/* WNNLS SOLVES A NONNEGATIVELY CONSTRAINED LINEAR LEAST */
/* SQUARES PROBLEM WITH LINEAR EQUALITY CONSTRAINTS. */
/* PART OF THIS PACKAGE. */
/* ++ */
/* DDOT, SUBROUTINES FROM THE BLAS PACKAGE. */
/* DSCAL,DNRM2, SEE TRANS. MATH. SOFT., VOL. 5, NO. 3, P. 308. */
/* DCOPY */
/*< DOUBLE PRECISION A(MDA,1), PRGOPT(1), WS(1), WNORM, X(1) >*/
/*< INTEGER IS(1) >*/
/*< DOUBLE PRECISION FAC, ONE, RNORM, SC, YNORM, ZERO >*/
/*< DOUBLE PRECISION DDOT, DNRM2, DABS >*/
/*< DATA ZERO, ONE /0.D0,1.D0/, FAC /0.1E0/ >*/
#line 56 "../fortran/lpdp.f"
/* Parameter adjustments */
#line 56 "../fortran/lpdp.f"
a_dim1 = *mda;
#line 56 "../fortran/lpdp.f"
a_offset = 1 + a_dim1;
#line 56 "../fortran/lpdp.f"
a -= a_offset;
#line 56 "../fortran/lpdp.f"
--prgopt;
#line 56 "../fortran/lpdp.f"
--x;
#line 56 "../fortran/lpdp.f"
--ws;
#line 56 "../fortran/lpdp.f"
--is;
#line 56 "../fortran/lpdp.f"
#line 56 "../fortran/lpdp.f"
/* Function Body */
/*< N = N1 + N2 >*/
#line 57 "../fortran/lpdp.f"
n = *n1 + *n2;
/*< MODE = 1 >*/
#line 58 "../fortran/lpdp.f"
*mode = 1;
/*< IF (.NOT.(M.LE.0)) GO TO 20 >*/
#line 59 "../fortran/lpdp.f"
if (! (*m <= 0)) {
#line 59 "../fortran/lpdp.f"
goto L20;
#line 59 "../fortran/lpdp.f"
}
/*< IF (.NOT.(N.GT.0)) GO TO 10 >*/
#line 60 "../fortran/lpdp.f"
if (! (n > 0)) {
#line 60 "../fortran/lpdp.f"
goto L10;
#line 60 "../fortran/lpdp.f"
}
/*< X(1) = ZERO >*/
#line 61 "../fortran/lpdp.f"
x[1] = zero;
/*< CALL DCOPY(N, X, 0, X, 1) >*/
#line 62 "../fortran/lpdp.f"
dcopy_(&n, &x[1], &c__0, &x[1], &c__1);
/*< 10 WNORM = ZERO >*/
#line 63 "../fortran/lpdp.f"
L10:
#line 63 "../fortran/lpdp.f"
*wnorm = zero;
/*< RETURN >*/
#line 64 "../fortran/lpdp.f"
return 0;
/*< 20 NP1 = N + 1 >*/
#line 65 "../fortran/lpdp.f"
L20:
#line 65 "../fortran/lpdp.f"
np1 = n + 1;
/* SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE. */
/*< DO 40 I=1,M >*/
#line 68 "../fortran/lpdp.f"
i__1 = *m;
#line 68 "../fortran/lpdp.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< SC = DNRM2(N,A(I,1),MDA) >*/
#line 69 "../fortran/lpdp.f"
sc = dnrm2_(&n, &a[i__ + a_dim1], mda);
/*< IF (.NOT.(SC.NE.ZERO)) GO TO 30 >*/
#line 70 "../fortran/lpdp.f"
if (! (sc != zero)) {
#line 70 "../fortran/lpdp.f"
goto L30;
#line 70 "../fortran/lpdp.f"
}
/*< SC = ONE/SC >*/
#line 71 "../fortran/lpdp.f"
sc = one / sc;
/*< CALL DSCAL(NP1, SC, A(I,1), MDA) >*/
#line 72 "../fortran/lpdp.f"
dscal_(&np1, &sc, &a[i__ + a_dim1], mda);
/*< 30 CONTINUE >*/
#line 73 "../fortran/lpdp.f"
L30:
/*< 40 CONTINUE >*/
#line 74 "../fortran/lpdp.f"
/* L40: */
#line 74 "../fortran/lpdp.f"
;
#line 74 "../fortran/lpdp.f"
}
/* SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO). */
/*< YNORM = DNRM2(M,A(1,NP1),1) >*/
#line 77 "../fortran/lpdp.f"
ynorm = dnrm2_(m, &a[np1 * a_dim1 + 1], &c__1);
/*< IF (.NOT.(YNORM.NE.ZERO)) GO TO 50 >*/
#line 78 "../fortran/lpdp.f"
if (! (ynorm != zero)) {
#line 78 "../fortran/lpdp.f"
goto L50;
#line 78 "../fortran/lpdp.f"
}
/*< SC = ONE/YNORM >*/
#line 79 "../fortran/lpdp.f"
sc = one / ynorm;
/*< CALL DSCAL(M, SC, A(1,NP1), 1) >*/
#line 80 "../fortran/lpdp.f"
dscal_(m, &sc, &a[np1 * a_dim1 + 1], &c__1);
/* SCALE COLS OF MATRIX H. */
/*< 50 J = N1 + 1 >*/
#line 83 "../fortran/lpdp.f"
L50:
#line 83 "../fortran/lpdp.f"
j = *n1 + 1;
/*< 60 IF (.NOT.(J.LE.N)) GO TO 70 >*/
#line 84 "../fortran/lpdp.f"
L60:
#line 84 "../fortran/lpdp.f"
if (! (j <= n)) {
#line 84 "../fortran/lpdp.f"
goto L70;
#line 84 "../fortran/lpdp.f"
}
/*< SC = DNRM2(M,A(1,J),1) >*/
#line 85 "../fortran/lpdp.f"
sc = dnrm2_(m, &a[j * a_dim1 + 1], &c__1);
/*< IF (SC.NE.ZERO) SC = ONE/SC >*/
#line 86 "../fortran/lpdp.f"
if (sc != zero) {
#line 86 "../fortran/lpdp.f"
sc = one / sc;
#line 86 "../fortran/lpdp.f"
}
/*< CALL DSCAL(M, SC, A(1,J), 1) >*/
#line 87 "../fortran/lpdp.f"
dscal_(m, &sc, &a[j * a_dim1 + 1], &c__1);
/*< X(J) = SC >*/
#line 88 "../fortran/lpdp.f"
x[j] = sc;
/*< J = J + 1 >*/
#line 89 "../fortran/lpdp.f"
++j;
/*< GO TO 60 >*/
#line 90 "../fortran/lpdp.f"
goto L60;
/*< 70 IF (.NOT.(N1.GT.0)) GO TO 130 >*/
#line 91 "../fortran/lpdp.f"
L70:
#line 91 "../fortran/lpdp.f"
if (! (*n1 > 0)) {
#line 91 "../fortran/lpdp.f"
goto L130;
#line 91 "../fortran/lpdp.f"
}
/* COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*). */
/*< IW = 0 >*/
#line 94 "../fortran/lpdp.f"
iw = 0;
/*< DO 80 I=1,M >*/
#line 95 "../fortran/lpdp.f"
i__1 = *m;
#line 95 "../fortran/lpdp.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/* MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY. */
/*< CALL DCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1) >*/
#line 98 "../fortran/lpdp.f"
dcopy_(n2, &a[i__ + (*n1 + 1) * a_dim1], mda, &ws[iw + 1], &c__1);
/*< IW = IW + N2 >*/
#line 99 "../fortran/lpdp.f"
iw += *n2;
/* MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY. */
/*< CALL DCOPY(N1, A(I,1), MDA, WS(IW+1), 1) >*/
#line 102 "../fortran/lpdp.f"
dcopy_(n1, &a[i__ + a_dim1], mda, &ws[iw + 1], &c__1);
/*< IW = IW + N1 >*/
#line 103 "../fortran/lpdp.f"
iw += *n1;
/* MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY. */
/*< WS(IW+1) = A(I,NP1) >*/
#line 106 "../fortran/lpdp.f"
ws[iw + 1] = a[i__ + np1 * a_dim1];
/*< IW = IW + 1 >*/
#line 107 "../fortran/lpdp.f"
++iw;
/*< 80 CONTINUE >*/
#line 108 "../fortran/lpdp.f"
/* L80: */
#line 108 "../fortran/lpdp.f"
}
/*< WS(IW+1) = ZERO >*/
#line 109 "../fortran/lpdp.f"
ws[iw + 1] = zero;
/*< CALL DCOPY(N, WS(IW+1), 0, WS(IW+1), 1) >*/
#line 110 "../fortran/lpdp.f"
dcopy_(&n, &ws[iw + 1], &c__0, &ws[iw + 1], &c__1);
/*< IW = IW + N >*/
#line 111 "../fortran/lpdp.f"
iw += n;
/*< WS(IW+1) = ONE >*/
#line 112 "../fortran/lpdp.f"
ws[iw + 1] = one;
/*< IW = IW + 1 >*/
#line 113 "../fortran/lpdp.f"
++iw;
/* SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0. THE */
/* MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR */
/* F = TRANSPOSE OF (0,...,0,1). */
/*< IX = IW + 1 >*/
#line 118 "../fortran/lpdp.f"
ix = iw + 1;
/*< IW = IW + M >*/
#line 119 "../fortran/lpdp.f"
iw += *m;
/* DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF WNNLS( ). */
/*< IS(1) = 0 >*/
#line 122 "../fortran/lpdp.f"
is[1] = 0;
/*< IS(2) = 0 >*/
#line 123 "../fortran/lpdp.f"
is[2] = 0;
/*< >*/
#line 124 "../fortran/lpdp.f"
i__1 = np1 - *n2;
#line 124 "../fortran/lpdp.f"
wnnls_(&ws[1], &np1, n2, &i__1, m, &c__0, &prgopt[1], &ws[ix], &rnorm, &
modew, &is[1], &ws[iw + 1]);
/* COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W. */
/*< SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) >*/
#line 128 "../fortran/lpdp.f"
sc = one - ddot_(m, &a[np1 * a_dim1 + 1], &c__1, &ws[ix], &c__1);
/*< IF (.NOT.(ONE+FAC*DABS(SC).NE.ONE .AND. RNORM.GT.ZERO)) GO TO 110 >*/
#line 129 "../fortran/lpdp.f"
if (! (one + fac * abs(sc) != one && rnorm > zero)) {
#line 129 "../fortran/lpdp.f"
goto L110;
#line 129 "../fortran/lpdp.f"
}
/*< SC = ONE/SC >*/
#line 130 "../fortran/lpdp.f"
sc = one / sc;
/*< DO 90 J=1,N1 >*/
#line 131 "../fortran/lpdp.f"
i__1 = *n1;
#line 131 "../fortran/lpdp.f"
for (j = 1; j <= i__1; ++j) {
/*< X(J) = SC*DDOT(M,A(1,J),1,WS(IX),1) >*/
#line 132 "../fortran/lpdp.f"
x[j] = sc * ddot_(m, &a[j * a_dim1 + 1], &c__1, &ws[ix], &c__1);
/*< 90 CONTINUE >*/
#line 133 "../fortran/lpdp.f"
/* L90: */
#line 133 "../fortran/lpdp.f"
}
/* COMPUTE THE VECTOR Q=Y-GW. OVERWRITE Y WITH THIS VECTOR. */
/*< DO 100 I=1,M >*/
#line 136 "../fortran/lpdp.f"
i__1 = *m;
#line 136 "../fortran/lpdp.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< A(I,NP1) = A(I,NP1) - DDOT(N1,A(I,1),MDA,X,1) >*/
#line 137 "../fortran/lpdp.f"
a[i__ + np1 * a_dim1] -= ddot_(n1, &a[i__ + a_dim1], mda, &x[1], &
c__1);
/*< 100 CONTINUE >*/
#line 138 "../fortran/lpdp.f"
/* L100: */
#line 138 "../fortran/lpdp.f"
}
/*< GO TO 120 >*/
#line 139 "../fortran/lpdp.f"
goto L120;
/*< 110 MODE = 2 >*/
#line 140 "../fortran/lpdp.f"
L110:
#line 140 "../fortran/lpdp.f"
*mode = 2;
/*< RETURN >*/
#line 141 "../fortran/lpdp.f"
return 0;
/*< 120 CONTINUE >*/
#line 142 "../fortran/lpdp.f"
L120:
/*< 130 IF (.NOT.(N2.GT.0)) GO TO 180 >*/
#line 143 "../fortran/lpdp.f"
L130:
#line 143 "../fortran/lpdp.f"
if (! (*n2 > 0)) {
#line 143 "../fortran/lpdp.f"
goto L180;
#line 143 "../fortran/lpdp.f"
}
/* COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*). */
/*< IW = 0 >*/
#line 146 "../fortran/lpdp.f"
iw = 0;
/*< DO 140 I=1,M >*/
#line 147 "../fortran/lpdp.f"
i__1 = *m;
#line 147 "../fortran/lpdp.f"
for (i__ = 1; i__ <= i__1; ++i__) {
/*< CALL DCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1) >*/
#line 148 "../fortran/lpdp.f"
dcopy_(n2, &a[i__ + (*n1 + 1) * a_dim1], mda, &ws[iw + 1], &c__1);
/*< IW = IW + N2 >*/
#line 149 "../fortran/lpdp.f"
iw += *n2;
/*< WS(IW+1) = A(I,NP1) >*/
#line 150 "../fortran/lpdp.f"
ws[iw + 1] = a[i__ + np1 * a_dim1];
/*< IW = IW + 1 >*/
#line 151 "../fortran/lpdp.f"
++iw;
/*< 140 CONTINUE >*/
#line 152 "../fortran/lpdp.f"
/* L140: */
#line 152 "../fortran/lpdp.f"
}
/*< WS(IW+1) = ZERO >*/
#line 153 "../fortran/lpdp.f"
ws[iw + 1] = zero;
/*< CALL DCOPY(N2, WS(IW+1), 0, WS(IW+1), 1) >*/
#line 154 "../fortran/lpdp.f"
dcopy_(n2, &ws[iw + 1], &c__0, &ws[iw + 1], &c__1);
/*< IW = IW + N2 >*/
#line 155 "../fortran/lpdp.f"
iw += *n2;
/*< WS(IW+1) = ONE >*/
#line 156 "../fortran/lpdp.f"
ws[iw + 1] = one;
/*< IW = IW + 1 >*/
#line 157 "../fortran/lpdp.f"
++iw;
/*< IX = IW + 1 >*/
#line 158 "../fortran/lpdp.f"
ix = iw + 1;
/*< IW = IW + M >*/
#line 159 "../fortran/lpdp.f"
iw += *m;
/* SOLVE RV=S SUBJECT TO V.GE.0. THE MATRIX R =(TRANSPOSE */
/* OF (H Q)), WHERE Q=Y-GW. THE (N2+1)-VECTOR S =(TRANSPOSE */
/* OF (0,...,0,1)). */
/* DO NOT CHECK LENGTHS OF WORK ARRAYS IN THIS USAGE OF WNNLS( ). */
/*< IS(1) = 0 >*/
#line 166 "../fortran/lpdp.f"
is[1] = 0;
/*< IS(2) = 0 >*/
#line 167 "../fortran/lpdp.f"
is[2] = 0;
/*< >*/
#line 168 "../fortran/lpdp.f"
i__1 = *n2 + 1;
#line 168 "../fortran/lpdp.f"
i__2 = *n2 + 1;
#line 168 "../fortran/lpdp.f"
wnnls_(&ws[1], &i__1, &c__0, &i__2, m, &c__0, &prgopt[1], &ws[ix], &rnorm,
&modew, &is[1], &ws[iw + 1]);
/* COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z. */
/*< SC = ONE - DDOT(M,A(1,NP1),1,WS(IX),1) >*/
#line 172 "../fortran/lpdp.f"
sc = one - ddot_(m, &a[np1 * a_dim1 + 1], &c__1, &ws[ix], &c__1);
/*< IF (.NOT.(ONE+FAC*DABS(SC).NE.ONE .AND. RNORM.GT.ZERO)) GO TO 160 >*/
#line 173 "../fortran/lpdp.f"
if (! (one + fac * abs(sc) != one && rnorm > zero)) {
#line 173 "../fortran/lpdp.f"
goto L160;
#line 173 "../fortran/lpdp.f"
}
/*< SC = ONE/SC >*/
#line 174 "../fortran/lpdp.f"
sc = one / sc;
/*< DO 150 J=1,N2 >*/
#line 175 "../fortran/lpdp.f"
i__1 = *n2;
#line 175 "../fortran/lpdp.f"
for (j = 1; j <= i__1; ++j) {
/*< L = N1 + J >*/
#line 176 "../fortran/lpdp.f"
l = *n1 + j;
/*< X(L) = SC*DDOT(M,A(1,L),1,WS(IX),1)*X(L) >*/
#line 177 "../fortran/lpdp.f"
x[l] = sc * ddot_(m, &a[l * a_dim1 + 1], &c__1, &ws[ix], &c__1) * x[l]
;
/*< 150 CONTINUE >*/
#line 178 "../fortran/lpdp.f"
/* L150: */
#line 178 "../fortran/lpdp.f"
}
/*< GO TO 170 >*/
#line 179 "../fortran/lpdp.f"
goto L170;
/*< 160 MODE = 2 >*/
#line 180 "../fortran/lpdp.f"
L160:
#line 180 "../fortran/lpdp.f"
*mode = 2;
/*< RETURN >*/
#line 181 "../fortran/lpdp.f"
return 0;
/*< 170 CONTINUE >*/
#line 182 "../fortran/lpdp.f"
L170:
/* ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION. */
/*< 180 CALL DSCAL(N, YNORM, X, 1) >*/
#line 185 "../fortran/lpdp.f"
L180:
#line 185 "../fortran/lpdp.f"
dscal_(&n, &ynorm, &x[1], &c__1);
/*< WNORM = DNRM2(N1,X,1) >*/
#line 186 "../fortran/lpdp.f"
*wnorm = dnrm2_(n1, &x[1], &c__1);
/*< RETURN >*/
#line 187 "../fortran/lpdp.f"
return 0;
/*< END >*/
} /* lpdp_ */
/* Subroutine */ int dorgl2_(const integer *m, const integer *n, const integer *k, doublereal *
a, const integer *lda, const doublereal *tau, const doublereal *work, integer *info)
{
/* -- LAPACK routine (version 3.1) --
Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
November 2006
Purpose
=======
DORGL2 generates an m by n real matrix Q with orthonormal rows,
which is defined as the first m rows of a product of k elementary
reflectors of order n
Q = H(k) . . . H(2) H(1)
as returned by DGELQF.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q. N >= M.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. M >= K >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the i-th row must contain the vector which defines
the elementary reflector H(i), for i = 1,2,...,k, as returned
by DGELQF in the first k rows of its array argument A.
On exit, the m-by-n matrix Q.
LDA (input) INTEGER
The first dimension of the array A. LDA >= max(1,M).
TAU (input) DOUBLE PRECISION array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by DGELQF.
WORK (workspace) DOUBLE PRECISION array, dimension (M)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument has an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
_THREAD_STATIC_ integer i__, j, l;
extern /* Subroutine */ int dscal_(const integer *, const doublereal *, const doublereal *,
const integer *), dlarf_(const char *, const integer *, const integer *, const doublereal *,
const integer *, const doublereal *, const doublereal *, const integer *, const doublereal *), xerbla_(const char *, const integer *);
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < *m) {
*info = -2;
} else if (*k < 0 || *k > *m) {
*info = -3;
} else if (*lda < max(1,*m)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DORGL2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m <= 0) {
return 0;
}
if (*k < *m) {
/* Initialise rows k+1:m to rows of the unit matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (l = *k + 1; l <= i__2; ++l) {
a[l + j * a_dim1] = 0.;
/* L10: */
}
if (j > *k && j <= *m) {
a[j + j * a_dim1] = 1.;
}
/* L20: */
}
}
for (i__ = *k; i__ >= 1; --i__) {
/* Apply H(i) to A(i:m,i:n) from the right */
if (i__ < *n) {
if (i__ < *m) {
a[i__ + i__ * a_dim1] = 1.;
i__1 = *m - i__;
i__2 = *n - i__ + 1;
dlarf_("Right", &i__1, &i__2, &a[i__ + i__ * a_dim1], lda, &
tau[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
}
i__1 = *n - i__;
d__1 = -tau[i__];
dscal_(&i__1, &d__1, &a[i__ + (i__ + 1) * a_dim1], lda);
}
a[i__ + i__ * a_dim1] = 1. - tau[i__];
/* Set A(i,1:i-1) to zero */
i__1 = i__ - 1;
for (l = 1; l <= i__1; ++l) {
a[i__ + l * a_dim1] = 0.;
/* L30: */
}
/* L40: */
}
return 0;
/* End of DORGL2 */
} /* dorgl2_ */
int zhbev_(char *jobz, char *uplo, int *n, int *kd,
doublecomplex *ab, int *ldab, double *w, doublecomplex *z__,
int *ldz, doublecomplex *work, double *rwork, int *info)
{
/* System generated locals */
int ab_dim1, ab_offset, z_dim1, z_offset, i__1;
double d__1;
/* Builtin functions */
double sqrt(double);
/* Local variables */
double eps;
int inde;
double anrm;
int imax;
double rmin, rmax;
extern int dscal_(int *, double *, double *,
int *);
double sigma;
extern int lsame_(char *, char *);
int iinfo;
int lower, wantz;
extern double dlamch_(char *);
int iscale;
double safmin;
extern double zlanhb_(char *, char *, int *, int *,
doublecomplex *, int *, double *);
extern int xerbla_(char *, int *);
double bignum;
extern int dsterf_(int *, double *, double *,
int *), zlascl_(char *, int *, int *, double *,
double *, int *, int *, doublecomplex *, int *,
int *), zhbtrd_(char *, char *, int *, int *,
doublecomplex *, int *, double *, double *,
doublecomplex *, int *, doublecomplex *, int *);
int indrwk;
double smlnum;
extern int zsteqr_(char *, int *, double *,
double *, doublecomplex *, int *, double *, int *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHBEV computes all the eigenvalues and, optionally, eigenvectors of */
/* a complex Hermitian band matrix A. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of superdiagonals of the matrix A if UPLO = 'U', */
/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
/* AB (input/output) COMPLEX*16 array, dimension (LDAB, N) */
/* On entry, the upper or lower triangle of the Hermitian band */
/* matrix A, stored in the first KD+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for MAX(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=MIN(n,j+kd). */
/* On exit, AB is overwritten by values generated during the */
/* reduction to tridiagonal form. If UPLO = 'U', the first */
/* superdiagonal and the diagonal of the tridiagonal matrix T */
/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
/* the diagonal and first subdiagonal of T are returned in the */
/* first two rows of AB. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD + 1. */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) COMPLEX*16 array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
/* eigenvectors of the matrix A, with the i-th column of Z */
/* holding the eigenvector associated with W(i). */
/* If JOBZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= MAX(1,N). */
/* WORK (workspace) COMPLEX*16 array, dimension (N) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,3*N-2)) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the algorithm failed to converge; i */
/* off-diagonal elements of an intermediate tridiagonal */
/* form did not converge to zero. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
wantz = lsame_(jobz, "V");
lower = lsame_(uplo, "L");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*kd < 0) {
*info = -4;
} else if (*ldab < *kd + 1) {
*info = -6;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHBEV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (lower) {
i__1 = ab_dim1 + 1;
w[1] = ab[i__1].r;
} else {
i__1 = *kd + 1 + ab_dim1;
w[1] = ab[i__1].r;
}
if (wantz) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1., z__[i__1].i = 0.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = zlanhb_("M", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]);
iscale = 0;
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
zlascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
info);
} else {
zlascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
info);
}
}
/* Call ZHBTRD to reduce Hermitian band matrix to tridiagonal form. */
inde = 1;
zhbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &rwork[inde], &
z__[z_offset], ldz, &work[1], &iinfo);
/* For eigenvalues only, call DSTERF. For eigenvectors, call ZSTEQR. */
if (! wantz) {
dsterf_(n, &w[1], &rwork[inde], info);
} else {
indrwk = inde + *n;
zsteqr_(jobz, n, &w[1], &rwork[inde], &z__[z_offset], ldz, &rwork[
indrwk], info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &w[1], &c__1);
}
return 0;
/* End of ZHBEV */
} /* zhbev_ */
/* Subroutine */ int dlaed2_(integer *k, integer *n, integer *n1, doublereal *
d__, doublereal *q, integer *ldq, integer *indxq, doublereal *rho,
doublereal *z__, doublereal *dlamda, doublereal *w, doublereal *q2,
integer *indx, integer *indxc, integer *indxp, integer *coltyp,
integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal c__;
integer i__, j;
doublereal s, t;
integer k2, n2, ct, nj, pj, js, iq1, iq2, n1p1;
doublereal eps, tau, tol;
integer psm[4], imax, jmax;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
integer ctot[4];
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dcopy_(integer *, doublereal *, integer *, doublereal
*, integer *);
extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *,
integer *, integer *, integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAED2 merges the two sets of eigenvalues together into a single */
/* sorted set. Then it tries to deflate the size of the problem. */
/* There are two ways in which deflation can occur: when two or more */
/* eigenvalues are close together or if there is a tiny entry in the */
/* Z vector. For each such occurrence the order of the related secular */
/* equation problem is reduced by one. */
/* Arguments */
/* ========= */
/* K (output) INTEGER */
/* The number of non-deflated eigenvalues, and the order of the */
/* related secular equation. 0 <= K <=N. */
/* N (input) INTEGER */
/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
/* N1 (input) INTEGER */
/* The location of the last eigenvalue in the leading sub-matrix. */
/* min(1,N) <= N1 <= N/2. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, D contains the eigenvalues of the two submatrices to */
/* be combined. */
/* On exit, D contains the trailing (N-K) updated eigenvalues */
/* (those which were deflated) sorted into increasing order. */
/* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) */
/* On entry, Q contains the eigenvectors of two submatrices in */
/* the two square blocks with corners at (1,1), (N1,N1) */
/* and (N1+1, N1+1), (N,N). */
/* On exit, Q contains the trailing (N-K) updated eigenvectors */
/* (those which were deflated) in its last N-K columns. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,N). */
/* INDXQ (input/output) INTEGER array, dimension (N) */
/* The permutation which separately sorts the two sub-problems */
/* in D into ascending order. Note that elements in the second */
/* half of this permutation must first have N1 added to their */
/* values. Destroyed on exit. */
/* RHO (input/output) DOUBLE PRECISION */
/* On entry, the off-diagonal element associated with the rank-1 */
/* cut which originally split the two submatrices which are now */
/* being recombined. */
/* On exit, RHO has been modified to the value required by */
/* DLAED3. */
/* Z (input) DOUBLE PRECISION array, dimension (N) */
/* On entry, Z contains the updating vector (the last */
/* row of the first sub-eigenvector matrix and the first row of */
/* the second sub-eigenvector matrix). */
/* On exit, the contents of Z have been destroyed by the updating */
/* process. */
/* DLAMDA (output) DOUBLE PRECISION array, dimension (N) */
/* A copy of the first K eigenvalues which will be used by */
/* DLAED3 to form the secular equation. */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* The first k values of the final deflation-altered z-vector */
/* which will be passed to DLAED3. */
/* Q2 (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2) */
/* A copy of the first K eigenvectors which will be used by */
/* DLAED3 in a matrix multiply (DGEMM) to solve for the new */
/* eigenvectors. */
/* INDX (workspace) INTEGER array, dimension (N) */
/* The permutation used to sort the contents of DLAMDA into */
/* ascending order. */
/* INDXC (output) INTEGER array, dimension (N) */
/* The permutation used to arrange the columns of the deflated */
/* Q matrix into three groups: the first group contains non-zero */
/* elements only at and above N1, the second contains */
/* non-zero elements only below N1, and the third is dense. */
/* INDXP (workspace) INTEGER array, dimension (N) */
/* The permutation used to place deflated values of D at the end */
/* of the array. INDXP(1:K) points to the nondeflated D-values */
/* and INDXP(K+1:N) points to the deflated eigenvalues. */
/* COLTYP (workspace/output) INTEGER array, dimension (N) */
/* During execution, a label which will indicate which of the */
/* following types a column in the Q2 matrix is: */
/* 1 : non-zero in the upper half only; */
/* 2 : dense; */
/* 3 : non-zero in the lower half only; */
/* 4 : deflated. */
/* On exit, COLTYP(i) is the number of columns of type i, */
/* for i=1 to 4 only. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Jeff Rutter, Computer Science Division, University of California */
/* at Berkeley, USA */
/* Modified by Francoise Tisseur, University of Tennessee. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--indxq;
--z__;
--dlamda;
--w;
--q2;
--indx;
--indxc;
--indxp;
--coltyp;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -2;
} else if (*ldq < max(1,*n)) {
*info = -6;
} else /* if(complicated condition) */ {
/* Computing MIN */
i__1 = 1, i__2 = *n / 2;
if (min(i__1,i__2) > *n1 || *n / 2 < *n1) {
*info = -3;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLAED2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
n2 = *n - *n1;
n1p1 = *n1 + 1;
if (*rho < 0.) {
dscal_(&n2, &c_b3, &z__[n1p1], &c__1);
}
/* Normalize z so that norm(z) = 1. Since z is the concatenation of */
/* two normalized vectors, norm2(z) = sqrt(2). */
t = 1. / sqrt(2.);
dscal_(n, &t, &z__[1], &c__1);
/* RHO = ABS( norm(z)**2 * RHO ) */
*rho = (d__1 = *rho * 2., abs(d__1));
/* Sort the eigenvalues into increasing order */
i__1 = *n;
for (i__ = n1p1; i__ <= i__1; ++i__) {
indxq[i__] += *n1;
/* L10: */
}
/* re-integrate the deflated parts from the last pass */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = d__[indxq[i__]];
/* L20: */
}
dlamrg_(n1, &n2, &dlamda[1], &c__1, &c__1, &indxc[1]);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
indx[i__] = indxq[indxc[i__]];
/* L30: */
}
/* Calculate the allowable deflation tolerance */
imax = idamax_(n, &z__[1], &c__1);
jmax = idamax_(n, &d__[1], &c__1);
eps = dlamch_("Epsilon");
/* Computing MAX */
d__3 = (d__1 = d__[jmax], abs(d__1)), d__4 = (d__2 = z__[imax], abs(d__2))
;
tol = eps * 8. * max(d__3,d__4);
/* If the rank-1 modifier is small enough, no more needs to be done */
/* except to reorganize Q so that its columns correspond with the */
/* elements in D. */
if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) {
*k = 0;
iq2 = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__ = indx[j];
dcopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1);
dlamda[j] = d__[i__];
iq2 += *n;
/* L40: */
}
dlacpy_("A", n, n, &q2[1], n, &q[q_offset], ldq);
dcopy_(n, &dlamda[1], &c__1, &d__[1], &c__1);
goto L190;
}
/* If there are multiple eigenvalues then the problem deflates. Here */
/* the number of equal eigenvalues are found. As each equal */
/* eigenvalue is found, an elementary reflector is computed to rotate */
/* the corresponding eigensubspace so that the corresponding */
/* components of Z are zero in this new basis. */
i__1 = *n1;
for (i__ = 1; i__ <= i__1; ++i__) {
coltyp[i__] = 1;
/* L50: */
}
i__1 = *n;
for (i__ = n1p1; i__ <= i__1; ++i__) {
coltyp[i__] = 3;
/* L60: */
}
*k = 0;
k2 = *n + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
nj = indx[j];
if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
coltyp[nj] = 4;
indxp[k2] = nj;
if (j == *n) {
goto L100;
}
} else {
pj = nj;
goto L80;
}
/* L70: */
}
L80:
++j;
nj = indx[j];
if (j > *n) {
goto L100;
}
if (*rho * (d__1 = z__[nj], abs(d__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
coltyp[nj] = 4;
indxp[k2] = nj;
} else {
/* Check if eigenvalues are close enough to allow deflation. */
s = z__[pj];
c__ = z__[nj];
/* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */
tau = dlapy2_(&c__, &s);
t = d__[nj] - d__[pj];
c__ /= tau;
s = -s / tau;
if ((d__1 = t * c__ * s, abs(d__1)) <= tol) {
/* Deflation is possible. */
z__[nj] = tau;
z__[pj] = 0.;
if (coltyp[nj] != coltyp[pj]) {
coltyp[nj] = 2;
}
coltyp[pj] = 4;
drot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, &
c__, &s);
/* Computing 2nd power */
d__1 = c__;
/* Computing 2nd power */
d__2 = s;
t = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2);
/* Computing 2nd power */
d__1 = s;
/* Computing 2nd power */
d__2 = c__;
d__[nj] = d__[pj] * (d__1 * d__1) + d__[nj] * (d__2 * d__2);
d__[pj] = t;
--k2;
i__ = 1;
L90:
if (k2 + i__ <= *n) {
if (d__[pj] < d__[indxp[k2 + i__]]) {
indxp[k2 + i__ - 1] = indxp[k2 + i__];
indxp[k2 + i__] = pj;
++i__;
goto L90;
} else {
indxp[k2 + i__ - 1] = pj;
}
} else {
indxp[k2 + i__ - 1] = pj;
}
pj = nj;
} else {
++(*k);
dlamda[*k] = d__[pj];
w[*k] = z__[pj];
indxp[*k] = pj;
pj = nj;
}
}
goto L80;
L100:
/* Record the last eigenvalue. */
++(*k);
dlamda[*k] = d__[pj];
w[*k] = z__[pj];
indxp[*k] = pj;
/* Count up the total number of the various types of columns, then */
/* form a permutation which positions the four column types into */
/* four uniform groups (although one or more of these groups may be */
/* empty). */
for (j = 1; j <= 4; ++j) {
ctot[j - 1] = 0;
/* L110: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
ct = coltyp[j];
++ctot[ct - 1];
/* L120: */
}
/* PSM(*) = Position in SubMatrix (of types 1 through 4) */
psm[0] = 1;
psm[1] = ctot[0] + 1;
psm[2] = psm[1] + ctot[1];
psm[3] = psm[2] + ctot[2];
*k = *n - ctot[3];
/* Fill out the INDXC array so that the permutation which it induces */
/* will place all type-1 columns first, all type-2 columns next, */
/* then all type-3's, and finally all type-4's. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
js = indxp[j];
ct = coltyp[js];
indx[psm[ct - 1]] = js;
indxc[psm[ct - 1]] = j;
++psm[ct - 1];
/* L130: */
}
/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */
/* and Q2 respectively. The eigenvalues/vectors which were not */
/* deflated go into the first K slots of DLAMDA and Q2 respectively, */
/* while those which were deflated go into the last N - K slots. */
i__ = 1;
iq1 = 1;
iq2 = (ctot[0] + ctot[1]) * *n1 + 1;
i__1 = ctot[0];
for (j = 1; j <= i__1; ++j) {
js = indx[i__];
dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1);
z__[i__] = d__[js];
++i__;
iq1 += *n1;
/* L140: */
}
i__1 = ctot[1];
for (j = 1; j <= i__1; ++j) {
js = indx[i__];
dcopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1);
dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1);
z__[i__] = d__[js];
++i__;
iq1 += *n1;
iq2 += n2;
/* L150: */
}
i__1 = ctot[2];
for (j = 1; j <= i__1; ++j) {
js = indx[i__];
dcopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1);
z__[i__] = d__[js];
++i__;
iq2 += n2;
/* L160: */
}
iq1 = iq2;
i__1 = ctot[3];
for (j = 1; j <= i__1; ++j) {
js = indx[i__];
dcopy_(n, &q[js * q_dim1 + 1], &c__1, &q2[iq2], &c__1);
iq2 += *n;
z__[i__] = d__[js];
++i__;
/* L170: */
}
/* The deflated eigenvalues and their corresponding vectors go back */
/* into the last N - K slots of D and Q respectively. */
dlacpy_("A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq);
i__1 = *n - *k;
dcopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1);
/* Copy CTOT into COLTYP for referencing in DLAED3. */
for (j = 1; j <= 4; ++j) {
coltyp[j] = ctot[j - 1];
/* L180: */
}
L190:
return 0;
/* End of DLAED2 */
} /* dlaed2_ */
/* Subroutine */ int dlaror_(char *side, char *init, integer *m, integer *n,
doublereal *a, integer *lda, integer *iseed, doublereal *x, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
/* Local variables */
static integer kbeg;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer jcol, irow;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer j;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
static integer ixfrm, itype, nxfrm;
static doublereal xnorm;
extern doublereal dlarnd_(integer *, integer *);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
static doublereal factor, xnorms;
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DLAROR pre- or post-multiplies an M by N matrix A by a random
orthogonal matrix U, overwriting A. A may optionally be initialized
to the identity matrix before multiplying by U. U is generated using
the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409).
Arguments
=========
SIDE (input) CHARACTER*1
Specifies whether A is multiplied on the left or right by U.
= 'L': Multiply A on the left (premultiply) by U
= 'R': Multiply A on the right (postmultiply) by U'
= 'C' or 'T': Multiply A on the left by U and the right
by U' (Here, U' means U-transpose.)
INIT (input) CHARACTER*1
Specifies whether or not A should be initialized to the
identity matrix.
= 'I': Initialize A to (a section of) the identity matrix
before applying U.
= 'N': No initialization. Apply U to the input matrix A.
INIT = 'I' may be used to generate square or rectangular
orthogonal matrices:
For M = N and SIDE = 'L' or 'R', the rows will be orthogonal
to each other, as will the columns.
If M < N, SIDE = 'R' produces a dense matrix whose rows are
orthogonal and whose columns are not, while SIDE = 'L'
produces a matrix whose rows are orthogonal, and whose first
M columns are orthogonal, and whose remaining columns are
zero.
If M > N, SIDE = 'L' produces a dense matrix whose columns
are orthogonal and whose rows are not, while SIDE = 'R'
produces a matrix whose columns are orthogonal, and whose
first M rows are orthogonal, and whose remaining rows are
zero.
M (input) INTEGER
The number of rows of A.
N (input) INTEGER
The number of columns of A.
A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
On entry, the array A.
On exit, overwritten by U A ( if SIDE = 'L' ),
or by A U ( if SIDE = 'R' ),
or by U A U' ( if SIDE = 'C' or 'T').
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
ISEED (input/output) INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to DLAROR to continue the same random number
sequence.
X (workspace) DOUBLE PRECISION array, dimension (3*MAX( M, N ))
Workspace of length
2*M + N if SIDE = 'L',
2*N + M if SIDE = 'R',
3*N if SIDE = 'C' or 'T'.
INFO (output) INTEGER
An error flag. It is set to:
= 0: normal return
< 0: if INFO = -k, the k-th argument had an illegal value
= 1: if the random numbers generated by DLARND are bad.
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--x;
/* Function Body */
if (*n == 0 || *m == 0) {
return 0;
}
itype = 0;
if (lsame_(side, "L")) {
itype = 1;
} else if (lsame_(side, "R")) {
itype = 2;
} else if (lsame_(side, "C") || lsame_(side, "T")) {
itype = 3;
}
/* Check for argument errors. */
*info = 0;
if (itype == 0) {
*info = -1;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0 || itype == 3 && *n != *m) {
*info = -4;
} else if (*lda < *m) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLAROR", &i__1);
return 0;
}
if (itype == 1) {
nxfrm = *m;
} else {
nxfrm = *n;
}
/* Initialize A to the identity matrix if desired */
if (lsame_(init, "I")) {
dlaset_("Full", m, n, &c_b9, &c_b10, &a[a_offset], lda);
}
/* If no rotation possible, multiply by random +/-1
Compute rotation by computing Householder transformations
H(2), H(3), ..., H(nhouse) */
i__1 = nxfrm;
for (j = 1; j <= i__1; ++j) {
x[j] = 0.;
/* L10: */
}
i__1 = nxfrm;
for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
kbeg = nxfrm - ixfrm + 1;
/* Generate independent normal( 0, 1 ) random numbers */
i__2 = nxfrm;
for (j = kbeg; j <= i__2; ++j) {
x[j] = dlarnd_(&c__3, &iseed[1]);
/* L20: */
}
/* Generate a Householder transformation from the random vector
X */
xnorm = dnrm2_(&ixfrm, &x[kbeg], &c__1);
xnorms = d_sign(&xnorm, &x[kbeg]);
d__1 = -x[kbeg];
x[kbeg + nxfrm] = d_sign(&c_b10, &d__1);
factor = xnorms * (xnorms + x[kbeg]);
if (abs(factor) < 1e-20) {
*info = 1;
xerbla_("DLAROR", info);
return 0;
} else {
factor = 1. / factor;
}
x[kbeg] += xnorms;
/* Apply Householder transformation to A */
if (itype == 1 || itype == 3) {
/* Apply H(k) from the left. */
dgemv_("T", &ixfrm, n, &c_b10, &a[kbeg + a_dim1], lda, &x[kbeg], &
c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
d__1 = -factor;
dger_(&ixfrm, n, &d__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
c__1, &a[kbeg + a_dim1], lda);
}
if (itype == 2 || itype == 3) {
/* Apply H(k) from the right. */
dgemv_("N", m, &ixfrm, &c_b10, &a[kbeg * a_dim1 + 1], lda, &x[
kbeg], &c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
d__1 = -factor;
dger_(m, &ixfrm, &d__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
c__1, &a[kbeg * a_dim1 + 1], lda);
}
/* L30: */
}
d__1 = dlarnd_(&c__3, &iseed[1]);
x[nxfrm * 2] = d_sign(&c_b10, &d__1);
/* Scale the matrix A by D. */
if (itype == 1 || itype == 3) {
i__1 = *m;
for (irow = 1; irow <= i__1; ++irow) {
dscal_(n, &x[nxfrm + irow], &a[irow + a_dim1], lda);
/* L40: */
}
}
if (itype == 2 || itype == 3) {
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
dscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
/* L50: */
}
}
return 0;
/* End of DLAROR */
} /* dlaror_ */
int dlahr2_(int *n, int *k, int *nb, double *
a, int *lda, double *tau, double *t, int *ldt,
double *y, int *ldy)
{
/* System generated locals */
int a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
double d__1;
/* Local variables */
int i__;
double ei;
extern int dscal_(int *, double *, double *,
int *), dgemm_(char *, char *, int *, int *, int *
, double *, double *, int *, double *, int *,
double *, double *, int *), dgemv_(
char *, int *, int *, double *, double *, int
*, double *, int *, double *, double *, int *), dcopy_(int *, double *, int *, double *,
int *), dtrmm_(char *, char *, char *, char *, int *,
int *, double *, double *, int *, double *,
int *), daxpy_(int *,
double *, double *, int *, double *, int *),
dtrmv_(char *, char *, char *, int *, double *, int *,
double *, int *), dlarfg_(
int *, double *, double *, int *, double *),
dlacpy_(char *, int *, int *, double *, int *,
double *, int *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAHR2 reduces the first NB columns of A float general n-BY-(n-k+1) */
/* matrix A so that elements below the k-th subdiagonal are zero. The */
/* reduction is performed by an orthogonal similarity transformation */
/* Q' * A * Q. The routine returns the matrices V and T which determine */
/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
/* This is an auxiliary routine called by DGEHRD. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* K (input) INTEGER */
/* The offset for the reduction. Elements below the k-th */
/* subdiagonal in the first NB columns are reduced to zero. */
/* K < N. */
/* NB (input) INTEGER */
/* The number of columns to be reduced. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1) */
/* On entry, the n-by-(n-k+1) general matrix A. */
/* On exit, the elements on and above the k-th subdiagonal in */
/* the first NB columns are overwritten with the corresponding */
/* elements of the reduced matrix; the elements below the k-th */
/* subdiagonal, with the array TAU, represent the matrix Q as a */
/* product of elementary reflectors. The other columns of A are */
/* unchanged. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* TAU (output) DOUBLE PRECISION array, dimension (NB) */
/* The scalar factors of the elementary reflectors. See Further */
/* Details. */
/* T (output) DOUBLE PRECISION array, dimension (LDT,NB) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= NB. */
/* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) */
/* The n-by-nb matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= N. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of nb elementary reflectors */
/* Q = H(1) H(2) . . . H(nb). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a float scalar, and v is a float vector with */
/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
/* A(i+k+1:n,i), and tau in TAU(i). */
/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
/* V which is needed, with T and Y, to apply the transformation to the */
/* unreduced part of the matrix, using an update of the form: */
/* A := (I - V*T*V') * (A - Y*V'). */
/* The contents of A on exit are illustrated by the following example */
/* with n = 7, k = 3 and nb = 2: */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( h h a a a ) */
/* ( v1 h a a a ) */
/* ( v1 v2 a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* This file is a slight modification of LAPACK-3.0's DLAHRD */
/* incorporating improvements proposed by Quintana-Orti and Van de */
/* Gejin. Note that the entries of A(1:K,2:NB) differ from those */
/* returned by the original LAPACK routine. This function is */
/* not backward compatible with LAPACK3.0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--tau;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
/* Update A(K+1:N,I) */
/* Update I-th column of A - Y * V' */
i__2 = *n - *k;
i__3 = i__ - 1;
dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1],
ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b5, &a[*k + 1 +
i__ * a_dim1], &c__1);
/* Apply I - V * T' * V' to this column (call it b) from the */
/* left, using the last column of T as workspace */
/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
/* ( V2 ) ( b2 ) */
/* where V1 is unit lower triangular */
/* w := V1' * b1 */
i__2 = i__ - 1;
dcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
1], &c__1);
i__2 = i__ - 1;
dtrmv_("Lower", "Transpose", "UNIT", &i__2, &a[*k + 1 + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1);
/* w := w + V2'*b2 */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1],
lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b5, &t[*nb *
t_dim1 + 1], &c__1);
/* w := T'*w */
i__2 = i__ - 1;
dtrmv_("Upper", "Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
&t[*nb * t_dim1 + 1], &c__1);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &a[*k + i__ + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, &c_b5, &a[*k + i__ +
i__ * a_dim1], &c__1);
/* b1 := b1 - V1*w */
i__2 = i__ - 1;
dtrmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1]
, lda, &t[*nb * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
daxpy_(&i__2, &c_b4, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
* a_dim1], &c__1);
a[*k + i__ - 1 + (i__ - 1) * a_dim1] = ei;
}
/* Generate the elementary reflector H(I) to annihilate */
/* A(K+I+1:N,I) */
i__2 = *n - *k - i__ + 1;
/* Computing MIN */
i__3 = *k + i__ + 1;
dlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[MIN(i__3, *n)+ i__ *
a_dim1], &c__1, &tau[i__]);
ei = a[*k + i__ + i__ * a_dim1];
a[*k + i__ + i__ * a_dim1] = 1.;
/* Compute Y(K+1:N,I) */
i__2 = *n - *k;
i__3 = *n - *k - i__ + 1;
dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b5, &a[*k + 1 + (i__ + 1) *
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &y[*
k + 1 + i__ * y_dim1], &c__1);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
dgemv_("Transpose", &i__2, &i__3, &c_b5, &a[*k + i__ + a_dim1], lda, &
a[*k + i__ + i__ * a_dim1], &c__1, &c_b38, &t[i__ * t_dim1 +
1], &c__1);
i__2 = *n - *k;
i__3 = i__ - 1;
dgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b4, &y[*k + 1 + y_dim1], ldy,
&t[i__ * t_dim1 + 1], &c__1, &c_b5, &y[*k + 1 + i__ * y_dim1],
&c__1);
i__2 = *n - *k;
dscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1);
/* Compute T(1:I,I) */
i__2 = i__ - 1;
d__1 = -tau[i__];
dscal_(&i__2, &d__1, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
dtrmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
&t[i__ * t_dim1 + 1], &c__1)
;
t[i__ + i__ * t_dim1] = tau[i__];
/* L10: */
}
a[*k + *nb + *nb * a_dim1] = ei;
/* Compute Y(1:K,1:NB) */
dlacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy);
dtrmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b5, &a[*k + 1
+ a_dim1], lda, &y[y_offset], ldy);
if (*n > *k + *nb) {
i__1 = *n - *k - *nb;
dgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b5, &a[(*nb +
2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b5,
&y[y_offset], ldy);
}
dtrmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b5, &t[
t_offset], ldt, &y[y_offset], ldy);
return 0;
/* End of DLAHR2 */
} /* dlahr2_ */
/* Subroutine */
int dpptri_(char *uplo, integer *n, doublereal *ap, integer * info)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
integer j, jc, jj;
doublereal ajj;
integer jjn;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *);
extern /* Subroutine */
int dspr_(char *, integer *, doublereal *, doublereal *, integer *, doublereal *), dscal_(integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int dtpmv_(char *, char *, char *, integer *, doublereal *, doublereal *, integer *);
logical upper;
extern /* Subroutine */
int xerbla_(char *, integer *), dtptri_( char *, char *, integer *, doublereal *, integer *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DPPTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Invert the triangular Cholesky factor U or L. */
dtptri_(uplo, "Non-unit", n, &ap[1], info);
if (*info > 0)
{
return 0;
}
if (upper)
{
/* Compute the product inv(U) * inv(U)**T. */
jj = 0;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
jc = jj + 1;
jj += j;
if (j > 1)
{
i__2 = j - 1;
dspr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]);
}
ajj = ap[jj];
dscal_(&j, &ajj, &ap[jc], &c__1);
/* L10: */
}
}
else
{
/* Compute the product inv(L)**T * inv(L). */
jj = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
jjn = jj + *n - j + 1;
i__2 = *n - j + 1;
ap[jj] = ddot_(&i__2, &ap[jj], &c__1, &ap[jj], &c__1);
if (j < *n)
{
i__2 = *n - j;
dtpmv_("Lower", "Transpose", "Non-unit", &i__2, &ap[jjn], &ap[ jj + 1], &c__1);
}
jj = jjn;
/* L20: */
}
}
return 0;
/* End of DPPTRI */
}
/* Subroutine */ int dgbtrf_(integer *m, integer *n, integer *kl, integer *ku,
doublereal *ab, integer *ldab, integer *ipiv, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1;
/* Local variables */
integer i__, j, i2, i3, j2, j3, k2, jb, nb, ii, jj, jm, ip, jp, km, ju,
kv, nw;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
doublereal temp;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemm_(char *, char *, integer *, integer *, integer *
, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dcopy_(
integer *, doublereal *, integer *, doublereal *, integer *),
dswap_(integer *, doublereal *, integer *, doublereal *, integer *
);
doublereal work13[4160] /* was [65][64] */, work31[4160] /*
was [65][64] */;
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *), dgbtf2_(
integer *, integer *, integer *, integer *, doublereal *, integer
*, integer *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *,
integer *, integer *, integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGBTRF computes an LU factorization of a real m-by-n band matrix A */
/* using partial pivoting with row interchanges. */
/* This is the blocked version of the algorithm, calling Level 3 BLAS. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) */
/* On entry, the matrix A in band storage, in rows KL+1 to */
/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
/* The j-th column of A is stored in the j-th column of the */
/* array AB as follows: */
/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
/* On exit, details of the factorization: U is stored as an */
/* upper triangular band matrix with KL+KU superdiagonals in */
/* rows 1 to KL+KU+1, and the multipliers used during the */
/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
/* See below for further details. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used */
/* to solve a system of equations. */
/* Further Details */
/* =============== */
/* The band storage scheme is illustrated by the following example, when */
/* M = N = 6, KL = 2, KU = 1: */
/* On entry: On exit: */
/* * * * + + + * * * u14 u25 u36 */
/* * * + + + + * * u13 u24 u35 u46 */
/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
/* Array elements marked * are not used by the routine; elements marked */
/* + need not be set on entry, but are required by the routine to store */
/* elements of U because of fill-in resulting from the row interchanges. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* KV is the number of superdiagonals in the factor U, allowing for */
/* fill-in */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
/* Function Body */
kv = *ku + *kl;
/* Test the input parameters. */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*ldab < *kl + kv + 1) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGBTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Determine the block size for this environment */
nb = ilaenv_(&c__1, "DGBTRF", " ", m, n, kl, ku);
/* The block size must not exceed the limit set by the size of the */
/* local arrays WORK13 and WORK31. */
nb = min(nb,64);
if (nb <= 1 || nb > *kl) {
/* Use unblocked code */
dgbtf2_(m, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info);
} else {
/* Use blocked code */
/* Zero the superdiagonal elements of the work array WORK13 */
i__1 = nb;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work13[i__ + j * 65 - 66] = 0.;
/* L10: */
}
/* L20: */
}
/* Zero the subdiagonal elements of the work array WORK31 */
i__1 = nb;
for (j = 1; j <= i__1; ++j) {
i__2 = nb;
for (i__ = j + 1; i__ <= i__2; ++i__) {
work31[i__ + j * 65 - 66] = 0.;
/* L30: */
}
/* L40: */
}
/* Gaussian elimination with partial pivoting */
/* Set fill-in elements in columns KU+2 to KV to zero */
i__1 = min(kv,*n);
for (j = *ku + 2; j <= i__1; ++j) {
i__2 = *kl;
for (i__ = kv - j + 2; i__ <= i__2; ++i__) {
ab[i__ + j * ab_dim1] = 0.;
/* L50: */
}
/* L60: */
}
/* JU is the index of the last column affected by the current */
/* stage of the factorization */
ju = 1;
i__1 = min(*m,*n);
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = min(*m,*n) - j + 1;
jb = min(i__3,i__4);
/* The active part of the matrix is partitioned */
/* A11 A12 A13 */
/* A21 A22 A23 */
/* A31 A32 A33 */
/* Here A11, A21 and A31 denote the current block of JB columns */
/* which is about to be factorized. The number of rows in the */
/* partitioning are JB, I2, I3 respectively, and the numbers */
/* of columns are JB, J2, J3. The superdiagonal elements of A13 */
/* and the subdiagonal elements of A31 lie outside the band. */
/* Computing MIN */
i__3 = *kl - jb, i__4 = *m - j - jb + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = jb, i__4 = *m - j - *kl + 1;
i3 = min(i__3,i__4);
/* J2 and J3 are computed after JU has been updated. */
/* Factorize the current block of JB columns */
i__3 = j + jb - 1;
for (jj = j; jj <= i__3; ++jj) {
/* Set fill-in elements in column JJ+KV to zero */
if (jj + kv <= *n) {
i__4 = *kl;
for (i__ = 1; i__ <= i__4; ++i__) {
ab[i__ + (jj + kv) * ab_dim1] = 0.;
/* L70: */
}
}
/* Find pivot and test for singularity. KM is the number of */
/* subdiagonal elements in the current column. */
/* Computing MIN */
i__4 = *kl, i__5 = *m - jj;
km = min(i__4,i__5);
i__4 = km + 1;
jp = idamax_(&i__4, &ab[kv + 1 + jj * ab_dim1], &c__1);
ipiv[jj] = jp + jj - j;
if (ab[kv + jp + jj * ab_dim1] != 0.) {
/* Computing MAX */
/* Computing MIN */
i__6 = jj + *ku + jp - 1;
i__4 = ju, i__5 = min(i__6,*n);
ju = max(i__4,i__5);
if (jp != 1) {
/* Apply interchange to columns J to J+JB-1 */
if (jp + jj - 1 < j + *kl) {
i__4 = *ldab - 1;
i__5 = *ldab - 1;
dswap_(&jb, &ab[kv + 1 + jj - j + j * ab_dim1], &
i__4, &ab[kv + jp + jj - j + j * ab_dim1],
&i__5);
} else {
/* The interchange affects columns J to JJ-1 of A31 */
/* which are stored in the work array WORK31 */
i__4 = jj - j;
i__5 = *ldab - 1;
dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1],
&i__5, &work31[jp + jj - j - *kl - 1], &
c__65);
i__4 = j + jb - jj;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
dswap_(&i__4, &ab[kv + 1 + jj * ab_dim1], &i__5, &
ab[kv + jp + jj * ab_dim1], &i__6);
}
}
/* Compute multipliers */
d__1 = 1. / ab[kv + 1 + jj * ab_dim1];
dscal_(&km, &d__1, &ab[kv + 2 + jj * ab_dim1], &c__1);
/* Update trailing submatrix within the band and within */
/* the current block. JM is the index of the last column */
/* which needs to be updated. */
/* Computing MIN */
i__4 = ju, i__5 = j + jb - 1;
jm = min(i__4,i__5);
if (jm > jj) {
i__4 = jm - jj;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
dger_(&km, &i__4, &c_b18, &ab[kv + 2 + jj * ab_dim1],
&c__1, &ab[kv + (jj + 1) * ab_dim1], &i__5, &
ab[kv + 1 + (jj + 1) * ab_dim1], &i__6);
}
} else {
/* If pivot is zero, set INFO to the index of the pivot */
/* unless a zero pivot has already been found. */
if (*info == 0) {
*info = jj;
}
}
/* Copy current column of A31 into the work array WORK31 */
/* Computing MIN */
i__4 = jj - j + 1;
nw = min(i__4,i3);
if (nw > 0) {
dcopy_(&nw, &ab[kv + *kl + 1 - jj + j + jj * ab_dim1], &
c__1, &work31[(jj - j + 1) * 65 - 65], &c__1);
}
/* L80: */
}
if (j + jb <= *n) {
/* Apply the row interchanges to the other blocks. */
/* Computing MIN */
i__3 = ju - j + 1;
j2 = min(i__3,kv) - jb;
/* Computing MAX */
i__3 = 0, i__4 = ju - j - kv + 1;
j3 = max(i__3,i__4);
/* Use DLASWP to apply the row interchanges to A12, A22, and */
/* A32. */
i__3 = *ldab - 1;
dlaswp_(&j2, &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__3, &
c__1, &jb, &ipiv[j], &c__1);
/* Adjust the pivot indices. */
i__3 = j + jb - 1;
for (i__ = j; i__ <= i__3; ++i__) {
ipiv[i__] = ipiv[i__] + j - 1;
/* L90: */
}
/* Apply the row interchanges to A13, A23, and A33 */
/* columnwise. */
k2 = j - 1 + jb + j2;
i__3 = j3;
for (i__ = 1; i__ <= i__3; ++i__) {
jj = k2 + i__;
i__4 = j + jb - 1;
for (ii = j + i__ - 1; ii <= i__4; ++ii) {
ip = ipiv[ii];
if (ip != ii) {
temp = ab[kv + 1 + ii - jj + jj * ab_dim1];
ab[kv + 1 + ii - jj + jj * ab_dim1] = ab[kv + 1 +
ip - jj + jj * ab_dim1];
ab[kv + 1 + ip - jj + jj * ab_dim1] = temp;
}
/* L100: */
}
/* L110: */
}
/* Update the relevant part of the trailing submatrix */
if (j2 > 0) {
/* Update A12 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j2,
&c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, &ab[kv
+ 1 - jb + (j + jb) * ab_dim1], &i__4);
if (i2 > 0) {
/* Update A22 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
i__5 = *ldab - 1;
dgemm_("No transpose", "No transpose", &i2, &j2, &jb,
&c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
&ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__4,
&c_b31, &ab[kv + 1 + (j + jb) * ab_dim1], &
i__5);
}
if (i3 > 0) {
/* Update A32 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dgemm_("No transpose", "No transpose", &i3, &j2, &jb,
&c_b18, work31, &c__65, &ab[kv + 1 - jb + (j
+ jb) * ab_dim1], &i__3, &c_b31, &ab[kv + *kl
+ 1 - jb + (j + jb) * ab_dim1], &i__4);
}
}
if (j3 > 0) {
/* Copy the lower triangle of A13 into the work array */
/* WORK13 */
i__3 = j3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = jb;
for (ii = jj; ii <= i__4; ++ii) {
work13[ii + jj * 65 - 66] = ab[ii - jj + 1 + (jj
+ j + kv - 1) * ab_dim1];
/* L120: */
}
/* L130: */
}
/* Update A13 in the work array */
i__3 = *ldab - 1;
dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j3,
&c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, work13,
&c__65);
if (i2 > 0) {
/* Update A23 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
dgemm_("No transpose", "No transpose", &i2, &j3, &jb,
&c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
work13, &c__65, &c_b31, &ab[jb + 1 + (j + kv)
* ab_dim1], &i__4);
}
if (i3 > 0) {
/* Update A33 */
i__3 = *ldab - 1;
dgemm_("No transpose", "No transpose", &i3, &j3, &jb,
&c_b18, work31, &c__65, work13, &c__65, &
c_b31, &ab[*kl + 1 + (j + kv) * ab_dim1], &
i__3);
}
/* Copy the lower triangle of A13 back into place */
i__3 = j3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = jb;
for (ii = jj; ii <= i__4; ++ii) {
ab[ii - jj + 1 + (jj + j + kv - 1) * ab_dim1] =
work13[ii + jj * 65 - 66];
/* L140: */
}
/* L150: */
}
}
} else {
/* Adjust the pivot indices. */
i__3 = j + jb - 1;
for (i__ = j; i__ <= i__3; ++i__) {
ipiv[i__] = ipiv[i__] + j - 1;
/* L160: */
}
}
/* Partially undo the interchanges in the current block to */
/* restore the upper triangular form of A31 and copy the upper */
/* triangle of A31 back into place */
i__3 = j;
for (jj = j + jb - 1; jj >= i__3; --jj) {
jp = ipiv[jj] - jj + 1;
if (jp != 1) {
/* Apply interchange to columns J to JJ-1 */
if (jp + jj - 1 < j + *kl) {
/* The interchange does not affect A31 */
i__4 = jj - j;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
i__5, &ab[kv + jp + jj - j + j * ab_dim1], &
i__6);
} else {
/* The interchange does affect A31 */
i__4 = jj - j;
i__5 = *ldab - 1;
dswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
i__5, &work31[jp + jj - j - *kl - 1], &c__65);
}
}
/* Copy the current column of A31 back into place */
/* Computing MIN */
i__4 = i3, i__5 = jj - j + 1;
nw = min(i__4,i__5);
if (nw > 0) {
dcopy_(&nw, &work31[(jj - j + 1) * 65 - 65], &c__1, &ab[
kv + *kl + 1 - jj + j + jj * ab_dim1], &c__1);
}
/* L170: */
}
/* L180: */
}
}
return 0;
/* End of DGBTRF */
} /* dgbtrf_ */
/* Subroutine */ int dsytf2_(char *uplo, integer *n, doublereal *a, integer *
lda, integer *ipiv, integer *info)
{
/* -- LAPACK routine (version 3.1) --
Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
November 2006
Purpose
=======
DSYTF2 computes the factorization of a real symmetric matrix A using
the Bunch-Kaufman diagonal pivoting method:
A = U*D*U' or A = L*D*L'
where U (or L) is a product of permutation and unit upper (lower)
triangular matrices, U' is the transpose of U, and D is symmetric and
block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
This is the unblocked version of the algorithm, calling Level 2 BLAS.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
symmetric matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the symmetric matrix A. If UPLO = 'U', the leading
n-by-n upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n-by-n lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, the block diagonal matrix D and the multipliers used
to obtain the factor U or L (see below for further details).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
IPIV (output) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D.
If IPIV(k) > 0, then rows and columns k and IPIV(k) were
interchanged and D(k,k) is a 1-by-1 diagonal block.
If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
> 0: if INFO = k, D(k,k) is exactly zero. The factorization
has been completed, but the block diagonal matrix D is
exactly singular, and division by zero will occur if it
is used to solve a system of equations.
Further Details
===============
09-29-06 - patch from
Bobby Cheng, MathWorks
Replace l.204 and l.372
IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
by
IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
01-01-96 - Based on modifications by
J. Lewis, Boeing Computer Services Company
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
1-96 - Based on modifications by J. Lewis, Boeing Computer Services
Company
If UPLO = 'U', then A = U*D*U', where
U = P(n)*U(n)* ... *P(k)U(k)* ...,
i.e., U is a product of terms P(k)*U(k), where k decreases from n to
1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
that if the diagonal block D(k) is of order s (s = 1 or 2), then
( I v 0 ) k-s
U(k) = ( 0 I 0 ) s
( 0 0 I ) n-k
k-s s n-k
If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
and A(k,k), and v overwrites A(1:k-2,k-1:k).
If UPLO = 'L', then A = L*D*L', where
L = P(1)*L(1)* ... *P(k)*L(k)* ...,
i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
that if the diagonal block D(k) is of order s (s = 1 or 2), then
( I 0 0 ) k-1
L(k) = ( 0 I 0 ) s
( 0 v I ) n-k-s+1
k-1 s n-k-s+1
If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static const integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
_THREAD_STATIC_ integer i__, j, k;
_THREAD_STATIC_ doublereal t, r1, d11, d12, d21, d22;
_THREAD_STATIC_ integer kk, kp;
_THREAD_STATIC_ doublereal wk, wkm1, wkp1;
_THREAD_STATIC_ integer imax, jmax;
extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
_THREAD_STATIC_ doublereal alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
_THREAD_STATIC_ integer kstep;
_THREAD_STATIC_ logical upper;
_THREAD_STATIC_ doublereal absakk;
extern integer idamax_(integer *, doublereal *, integer *);
extern logical disnan_(doublereal *);
extern /* Subroutine */ int xerbla_(char *, integer *);
_THREAD_STATIC_ doublereal colmax, rowmax;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYTF2", &i__1);
return 0;
}
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.) + 1.) / 8.;
if (upper) {
/* Factorize A as U*D*U' using the upper triangle of A
K is the main loop index, decreasing from N to 1 in steps of
1 or 2 */
k = *n;
L10:
/* If K < 1, exit from loop */
if (k < 1) {
goto L70;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether
a 1-by-1 or 2-by-2 pivot block will be used */
absakk = (d__1 = a[k + k * a_dim1], abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in
column K, and COLMAX is its absolute value */
if (k > 1) {
i__1 = k - 1;
imax = idamax_(&i__1, &a[k * a_dim1 + 1], &c__1);
colmax = (d__1 = a[imax + k * a_dim1], abs(d__1));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0. || disnan_(&absakk)) {
/* Column K is zero or contains a NaN: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* JMAX is the column-index of the largest off-diagonal
element in row IMAX, and ROWMAX is its absolute value */
i__1 = k - imax;
jmax = imax + idamax_(&i__1, &a[imax + (imax + 1) * a_dim1],
lda);
rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1));
if (imax > 1) {
i__1 = imax - 1;
jmax = idamax_(&i__1, &a[imax * a_dim1 + 1], &c__1);
/* Computing MAX */
d__2 = rowmax, d__3 = (d__1 = a[jmax + imax * a_dim1],
abs(d__1));
rowmax = max(d__2,d__3);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else if ((d__1 = a[imax + imax * a_dim1], abs(d__1)) >=
alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1
pivot block */
kp = imax;
} else {
/* interchange rows and columns K-1 and IMAX, use 2-by-2
pivot block */
kp = imax;
kstep = 2;
}
}
kk = k - kstep + 1;
if (kp != kk) {
/* Interchange rows and columns KK and KP in the leading
submatrix A(1:k,1:k) */
i__1 = kp - 1;
dswap_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1],
&c__1);
i__1 = kk - kp - 1;
dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp +
1) * a_dim1], lda);
t = a[kk + kk * a_dim1];
a[kk + kk * a_dim1] = a[kp + kp * a_dim1];
a[kp + kp * a_dim1] = t;
if (kstep == 2) {
t = a[k - 1 + k * a_dim1];
a[k - 1 + k * a_dim1] = a[kp + k * a_dim1];
a[kp + k * a_dim1] = t;
}
}
/* Update the leading submatrix */
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds
W(k) = U(k)*D(k)
where U(k) is the k-th column of U
Perform a rank-1 update of A(1:k-1,1:k-1) as
A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
r1 = 1. / a[k + k * a_dim1];
i__1 = k - 1;
d__1 = -r1;
dsyr_(uplo, &i__1, &d__1, &a[k * a_dim1 + 1], &c__1, &a[
a_offset], lda);
/* Store U(k) in column k */
i__1 = k - 1;
dscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
} else {
/* 2-by-2 pivot block D(k): columns k and k-1 now hold
( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
where U(k) and U(k-1) are the k-th and (k-1)-th columns
of U
Perform a rank-2 update of A(1:k-2,1:k-2) as
A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
= A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
if (k > 2) {
d12 = a[k - 1 + k * a_dim1];
d22 = a[k - 1 + (k - 1) * a_dim1] / d12;
d11 = a[k + k * a_dim1] / d12;
t = 1. / (d11 * d22 - 1.);
d12 = t / d12;
for (j = k - 2; j >= 1; --j) {
wkm1 = d12 * (d11 * a[j + (k - 1) * a_dim1] - a[j + k
* a_dim1]);
wk = d12 * (d22 * a[j + k * a_dim1] - a[j + (k - 1) *
a_dim1]);
for (i__ = j; i__ >= 1; --i__) {
a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__
+ k * a_dim1] * wk - a[i__ + (k - 1) *
a_dim1] * wkm1;
/* L20: */
}
a[j + k * a_dim1] = wk;
a[j + (k - 1) * a_dim1] = wkm1;
/* L30: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
/* Decrease K and return to the start of the main loop */
k -= kstep;
goto L10;
} else {
/* Factorize A as L*D*L' using the lower triangle of A
K is the main loop index, increasing from 1 to N in steps of
1 or 2 */
k = 1;
L40:
/* If K > N, exit from loop */
if (k > *n) {
goto L70;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether
a 1-by-1 or 2-by-2 pivot block will be used */
absakk = (d__1 = a[k + k * a_dim1], abs(d__1));
/* IMAX is the row-index of the largest off-diagonal element in
column K, and COLMAX is its absolute value */
if (k < *n) {
i__1 = *n - k;
imax = k + idamax_(&i__1, &a[k + 1 + k * a_dim1], &c__1);
colmax = (d__1 = a[imax + k * a_dim1], abs(d__1));
} else {
colmax = 0.;
}
if (max(absakk,colmax) == 0. || disnan_(&absakk)) {
/* Column K is zero or contains a NaN: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* JMAX is the column-index of the largest off-diagonal
element in row IMAX, and ROWMAX is its absolute value */
i__1 = imax - k;
jmax = k - 1 + idamax_(&i__1, &a[imax + k * a_dim1], lda);
rowmax = (d__1 = a[imax + jmax * a_dim1], abs(d__1));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + idamax_(&i__1, &a[imax + 1 + imax * a_dim1],
&c__1);
/* Computing MAX */
d__2 = rowmax, d__3 = (d__1 = a[jmax + imax * a_dim1],
abs(d__1));
rowmax = max(d__2,d__3);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else if ((d__1 = a[imax + imax * a_dim1], abs(d__1)) >=
alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1
pivot block */
kp = imax;
} else {
/* interchange rows and columns K+1 and IMAX, use 2-by-2
pivot block */
kp = imax;
kstep = 2;
}
}
kk = k + kstep - 1;
if (kp != kk) {
/* Interchange rows and columns KK and KP in the trailing
submatrix A(k:n,k:n) */
if (kp < *n) {
i__1 = *n - kp;
dswap_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1
+ kp * a_dim1], &c__1);
}
i__1 = kp - kk - 1;
dswap_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk +
1) * a_dim1], lda);
t = a[kk + kk * a_dim1];
a[kk + kk * a_dim1] = a[kp + kp * a_dim1];
a[kp + kp * a_dim1] = t;
if (kstep == 2) {
t = a[k + 1 + k * a_dim1];
a[k + 1 + k * a_dim1] = a[kp + k * a_dim1];
a[kp + k * a_dim1] = t;
}
}
/* Update the trailing submatrix */
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds
W(k) = L(k)*D(k)
where L(k) is the k-th column of L */
if (k < *n) {
/* Perform a rank-1 update of A(k+1:n,k+1:n) as
A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
d11 = 1. / a[k + k * a_dim1];
i__1 = *n - k;
d__1 = -d11;
dsyr_(uplo, &i__1, &d__1, &a[k + 1 + k * a_dim1], &c__1, &
a[k + 1 + (k + 1) * a_dim1], lda);
/* Store L(k) in column K */
i__1 = *n - k;
dscal_(&i__1, &d11, &a[k + 1 + k * a_dim1], &c__1);
}
} else {
/* 2-by-2 pivot block D(k) */
if (k < *n - 1) {
/* Perform a rank-2 update of A(k+2:n,k+2:n) as
A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))'
where L(k) and L(k+1) are the k-th and (k+1)-th
columns of L */
d21 = a[k + 1 + k * a_dim1];
d11 = a[k + 1 + (k + 1) * a_dim1] / d21;
d22 = a[k + k * a_dim1] / d21;
t = 1. / (d11 * d22 - 1.);
d21 = t / d21;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
wk = d21 * (d11 * a[j + k * a_dim1] - a[j + (k + 1) *
a_dim1]);
wkp1 = d21 * (d22 * a[j + (k + 1) * a_dim1] - a[j + k
* a_dim1]);
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
a[i__ + j * a_dim1] = a[i__ + j * a_dim1] - a[i__
+ k * a_dim1] * wk - a[i__ + (k + 1) *
a_dim1] * wkp1;
/* L50: */
}
a[j + k * a_dim1] = wk;
a[j + (k + 1) * a_dim1] = wkp1;
/* L60: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
/* Increase K and return to the start of the main loop */
k += kstep;
goto L40;
}
L70:
return 0;
/* End of DSYTF2 */
} /* dsytf2_ */
/* Subroutine */ int dtrti2_(char *uplo, char *diag, integer *n, doublereal *
a, integer *lda, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
integer j;
doublereal ajj;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
logical upper;
extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *,
doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
logical nounit;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DTRTI2 computes the inverse of a real upper or lower triangular */
/* matrix. */
/* This is the Level 2 BLAS version of the algorithm. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the triangular matrix A. If UPLO = 'U', the */
/* leading n by n upper triangular part of the array A contains */
/* the upper triangular matrix, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of the array A contains */
/* the lower triangular matrix, and the strictly upper */
/* triangular part of A is not referenced. If DIAG = 'U', the */
/* diagonal elements of A are also not referenced and are */
/* assumed to be 1. */
/* On exit, the (triangular) inverse of the original matrix, in */
/* the same storage format. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTRTI2", &i__1);
return 0;
}
if (upper) {
/* Compute inverse of upper triangular matrix. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (nounit) {
a[j + j * a_dim1] = 1. / a[j + j * a_dim1];
ajj = -a[j + j * a_dim1];
} else {
ajj = -1.;
}
/* Compute elements 1:j-1 of j-th column. */
i__2 = j - 1;
dtrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, &
a[j * a_dim1 + 1], &c__1);
i__2 = j - 1;
dscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1);
/* L10: */
}
} else {
/* Compute inverse of lower triangular matrix. */
for (j = *n; j >= 1; --j) {
if (nounit) {
a[j + j * a_dim1] = 1. / a[j + j * a_dim1];
ajj = -a[j + j * a_dim1];
} else {
ajj = -1.;
}
if (j < *n) {
/* Compute elements j+1:n of j-th column. */
i__1 = *n - j;
dtrmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j +
1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1);
i__1 = *n - j;
dscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* End of DTRTI2 */
} /* dtrti2_ */
/* Subroutine */ int dgebak_(char *job, char *side, integer *n, integer *ilo,
integer *ihi, doublereal *scale, integer *m, doublereal *v, integer *
ldv, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
DGEBAK forms the right or left eigenvectors of a real general matrix
by backward transformation on the computed eigenvectors of the
balanced matrix output by DGEBAL.
Arguments
=========
JOB (input) CHARACTER*1
Specifies the type of backward transformation required:
= 'N', do nothing, return immediately;
= 'P', do backward transformation for permutation only;
= 'S', do backward transformation for scaling only;
= 'B', do backward transformations for both permutation and
scaling.
JOB must be the same as the argument JOB supplied to DGEBAL.
SIDE (input) CHARACTER*1
= 'R': V contains right eigenvectors;
= 'L': V contains left eigenvectors.
N (input) INTEGER
The number of rows of the matrix V. N >= 0.
ILO (input) INTEGER
IHI (input) INTEGER
The integers ILO and IHI determined by DGEBAL.
1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
SCALE (input) DOUBLE PRECISION array, dimension (N)
Details of the permutation and scaling factors, as returned
by DGEBAL.
M (input) INTEGER
The number of columns of the matrix V. M >= 0.
V (input/output) DOUBLE PRECISION array, dimension (LDV,M)
On entry, the matrix of right or left eigenvectors to be
transformed, as returned by DHSEIN or DTREVC.
On exit, V is overwritten by the transformed eigenvectors.
LDV (input) INTEGER
The leading dimension of the array V. LDV >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Decode and Test the input parameters
Parameter adjustments */
/* System generated locals */
integer v_dim1, v_offset, i__1;
/* Local variables */
static integer i__, k;
static doublereal s;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *);
static logical leftv;
static integer ii;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical rightv;
#define v_ref(a_1,a_2) v[(a_2)*v_dim1 + a_1]
--scale;
v_dim1 = *ldv;
v_offset = 1 + v_dim1 * 1;
v -= v_offset;
/* Function Body */
rightv = lsame_(side, "R");
leftv = lsame_(side, "L");
*info = 0;
if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S")
&& ! lsame_(job, "B")) {
*info = -1;
} else if (! rightv && ! leftv) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ilo < 1 || *ilo > max(1,*n)) {
*info = -4;
} else if (*ihi < min(*ilo,*n) || *ihi > *n) {
*info = -5;
} else if (*m < 0) {
*info = -7;
} else if (*ldv < max(1,*n)) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DGEBAK", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*m == 0) {
return 0;
}
if (lsame_(job, "N")) {
return 0;
}
if (*ilo == *ihi) {
goto L30;
}
/* Backward balance */
if (lsame_(job, "S") || lsame_(job, "B")) {
if (rightv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
s = scale[i__];
dscal_(m, &s, &v_ref(i__, 1), ldv);
/* L10: */
}
}
if (leftv) {
i__1 = *ihi;
for (i__ = *ilo; i__ <= i__1; ++i__) {
s = 1. / scale[i__];
dscal_(m, &s, &v_ref(i__, 1), ldv);
/* L20: */
}
}
}
/* Backward permutation
For I = ILO-1 step -1 until 1,
IHI+1 step 1 until N do -- */
L30:
if (lsame_(job, "P") || lsame_(job, "B")) {
if (rightv) {
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = ii;
if (i__ >= *ilo && i__ <= *ihi) {
goto L40;
}
if (i__ < *ilo) {
i__ = *ilo - ii;
}
k = (integer) scale[i__];
if (k == i__) {
goto L40;
}
dswap_(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv);
L40:
;
}
}
if (leftv) {
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = ii;
if (i__ >= *ilo && i__ <= *ihi) {
goto L50;
}
if (i__ < *ilo) {
i__ = *ilo - ii;
}
k = (integer) scale[i__];
if (k == i__) {
goto L50;
}
dswap_(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv);
L50:
;
}
}
}
return 0;
/* End of DGEBAK */
} /* dgebak_ */
void dscal( int N, double alpha, double *a, int inca ){
dscal_( &N, &alpha, a, &inca );
};
/* Subroutine */ int dgesc2_(integer *n, doublereal *a, integer *lda,
doublereal *rhs, integer *ipiv, integer *jpiv, doublereal *scale)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
integer i__, j;
doublereal eps, temp;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *);
extern integer idamax_(integer *, doublereal *, integer *);
doublereal bignum;
extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *,
integer *, integer *, integer *, integer *);
doublereal smlnum;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGESC2 solves a system of linear equations */
/* A * X = scale* RHS */
/* with a general N-by-N matrix A using the LU factorization with */
/* complete pivoting computed by DGETC2. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the LU part of the factorization of the n-by-n */
/* matrix A computed by DGETC2: A = P * L * U * Q */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1, N). */
/* RHS (input/output) DOUBLE PRECISION array, dimension (N). */
/* On entry, the right hand side vector b. */
/* On exit, the solution vector X. */
/* IPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= i <= N, row i of the */
/* matrix has been interchanged with row IPIV(i). */
/* JPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= j <= N, column j of the */
/* matrix has been interchanged with column JPIV(j). */
/* SCALE (output) DOUBLE PRECISION */
/* On exit, SCALE contains the scale factor. SCALE is chosen */
/* 0 <= SCALE <= 1 to prevent owerflow in the solution. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Set constant to control owerflow */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--rhs;
--ipiv;
--jpiv;
/* Function Body */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Apply permutations IPIV to RHS */
i__1 = *n - 1;
dlaswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &ipiv[1], &c__1);
/* Solve for L part */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
rhs[j] -= a[j + i__ * a_dim1] * rhs[i__];
/* L10: */
}
/* L20: */
}
/* Solve for U part */
*scale = 1.;
/* Check for scaling */
i__ = idamax_(n, &rhs[1], &c__1);
if (smlnum * 2. * (d__1 = rhs[i__], abs(d__1)) > (d__2 = a[*n + *n *
a_dim1], abs(d__2))) {
temp = .5 / (d__1 = rhs[i__], abs(d__1));
dscal_(n, &temp, &rhs[1], &c__1);
*scale *= temp;
}
for (i__ = *n; i__ >= 1; --i__) {
temp = 1. / a[i__ + i__ * a_dim1];
rhs[i__] *= temp;
i__1 = *n;
for (j = i__ + 1; j <= i__1; ++j) {
rhs[i__] -= rhs[j] * (a[i__ + j * a_dim1] * temp);
/* L30: */
}
/* L40: */
}
/* Apply permutations JPIV to the solution (RHS) */
i__1 = *n - 1;
dlaswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &jpiv[1], &c_n1);
return 0;
/* End of DGESC2 */
} /* dgesc2_ */
/* Ref: Weiss, Algorithm 12 BiCGSTAB
* INPUT
* n : dimension of the problem
* b [n] : r-h-s vector
* atimes (int n, static double *x, double *b, void *param) :
* calc matrix-vector product A.x = b.
* atimes_param : parameters for atimes().
* it : struct iter. following entries are used
* it->max = kend : max of iteration
* it->eps = eps : criteria for |r^2|/|b^2|
* OUTPUT
* returned value : 0 == success, otherwise (-1) == failed
* x [n] : solution
* it->niter : # of iteration
* it->res2 : |r^2| / |b^2|
*/
int
bicgstab (int n, const double *b, double *x,
void (*atimes) (int, const double *, double *, void *),
void *atimes_param,
struct iter *it)
{
#ifndef HAVE_CBLAS_H
# ifdef HAVE_BLAS_H
/* use Fortran BLAS routines */
int i_1 = 1;
double d_1 = 1.0;
double d_m1 = -1.0;
# endif // !HAVE_BLAS_H
#endif // !HAVE_CBLAS_H
int ret = -1;
double eps2 = it->eps * it->eps;
int itmax = it->max;
double *r = (double *)malloc (sizeof (double) * n);
double *rs = (double *)malloc (sizeof (double) * n);
double *p = (double *)malloc (sizeof (double) * n);
double *ap = (double *)malloc (sizeof (double) * n);
double *s = (double *)malloc (sizeof (double) * n);
double *t = (double *)malloc (sizeof (double) * n);
CHECK_MALLOC (r, "bicgstab");
CHECK_MALLOC (rs, "bicgstab");
CHECK_MALLOC (p, "bicgstab");
CHECK_MALLOC (ap, "bicgstab");
CHECK_MALLOC (s, "bicgstab");
CHECK_MALLOC (t, "bicgstab");
double rsap; // (r*, A.p)
double st;
double t2;
double rho, rho1;
double delta;
double gamma;
double beta;
double res2 = 0.0;
#ifdef HAVE_CBLAS_H
/**
* ATLAS version
*/
double b2 = cblas_ddot (n, b, 1, b, 1); // (b,b)
eps2 *= b2;
atimes (n, x, r, atimes_param); // r = A.x ...
cblas_daxpy (n, -1.0, b, 1, r, 1); // - b
cblas_dcopy (n, r, 1, rs, 1); // r* = r
cblas_dcopy (n, r, 1, p, 1); // p = r
rho = cblas_ddot (n, rs, 1, r, 1); // rho = (r*, r)
int i;
for (i = 0; i < itmax; i ++)
{
atimes (n, p, ap, atimes_param); // ap = A.p
rsap = cblas_ddot (n, rs, 1, ap, 1); // rsap = (r*, A.p)
delta = - rho / rsap;
cblas_dcopy (n, r, 1, s, 1); // s = r ...
cblas_daxpy (n, delta, ap, 1, s, 1); // + delta A.p
atimes (n, s, t, atimes_param); // t = A.s
st = cblas_ddot (n, s, 1, t, 1); // st = (s, t)
t2 = cblas_ddot (n, t, 1, t, 1); // t2 = (t, t)
gamma = - st / t2;
cblas_dcopy (n, s, 1, r, 1); // r = s ...
cblas_daxpy (n, gamma, t, 1, r, 1); // + gamma t
cblas_daxpy (n, delta, p, 1, x, 1); // x = x + delta p...
cblas_daxpy (n, gamma, s, 1, x, 1); // + gamma s
res2 = cblas_ddot (n, r, 1, r, 1);
if (it->debug == 2)
{
fprintf (it->out,
"libiter-bicgstab(cblas) %d %e\n",
i, res2 / b2);
}
if (res2 <= eps2)
{
ret = 0; // success
break;
}
rho1 = cblas_ddot (n, rs, 1, r, 1); // rho = (r*, r)
beta = rho1 / rho * delta / gamma;
rho = rho1;
cblas_daxpy (n, gamma, ap, 1, p, 1); // p = p + gamma A.p
cblas_dscal (n, beta, p, 1); // p = beta (p + gamma A.p)
cblas_daxpy (n, 1.0, r, 1, p, 1); // p = r + beta(p + gamma A.p)
}
#else // !HAVE_CBLAS_H
# ifdef HAVE_BLAS_H
/**
* BLAS version
*/
double b2 = ddot_ (&n, b, &i_1, b, &i_1); // (b,b)
eps2 *= b2;
atimes (n, x, r, atimes_param); // r = A.x ...
daxpy_ (&n, &d_m1, b, &i_1, r, &i_1); // - b
dcopy_ (&n, r, &i_1, rs, &i_1); // r* = r
dcopy_ (&n, r, &i_1, p, &i_1); // p = r
rho = ddot_ (&n, rs, &i_1, r, &i_1); // rho = (r*, r)
int i;
for (i = 0; i < itmax; i ++)
{
atimes (n, p, ap, atimes_param); // ap = A.p
rsap = ddot_ (&n, rs, &i_1, ap, &i_1); // rsap = (r*, A.p)
delta = - rho / rsap;
dcopy_ (&n, r, &i_1, s, &i_1); // s = r ...
daxpy_ (&n, &delta, ap, &i_1, s, &i_1); // + delta A.p
atimes (n, s, t, atimes_param); // t = A.s
st = ddot_ (&n, s, &i_1, t, &i_1); // st = (s, t)
t2 = ddot_ (&n, t, &i_1, t, &i_1); // t2 = (t, t)
gamma = - st / t2;
dcopy_ (&n, s, &i_1, r, &i_1); // r = s ...
daxpy_ (&n, &gamma, t, &i_1, r, &i_1); // + gamma t
daxpy_ (&n, &delta, p, &i_1, x, &i_1); // x = x + delta p...
daxpy_ (&n, &gamma, s, &i_1, x, &i_1); // + gamma s
res2 = ddot_ (&n, r, &i_1, r, &i_1);
if (it->debug == 2)
{
fprintf (it->out,
"libiter-bicgstab(blas) %d %e\n",
i, res2 / b2);
}
if (res2 <= eps2)
{
ret = 0; // success
break;
}
if (res2 > 1.0e20)
{
// already too big residual
break;
}
rho1 = ddot_ (&n, rs, &i_1, r, &i_1); // rho = (r*, r)
beta = rho1 / rho * delta / gamma;
rho = rho1;
daxpy_ (&n, &gamma, ap, &i_1, p, &i_1); // p = p + gamma A.p
dscal_ (&n, &beta, p, &i_1); // p = beta (p + gamma A.p)
daxpy_ (&n, &d_1, r, &i_1, p, &i_1); // p = r + beta(p + gamma A.p)
}
# else // !HAVE_BLAS_H
/**
* local BLAS version
*/
double b2 = my_ddot (n, b, 1, b, 1); // (b,b)
eps2 *= b2;
atimes (n, x, r, atimes_param); // r = A.x ...
my_daxpy (n, -1.0, b, 1, r, 1); // - b
my_dcopy (n, r, 1, rs, 1); // r* = r
my_dcopy (n, r, 1, p, 1); // p = r
rho = my_ddot (n, rs, 1, r, 1); // rho = (r*, r)
int i;
for (i = 0; i < itmax; i ++)
{
atimes (n, p, ap, atimes_param); // ap = A.p
rsap = my_ddot (n, rs, 1, ap, 1); // rsap = (r*, A.p)
delta = - rho / rsap;
my_dcopy (n, r, 1, s, 1); // s = r ...
my_daxpy (n, delta, ap, 1, s, 1); // + delta A.p
atimes (n, s, t, atimes_param); // t = A.s
st = my_ddot (n, s, 1, t, 1); // st = (s, t)
t2 = my_ddot (n, t, 1, t, 1); // t2 = (t, t)
gamma = - st / t2;
my_dcopy (n, s, 1, r, 1); // r = s ...
my_daxpy (n, gamma, t, 1, r, 1); // + gamma t
my_daxpy (n, delta, p, 1, x, 1); // x = x + delta p...
my_daxpy (n, gamma, s, 1, x, 1); // + gamma s
res2 = my_ddot (n, r, 1, r, 1);
if (it->debug == 2)
{
fprintf (it->out,
"libiter-bicgstab(myblas) %d %e\n",
i, res2 / b2);
}
if (res2 <= eps2)
{
ret = 0; // success
break;
}
rho1 = my_ddot (n, rs, 1, r, 1); // rho = (r*, r)
beta = rho1 / rho * delta / gamma;
rho = rho1;
my_daxpy (n, gamma, ap, 1, p, 1); // p = p + gamma A.p
my_dscal (n, beta, p, 1); // p = beta (p + gamma A.p)
my_daxpy (n, 1.0, r, 1, p, 1); // p = r + beta(p + gamma A.p)
}
# endif // !HAVE_BLAS_H
#endif // !HAVE_CBLAS_H
free (r);
free (rs);
free (p);
free (ap);
free (s);
free (t);
if (it->debug == 1)
{
fprintf (it->out, "libiter-bicgstab %d %e\n", i, res2 / b2);
}
it->niter = i;
it->res2 = res2 / b2;
return (ret);
}