/* sum |s(:,j)| */
static double
mm_real_sj_asum (const mm_sparse *s, const int j)
{
int p = s->p[j];
int n = s->p[j + 1] - p;
double *sd = s->data;
double asum = dasum_ (&n, sd + p, &ione);
if (mm_real_is_symmetric (s)) {
int k;
int k0;
int k1;
if (mm_real_is_upper (s)) {
k0 = j + 1;
k1 = s->n;
} else {
k0 = 0;
k1 = j;
}
for (k = k0; k < k1; k++) {
int l = find_row_element (j, s, k);
// if found
if (l >= 0) asum += fabs (sd[l]);
}
}
return asum;
}
/* sum |d(:,j)| */
static double
mm_real_dj_asum (const mm_dense *d, const int j)
{
double val = 0.;
if (!mm_real_is_symmetric (d)) val = dasum_ (&d->m, d->data + j * d->m, &ione);
else {
int n;
if (mm_real_is_upper (d)) {
n = j;
val = dasum_ (&n, d->data + j * d->m, &ione);
n = d->m - j;
val += dasum_ (&n, d->data + j * d->m + j, &d->m);
} else if (mm_real_is_lower (d)) {
n = d->m - j;
val = dasum_ (&n, d->data + j * d->m + j, &ione);
n = j;
val += dasum_ (&n, d->data + j, &d->m);
}
}
return val;
}
int toScalarR(int code, KDVEC(x), DVEC(r)) {
REQUIRES(rn==1,BAD_SIZE);
DEBUGMSG("toScalarR");
double res;
integer one = 1;
integer n = xn;
switch(code) {
case 0: { res = dnrm2_(&n,xp,&one); break; }
case 1: { res = dasum_(&n,xp,&one); break; }
case 2: { res = vector_max_index(V(x)); break; }
case 3: { res = vector_max(V(x)); break; }
case 4: { res = vector_min_index(V(x)); break; }
case 5: { res = vector_min(V(x)); break; }
default: ERROR(BAD_CODE);
}
rp[0] = res;
OK
}
/* Subroutine */ int dpbt02_(char *uplo, integer *n, integer *kd, integer *
nrhs, doublereal *a, integer *lda, doublereal *x, integer *ldx,
doublereal *b, integer *ldb, doublereal *rwork, doublereal *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
integer j;
doublereal eps;
extern doublereal dasum_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dsbmv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
doublereal anorm, bnorm, xnorm;
extern doublereal dlamch_(char *), dlansb_(char *, char *,
integer *, integer *, doublereal *, integer *, doublereal *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DPBT02 computes the residual for a solution of a symmetric banded */
/* system of equations A*x = b: */
/* RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS) */
/* where EPS is the machine precision. */
/* 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 number of rows and columns of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of super-diagonals of the matrix A if UPLO = 'U', */
/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The original symmetric band matrix A. If UPLO = 'U', the */
/* upper triangular part of A is stored as a band matrix; if */
/* UPLO = 'L', the lower triangular part of A is stored. The */
/* columns of the appropriate triangle are stored in the columns */
/* of A and the diagonals of the triangle are stored in the rows */
/* of A. See DPBTRF for further details. */
/* LDA (input) INTEGER. */
/* The leading dimension of the array A. LDA >= max(1,KD+1). */
/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* The computed solution vectors for the system of linear */
/* equations. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the right hand side vectors for the system of */
/* linear equations. */
/* On exit, B is overwritten with the difference B - A*X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESID (output) DOUBLE PRECISION */
/* The maximum over the number of right hand sides of */
/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--rwork;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
anorm = dlansb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Compute B - A*X */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dsbmv_(uplo, n, kd, &c_b5, &a[a_offset], lda, &x[j * x_dim1 + 1], &
c__1, &c_b7, &b[j * b_dim1 + 1], &c__1);
/* L10: */
}
/* Compute the maximum over the number of right hand sides of */
/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) */
*resid = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bnorm = dasum_(n, &b[j * b_dim1 + 1], &c__1);
xnorm = dasum_(n, &x[j * x_dim1 + 1], &c__1);
if (xnorm <= 0.) {
*resid = 1. / eps;
} else {
/* Computing MAX */
d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
*resid = max(d__1,d__2);
}
/* L20: */
}
return 0;
/* End of DPBT02 */
} /* dpbt02_ */
/* Subroutine */ int dlaqtr_(logical *ltran, logical *lreal, integer *n,
doublereal *t, integer *ldt, doublereal *b, doublereal *w, doublereal
*scale, doublereal *x, doublereal *work, integer *info)
{
/* System generated locals */
integer t_dim1, t_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
/* Local variables */
doublereal d__[4] /* was [2][2] */;
integer i__, j, k;
doublereal v[4] /* was [2][2] */, z__;
integer j1, j2, n1, n2;
doublereal si, xj, sr, rec, eps, tjj, tmp;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
integer ierr;
doublereal smin, xmax;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern doublereal dasum_(integer *, doublereal *, integer *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
integer jnext;
doublereal sminw, xnorm;
extern /* Subroutine */ int dlaln2_(logical *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *
, doublereal *, integer *, doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern integer idamax_(integer *, doublereal *, integer *);
doublereal scaloc;
extern /* Subroutine */ int dladiv_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
doublereal bignum;
logical notran;
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 */
/* ======= */
/* DLAQTR solves the real quasi-triangular system */
/* op(T)*p = scale*c, if LREAL = .TRUE. */
/* or the complex quasi-triangular systems */
/* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE. */
/* in real arithmetic, where T is upper quasi-triangular. */
/* If LREAL = .FALSE., then the first diagonal block of T must be */
/* 1 by 1, B is the specially structured matrix */
/* B = [ b(1) b(2) ... b(n) ] */
/* [ w ] */
/* [ w ] */
/* [ . ] */
/* [ w ] */
/* op(A) = A or A', A' denotes the conjugate transpose of */
/* matrix A. */
/* On input, X = [ c ]. On output, X = [ p ]. */
/* [ d ] [ q ] */
/* This subroutine is designed for the condition number estimation */
/* in routine DTRSNA. */
/* Arguments */
/* ========= */
/* LTRAN (input) LOGICAL */
/* On entry, LTRAN specifies the option of conjugate transpose: */
/* = .FALSE., op(T+i*B) = T+i*B, */
/* = .TRUE., op(T+i*B) = (T+i*B)'. */
/* LREAL (input) LOGICAL */
/* On entry, LREAL specifies the input matrix structure: */
/* = .FALSE., the input is complex */
/* = .TRUE., the input is real */
/* N (input) INTEGER */
/* On entry, N specifies the order of T+i*B. N >= 0. */
/* T (input) DOUBLE PRECISION array, dimension (LDT,N) */
/* On entry, T contains a matrix in Schur canonical form. */
/* If LREAL = .FALSE., then the first diagonal block of T mu */
/* be 1 by 1. */
/* LDT (input) INTEGER */
/* The leading dimension of the matrix T. LDT >= max(1,N). */
/* B (input) DOUBLE PRECISION array, dimension (N) */
/* On entry, B contains the elements to form the matrix */
/* B as described above. */
/* If LREAL = .TRUE., B is not referenced. */
/* W (input) DOUBLE PRECISION */
/* On entry, W is the diagonal element of the matrix B. */
/* If LREAL = .TRUE., W is not referenced. */
/* SCALE (output) DOUBLE PRECISION */
/* On exit, SCALE is the scale factor. */
/* X (input/output) DOUBLE PRECISION array, dimension (2*N) */
/* On entry, X contains the right hand side of the system. */
/* On exit, X is overwritten by the solution. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* On exit, INFO is set to */
/* 0: successful exit. */
/* 1: the some diagonal 1 by 1 block has been perturbed by */
/* a small number SMIN to keep nonsingularity. */
/* 2: the some diagonal 2 by 2 block has been perturbed by */
/* a small number in DLALN2 to keep nonsingularity. */
/* NOTE: In the interests of speed, this routine does not */
/* check the inputs for errors. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Do not test the input parameters for errors */
/* Parameter adjustments */
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
--b;
--x;
--work;
/* Function Body */
notran = ! (*ltran);
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Set constants to control overflow */
eps = dlamch_("P");
smlnum = dlamch_("S") / eps;
bignum = 1. / smlnum;
xnorm = dlange_("M", n, n, &t[t_offset], ldt, d__);
if (! (*lreal)) {
/* Computing MAX */
d__1 = xnorm, d__2 = abs(*w), d__1 = max(d__1,d__2), d__2 = dlange_(
"M", n, &c__1, &b[1], n, d__);
xnorm = max(d__1,d__2);
}
/* Computing MAX */
d__1 = smlnum, d__2 = eps * xnorm;
smin = max(d__1,d__2);
/* Compute 1-norm of each column of strictly upper triangular */
/* part of T to control overflow in triangular solver. */
work[1] = 0.;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
work[j] = dasum_(&i__2, &t[j * t_dim1 + 1], &c__1);
/* L10: */
}
if (! (*lreal)) {
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
work[i__] += (d__1 = b[i__], abs(d__1));
/* L20: */
}
}
n2 = *n << 1;
n1 = *n;
if (! (*lreal)) {
n1 = n2;
}
k = idamax_(&n1, &x[1], &c__1);
xmax = (d__1 = x[k], abs(d__1));
*scale = 1.;
if (xmax > bignum) {
*scale = bignum / xmax;
dscal_(&n1, scale, &x[1], &c__1);
xmax = bignum;
}
if (*lreal) {
if (notran) {
/* Solve T*p = scale*c */
jnext = *n;
for (j = *n; j >= 1; --j) {
if (j > jnext) {
goto L30;
}
j1 = j;
j2 = j;
jnext = j - 1;
if (j > 1) {
if (t[j + (j - 1) * t_dim1] != 0.) {
j1 = j - 1;
jnext = j - 2;
}
}
if (j1 == j2) {
/* Meet 1 by 1 diagonal block */
/* Scale to avoid overflow when computing */
/* x(j) = b(j)/T(j,j) */
xj = (d__1 = x[j1], abs(d__1));
tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1));
tmp = t[j1 + j1 * t_dim1];
if (tjj < smin) {
tmp = smin;
tjj = smin;
*info = 1;
}
if (xj == 0.) {
goto L30;
}
if (tjj < 1.) {
if (xj > bignum * tjj) {
rec = 1. / xj;
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j1] /= tmp;
xj = (d__1 = x[j1], abs(d__1));
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j1 of T. */
if (xj > 1.) {
rec = 1. / xj;
if (work[j1] > (bignum - xmax) * rec) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
}
if (j1 > 1) {
i__1 = j1 - 1;
d__1 = -x[j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
k = idamax_(&i__1, &x[1], &c__1);
xmax = (d__1 = x[k], abs(d__1));
}
} else {
/* Meet 2 by 2 diagonal block */
/* Call 2 by 2 linear system solve, to take */
/* care of possible overflow by scaling factor. */
d__[0] = x[j1];
d__[1] = x[j2];
dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1
* t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &
c_b25, &c_b25, v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.) {
dscal_(n, &scaloc, &x[1], &c__1);
*scale *= scaloc;
}
x[j1] = v[0];
x[j2] = v[1];
/* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2)) */
/* to avoid overflow in updating right-hand side. */
/* Computing MAX */
d__1 = abs(v[0]), d__2 = abs(v[1]);
xj = max(d__1,d__2);
if (xj > 1.) {
rec = 1. / xj;
/* Computing MAX */
d__1 = work[j1], d__2 = work[j2];
if (max(d__1,d__2) > (bignum - xmax) * rec) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
}
/* Update right-hand side */
if (j1 > 1) {
i__1 = j1 - 1;
d__1 = -x[j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
d__1 = -x[j2];
daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
k = idamax_(&i__1, &x[1], &c__1);
xmax = (d__1 = x[k], abs(d__1));
}
}
L30:
;
}
} else {
/* Solve T'*p = scale*c */
jnext = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < jnext) {
goto L40;
}
j1 = j;
j2 = j;
jnext = j + 1;
if (j < *n) {
if (t[j + 1 + j * t_dim1] != 0.) {
j2 = j + 1;
jnext = j + 2;
}
}
if (j1 == j2) {
/* 1 by 1 diagonal block */
/* Scale if necessary to avoid overflow in forming the */
/* right-hand side element by inner product. */
xj = (d__1 = x[j1], abs(d__1));
if (xmax > 1.) {
rec = 1. / xmax;
if (work[j1] > (bignum - xj) * rec) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
x[j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &
c__1);
xj = (d__1 = x[j1], abs(d__1));
tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1));
tmp = t[j1 + j1 * t_dim1];
if (tjj < smin) {
tmp = smin;
tjj = smin;
*info = 1;
}
if (tjj < 1.) {
if (xj > bignum * tjj) {
rec = 1. / xj;
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j1] /= tmp;
/* Computing MAX */
d__2 = xmax, d__3 = (d__1 = x[j1], abs(d__1));
xmax = max(d__2,d__3);
} else {
/* 2 by 2 diagonal block */
/* Scale if necessary to avoid overflow in forming the */
/* right-hand side elements by inner product. */
/* Computing MAX */
d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2],
abs(d__2));
xj = max(d__3,d__4);
if (xmax > 1.) {
rec = 1. / xmax;
/* Computing MAX */
d__1 = work[j2], d__2 = work[j1];
if (max(d__1,d__2) > (bignum - xj) * rec) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
d__[0] = x[j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1,
&x[1], &c__1);
i__2 = j1 - 1;
d__[1] = x[j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &c__1,
&x[1], &c__1);
dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1 *
t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &c_b25,
&c_b25, v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.) {
dscal_(n, &scaloc, &x[1], &c__1);
*scale *= scaloc;
}
x[j1] = v[0];
x[j2] = v[1];
/* Computing MAX */
d__3 = (d__1 = x[j1], abs(d__1)), d__4 = (d__2 = x[j2],
abs(d__2)), d__3 = max(d__3,d__4);
xmax = max(d__3,xmax);
}
L40:
;
}
}
} else {
/* Computing MAX */
d__1 = eps * abs(*w);
sminw = max(d__1,smin);
if (notran) {
/* Solve (T + iB)*(p+iq) = c+id */
jnext = *n;
for (j = *n; j >= 1; --j) {
if (j > jnext) {
goto L70;
}
j1 = j;
j2 = j;
jnext = j - 1;
if (j > 1) {
if (t[j + (j - 1) * t_dim1] != 0.) {
j1 = j - 1;
jnext = j - 2;
}
}
if (j1 == j2) {
/* 1 by 1 diagonal block */
/* Scale if necessary to avoid overflow in division */
z__ = *w;
if (j1 == 1) {
z__ = b[1];
}
xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs(
d__2));
tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)) + abs(z__);
tmp = t[j1 + j1 * t_dim1];
if (tjj < sminw) {
tmp = sminw;
tjj = sminw;
*info = 1;
}
if (xj == 0.) {
goto L70;
}
if (tjj < 1.) {
if (xj > bignum * tjj) {
rec = 1. / xj;
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
dladiv_(&x[j1], &x[*n + j1], &tmp, &z__, &sr, &si);
x[j1] = sr;
x[*n + j1] = si;
xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1], abs(
d__2));
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j1 of T. */
if (xj > 1.) {
rec = 1. / xj;
if (work[j1] > (bignum - xmax) * rec) {
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
}
}
if (j1 > 1) {
i__1 = j1 - 1;
d__1 = -x[j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
d__1 = -x[*n + j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[*
n + 1], &c__1);
x[1] += b[j1] * x[*n + j1];
x[*n + 1] -= b[j1] * x[j1];
xmax = 0.;
i__1 = j1 - 1;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__3 = xmax, d__4 = (d__1 = x[k], abs(d__1)) + (
d__2 = x[k + *n], abs(d__2));
xmax = max(d__3,d__4);
/* L50: */
}
}
} else {
/* Meet 2 by 2 diagonal block */
d__[0] = x[j1];
d__[1] = x[j2];
d__[2] = x[*n + j1];
d__[3] = x[*n + j2];
d__1 = -(*w);
dlaln2_(&c_false, &c__2, &c__2, &sminw, &c_b21, &t[j1 +
j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &
c_b25, &d__1, v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.) {
i__1 = *n << 1;
dscal_(&i__1, &scaloc, &x[1], &c__1);
*scale = scaloc * *scale;
}
x[j1] = v[0];
x[j2] = v[1];
x[*n + j1] = v[2];
x[*n + j2] = v[3];
/* Scale X(J1), .... to avoid overflow in */
/* updating right hand side. */
/* Computing MAX */
d__1 = abs(v[0]) + abs(v[2]), d__2 = abs(v[1]) + abs(v[3])
;
xj = max(d__1,d__2);
if (xj > 1.) {
rec = 1. / xj;
/* Computing MAX */
d__1 = work[j1], d__2 = work[j2];
if (max(d__1,d__2) > (bignum - xmax) * rec) {
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
}
}
/* Update the right-hand side. */
if (j1 > 1) {
i__1 = j1 - 1;
d__1 = -x[j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
d__1 = -x[j2];
daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
d__1 = -x[*n + j1];
daxpy_(&i__1, &d__1, &t[j1 * t_dim1 + 1], &c__1, &x[*
n + 1], &c__1);
i__1 = j1 - 1;
d__1 = -x[*n + j2];
daxpy_(&i__1, &d__1, &t[j2 * t_dim1 + 1], &c__1, &x[*
n + 1], &c__1);
x[1] = x[1] + b[j1] * x[*n + j1] + b[j2] * x[*n + j2];
x[*n + 1] = x[*n + 1] - b[j1] * x[j1] - b[j2] * x[j2];
xmax = 0.;
i__1 = j1 - 1;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
d__3 = (d__1 = x[k], abs(d__1)) + (d__2 = x[k + *
n], abs(d__2));
xmax = max(d__3,xmax);
/* L60: */
}
}
}
L70:
;
}
} else {
/* Solve (T + iB)'*(p+iq) = c+id */
jnext = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (j < jnext) {
goto L80;
}
j1 = j;
j2 = j;
jnext = j + 1;
if (j < *n) {
if (t[j + 1 + j * t_dim1] != 0.) {
j2 = j + 1;
jnext = j + 2;
}
}
if (j1 == j2) {
/* 1 by 1 diagonal block */
/* Scale if necessary to avoid overflow in forming the */
/* right-hand side element by inner product. */
xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs(
d__2));
if (xmax > 1.) {
rec = 1. / xmax;
if (work[j1] > (bignum - xj) * rec) {
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
x[j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &
c__1);
i__2 = j1 - 1;
x[*n + j1] -= ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[
*n + 1], &c__1);
if (j1 > 1) {
x[j1] -= b[j1] * x[*n + 1];
x[*n + j1] += b[j1] * x[1];
}
xj = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n], abs(
d__2));
z__ = *w;
if (j1 == 1) {
z__ = b[1];
}
/* Scale if necessary to avoid overflow in */
/* complex division */
tjj = (d__1 = t[j1 + j1 * t_dim1], abs(d__1)) + abs(z__);
tmp = t[j1 + j1 * t_dim1];
if (tjj < sminw) {
tmp = sminw;
tjj = sminw;
*info = 1;
}
if (tjj < 1.) {
if (xj > bignum * tjj) {
rec = 1. / xj;
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
d__1 = -z__;
dladiv_(&x[j1], &x[*n + j1], &tmp, &d__1, &sr, &si);
x[j1] = sr;
x[j1 + *n] = si;
/* Computing MAX */
d__3 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[j1 + *n],
abs(d__2));
xmax = max(d__3,xmax);
} else {
/* 2 by 2 diagonal block */
/* Scale if necessary to avoid overflow in forming the */
/* right-hand side element by inner product. */
/* Computing MAX */
d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1],
abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + (
d__4 = x[*n + j2], abs(d__4));
xj = max(d__5,d__6);
if (xmax > 1.) {
rec = 1. / xmax;
/* Computing MAX */
d__1 = work[j1], d__2 = work[j2];
if (max(d__1,d__2) > (bignum - xj) / xmax) {
dscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
d__[0] = x[j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &c__1,
&x[1], &c__1);
i__2 = j1 - 1;
d__[1] = x[j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &c__1,
&x[1], &c__1);
i__2 = j1 - 1;
d__[2] = x[*n + j1] - ddot_(&i__2, &t[j1 * t_dim1 + 1], &
c__1, &x[*n + 1], &c__1);
i__2 = j1 - 1;
d__[3] = x[*n + j2] - ddot_(&i__2, &t[j2 * t_dim1 + 1], &
c__1, &x[*n + 1], &c__1);
d__[0] -= b[j1] * x[*n + 1];
d__[1] -= b[j2] * x[*n + 1];
d__[2] += b[j1] * x[1];
d__[3] += b[j2] * x[1];
dlaln2_(&c_true, &c__2, &c__2, &sminw, &c_b21, &t[j1 + j1
* t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &
c_b25, w, v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.) {
dscal_(&n2, &scaloc, &x[1], &c__1);
*scale = scaloc * *scale;
}
x[j1] = v[0];
x[j2] = v[1];
x[*n + j1] = v[2];
x[*n + j2] = v[3];
/* Computing MAX */
d__5 = (d__1 = x[j1], abs(d__1)) + (d__2 = x[*n + j1],
abs(d__2)), d__6 = (d__3 = x[j2], abs(d__3)) + (
d__4 = x[*n + j2], abs(d__4)), d__5 = max(d__5,
d__6);
xmax = max(d__5,xmax);
}
L80:
;
}
}
}
return 0;
/* End of DLAQTR */
} /* dlaqtr_ */
int
dlacon_(int *n, double *v, double *x, int *isgn, double *est, int *kase)
{
/*
Purpose
=======
DLACON estimates the 1-norm of a square matrix A.
Reverse communication is used for evaluating matrix-vector products.
Arguments
=========
N (input) INT
The order of the matrix. N >= 1.
V (workspace) DOUBLE PRECISION array, dimension (N)
On the final return, V = A*W, where EST = norm(V)/norm(W)
(W is not returned).
X (input/output) DOUBLE PRECISION array, dimension (N)
On an intermediate return, X should be overwritten by
A * X, if KASE=1,
A' * X, if KASE=2,
and DLACON must be re-called with all the other parameters
unchanged.
ISGN (workspace) INT array, dimension (N)
EST (output) DOUBLE PRECISION
An estimate (a lower bound) for norm(A).
KASE (input/output) INT
On the initial call to DLACON, KASE should be 0.
On an intermediate return, KASE will be 1 or 2, indicating
whether X should be overwritten by A * X or A' * X.
On the final return from DLACON, KASE will again be 0.
Further Details
======= =======
Contributed by Nick Higham, University of Manchester.
Originally named CONEST, dated March 16, 1988.
Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
a real or complex matrix, with applications to condition estimation",
ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
=====================================================================
*/
/* Table of constant values */
int c__1 = 1;
double zero = 0.0;
double one = 1.0;
/* Local variables */
static int iter;
static int jump, jlast;
static double altsgn, estold;
static int i, j;
double temp;
extern int idamax_(int *, double *, int *);
extern double dasum_(int *, double *, int *);
extern int dcopy_(int *, double *, int *, double *, int *);
#define d_sign(a, b) (b >= 0 ? fabs(a) : -fabs(a)) /* Copy sign */
#define i_dnnt(a) \
( a>=0 ? floor(a+.5) : -floor(.5-a) ) /* Round to nearest integer */
if ( *kase == 0 ) {
for (i = 0; i < *n; ++i) {
x[i] = 1. / (double) (*n);
}
*kase = 1;
jump = 1;
return 0;
}
switch (jump) {
case 1: goto L20;
case 2: goto L40;
case 3: goto L70;
case 4: goto L110;
case 5: goto L140;
}
/* ................ ENTRY (JUMP = 1)
FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
L20:
if (*n == 1) {
v[0] = x[0];
*est = fabs(v[0]);
/* ... QUIT */
goto L150;
}
*est = dasum_(n, x, &c__1);
for (i = 0; i < *n; ++i) {
x[i] = d_sign(one, x[i]);
isgn[i] = i_dnnt(x[i]);
}
*kase = 2;
jump = 2;
return 0;
/* ................ ENTRY (JUMP = 2)
FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L40:
j = idamax_(n, &x[0], &c__1);
--j;
iter = 2;
/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
L50:
for (i = 0; i < *n; ++i) x[i] = zero;
x[j] = one;
*kase = 1;
jump = 3;
return 0;
/* ................ ENTRY (JUMP = 3)
X HAS BEEN OVERWRITTEN BY A*X. */
L70:
dcopy_(n, &x[0], &c__1, &v[0], &c__1);
estold = *est;
*est = dasum_(n, v, &c__1);
for (i = 0; i < *n; ++i)
if (i_dnnt(d_sign(one, x[i])) != isgn[i])
goto L90;
/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
goto L120;
L90:
/* TEST FOR CYCLING. */
if (*est <= estold) goto L120;
for (i = 0; i < *n; ++i) {
x[i] = d_sign(one, x[i]);
isgn[i] = i_dnnt(x[i]);
}
*kase = 2;
jump = 4;
return 0;
/* ................ ENTRY (JUMP = 4)
X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. */
L110:
jlast = j;
j = idamax_(n, &x[0], &c__1);
--j;
if (x[jlast] != fabs(x[j]) && iter < 5) {
++iter;
goto L50;
}
/* ITERATION COMPLETE. FINAL STAGE. */
L120:
altsgn = 1.;
for (i = 1; i <= *n; ++i) {
x[i-1] = altsgn * ((double) (i - 1) / (double) (*n - 1) + 1.);
altsgn = -altsgn;
}
*kase = 1;
jump = 5;
return 0;
/* ................ ENTRY (JUMP = 5)
X HAS BEEN OVERWRITTEN BY A*X. */
L140:
temp = dasum_(n, x, &c__1) / (double) (*n * 3) * 2.;
if (temp > *est) {
dcopy_(n, &x[0], &c__1, &v[0], &c__1);
*est = temp;
}
L150:
*kase = 0;
return 0;
} /* dlacon_ */
/* Subroutine */ int dtbt02_(char *uplo, char *trans, char *diag, integer *n,
integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal
*x, integer *ldx, doublereal *b, integer *ldb, doublereal *work,
doublereal *resid)
{
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
integer j;
doublereal eps;
doublereal anorm, bnorm;
doublereal xnorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DTBT02 computes the residual for the computed solution to a */
/* triangular system of linear equations A*x = b or A' *x = b when */
/* A is a triangular band matrix. Here A' is the transpose of A and */
/* x and b are N by NRHS matrices. The test ratio is the maximum over */
/* the number of right hand sides of */
/* norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
/* where op(A) denotes A or A' and EPS is the machine epsilon. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation applied to A. */
/* = 'N': A *x = b (No transpose) */
/* = 'T': A'*x = b (Transpose) */
/* = 'C': A'*x = b (Conjugate transpose = Transpose) */
/* 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. */
/* KD (input) INTEGER */
/* The number of superdiagonals or subdiagonals of the */
/* triangular band matrix A. KD >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices X and B. NRHS >= 0. */
/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */
/* The upper or lower triangular 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). */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* The computed solution vectors for the system of linear */
/* equations. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* The right hand side vectors for the system of linear */
/* equations. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESID (output) DOUBLE PRECISION */
/* The maximum over the number of right hand sides of */
/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0 */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.;
return 0;
}
/* Compute the 1-norm of A or A'. */
if (lsame_(trans, "N")) {
anorm = dlantb_("1", uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]
);
} else {
anorm = dlantb_("I", uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]
);
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Compute the maximum over the number of right hand sides of */
/* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
*resid = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
dtbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], &
c__1);
daxpy_(n, &c_b10, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
bnorm = dasum_(n, &work[1], &c__1);
xnorm = dasum_(n, &x[j * x_dim1 + 1], &c__1);
if (xnorm <= 0.) {
*resid = 1. / eps;
} else {
/* Computing MAX */
d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
*resid = max(d__1,d__2);
}
/* L10: */
}
return 0;
/* End of DTBT02 */
} /* dtbt02_ */
/* Subroutine */
int dlaein_(logical *rightv, logical *noinit, integer *n, doublereal *h__, integer *ldh, doublereal *wr, doublereal *wi, doublereal *vr, doublereal *vi, doublereal *b, integer *ldb, doublereal *work, doublereal *eps3, doublereal *smlnum, doublereal * bignum, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
doublereal w, x, y;
integer i1, i2, i3;
doublereal w1, ei, ej, xi, xr, rec;
integer its, ierr;
doublereal temp, norm, vmax;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
extern /* Subroutine */
int dscal_(integer *, doublereal *, doublereal *, integer *);
doublereal scale;
extern doublereal dasum_(integer *, doublereal *, integer *);
char trans[1];
doublereal vcrit, rootn, vnorm;
extern doublereal dlapy2_(doublereal *, doublereal *);
doublereal absbii, absbjj;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */
int dladiv_(doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *), dlatrs_( char *, char *, char *, char *, integer *, doublereal *, integer * , doublereal *, doublereal *, doublereal *, integer *);
char normin[1];
doublereal nrmsml, growto;
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--vr;
--vi;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
*info = 0;
/* GROWTO is the threshold used in the acceptance test for an */
/* eigenvector. */
rootn = sqrt((doublereal) (*n));
growto = .1 / rootn;
/* Computing MAX */
d__1 = 1.;
d__2 = *eps3 * rootn; // , expr subst
nrmsml = max(d__1,d__2) * *smlnum;
/* Form B = H - (WR,WI)*I (except that the subdiagonal elements and */
/* the imaginary parts of the diagonal elements are not stored). */
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j - 1;
for (i__ = 1;
i__ <= i__2;
++i__)
{
b[i__ + j * b_dim1] = h__[i__ + j * h_dim1];
/* L10: */
}
b[j + j * b_dim1] = h__[j + j * h_dim1] - *wr;
/* L20: */
}
if (*wi == 0.)
{
/* Real eigenvalue. */
if (*noinit)
{
/* Set initial vector. */
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
vr[i__] = *eps3;
/* L30: */
}
}
else
{
/* Scale supplied initial vector. */
vnorm = dnrm2_(n, &vr[1], &c__1);
d__1 = *eps3 * rootn / max(vnorm,nrmsml);
dscal_(n, &d__1, &vr[1], &c__1);
}
if (*rightv)
{
/* LU decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
ei = h__[i__ + 1 + i__ * h_dim1];
if ((d__1 = b[i__ + i__ * b_dim1], abs(d__1)) < abs(ei))
{
/* Interchange rows and eliminate. */
x = b[i__ + i__ * b_dim1] / ei;
b[i__ + i__ * b_dim1] = ei;
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
temp = b[i__ + 1 + j * b_dim1];
b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - x * temp;
b[i__ + j * b_dim1] = temp;
/* L40: */
}
}
else
{
/* Eliminate without interchange. */
if (b[i__ + i__ * b_dim1] == 0.)
{
b[i__ + i__ * b_dim1] = *eps3;
}
x = ei / b[i__ + i__ * b_dim1];
if (x != 0.)
{
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
b[i__ + 1 + j * b_dim1] -= x * b[i__ + j * b_dim1] ;
/* L50: */
}
}
}
/* L60: */
}
if (b[*n + *n * b_dim1] == 0.)
{
b[*n + *n * b_dim1] = *eps3;
}
*(unsigned char *)trans = 'N';
}
else
{
/* UL decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
for (j = *n;
j >= 2;
--j)
{
ej = h__[j + (j - 1) * h_dim1];
if ((d__1 = b[j + j * b_dim1], abs(d__1)) < abs(ej))
{
/* Interchange columns and eliminate. */
x = b[j + j * b_dim1] / ej;
b[j + j * b_dim1] = ej;
i__1 = j - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
temp = b[i__ + (j - 1) * b_dim1];
b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - x * temp;
b[i__ + j * b_dim1] = temp;
/* L70: */
}
}
else
{
/* Eliminate without interchange. */
if (b[j + j * b_dim1] == 0.)
{
b[j + j * b_dim1] = *eps3;
}
x = ej / b[j + j * b_dim1];
if (x != 0.)
{
i__1 = j - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
b[i__ + (j - 1) * b_dim1] -= x * b[i__ + j * b_dim1];
/* L80: */
}
}
}
/* L90: */
}
if (b[b_dim1 + 1] == 0.)
{
b[b_dim1 + 1] = *eps3;
}
*(unsigned char *)trans = 'T';
}
*(unsigned char *)normin = 'N';
i__1 = *n;
for (its = 1;
its <= i__1;
++its)
{
/* Solve U*x = scale*v for a right eigenvector */
/* or U**T*x = scale*v for a left eigenvector, */
/* overwriting x on v. */
dlatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, & vr[1], &scale, &work[1], &ierr);
*(unsigned char *)normin = 'Y';
/* Test for sufficient growth in the norm of v. */
vnorm = dasum_(n, &vr[1], &c__1);
if (vnorm >= growto * scale)
{
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
temp = *eps3 / (rootn + 1.);
vr[1] = *eps3;
i__2 = *n;
for (i__ = 2;
i__ <= i__2;
++i__)
{
vr[i__] = temp;
/* L100: */
}
vr[*n - its + 1] -= *eps3 * rootn;
/* L110: */
}
/* Failure to find eigenvector in N iterations. */
*info = 1;
L120: /* Normalize eigenvector. */
i__ = idamax_(n, &vr[1], &c__1);
d__2 = 1. / (d__1 = vr[i__], abs(d__1));
dscal_(n, &d__2, &vr[1], &c__1);
}
else
{
/* Complex eigenvalue. */
if (*noinit)
{
/* Set initial vector. */
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
vr[i__] = *eps3;
vi[i__] = 0.;
/* L130: */
}
}
else
{
/* Scale supplied initial vector. */
d__1 = dnrm2_(n, &vr[1], &c__1);
d__2 = dnrm2_(n, &vi[1], &c__1);
norm = dlapy2_(&d__1, &d__2);
rec = *eps3 * rootn / max(norm,nrmsml);
dscal_(n, &rec, &vr[1], &c__1);
dscal_(n, &rec, &vi[1], &c__1);
}
if (*rightv)
{
/* LU decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
/* The imaginary part of the (i,j)-th element of U is stored in */
/* B(j+1,i). */
b[b_dim1 + 2] = -(*wi);
i__1 = *n;
for (i__ = 2;
i__ <= i__1;
++i__)
{
b[i__ + 1 + b_dim1] = 0.;
/* L140: */
}
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
absbii = dlapy2_(&b[i__ + i__ * b_dim1], &b[i__ + 1 + i__ * b_dim1]);
ei = h__[i__ + 1 + i__ * h_dim1];
if (absbii < abs(ei))
{
/* Interchange rows and eliminate. */
xr = b[i__ + i__ * b_dim1] / ei;
xi = b[i__ + 1 + i__ * b_dim1] / ei;
b[i__ + i__ * b_dim1] = ei;
b[i__ + 1 + i__ * b_dim1] = 0.;
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
temp = b[i__ + 1 + j * b_dim1];
b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - xr * temp;
b[j + 1 + (i__ + 1) * b_dim1] = b[j + 1 + i__ * b_dim1] - xi * temp;
b[i__ + j * b_dim1] = temp;
b[j + 1 + i__ * b_dim1] = 0.;
/* L150: */
}
b[i__ + 2 + i__ * b_dim1] = -(*wi);
b[i__ + 1 + (i__ + 1) * b_dim1] -= xi * *wi;
b[i__ + 2 + (i__ + 1) * b_dim1] += xr * *wi;
}
else
{
/* Eliminate without interchanging rows. */
if (absbii == 0.)
{
b[i__ + i__ * b_dim1] = *eps3;
b[i__ + 1 + i__ * b_dim1] = 0.;
absbii = *eps3;
}
ei = ei / absbii / absbii;
xr = b[i__ + i__ * b_dim1] * ei;
xi = -b[i__ + 1 + i__ * b_dim1] * ei;
i__2 = *n;
for (j = i__ + 1;
j <= i__2;
++j)
{
b[i__ + 1 + j * b_dim1] = b[i__ + 1 + j * b_dim1] - xr * b[i__ + j * b_dim1] + xi * b[j + 1 + i__ * b_dim1];
b[j + 1 + (i__ + 1) * b_dim1] = -xr * b[j + 1 + i__ * b_dim1] - xi * b[i__ + j * b_dim1];
/* L160: */
}
b[i__ + 2 + (i__ + 1) * b_dim1] -= *wi;
}
/* Compute 1-norm of offdiagonal elements of i-th row. */
i__2 = *n - i__;
i__3 = *n - i__;
work[i__] = dasum_(&i__2, &b[i__ + (i__ + 1) * b_dim1], ldb) + dasum_(&i__3, &b[i__ + 2 + i__ * b_dim1], &c__1);
/* L170: */
}
if (b[*n + *n * b_dim1] == 0. && b[*n + 1 + *n * b_dim1] == 0.)
{
b[*n + *n * b_dim1] = *eps3;
}
work[*n] = 0.;
i1 = *n;
i2 = 1;
i3 = -1;
}
else
{
/* UL decomposition with partial pivoting of conjg(B), */
/* replacing zero pivots by EPS3. */
/* The imaginary part of the (i,j)-th element of U is stored in */
/* B(j+1,i). */
b[*n + 1 + *n * b_dim1] = *wi;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
b[*n + 1 + j * b_dim1] = 0.;
/* L180: */
}
for (j = *n;
j >= 2;
--j)
{
ej = h__[j + (j - 1) * h_dim1];
absbjj = dlapy2_(&b[j + j * b_dim1], &b[j + 1 + j * b_dim1]);
if (absbjj < abs(ej))
{
/* Interchange columns and eliminate */
xr = b[j + j * b_dim1] / ej;
xi = b[j + 1 + j * b_dim1] / ej;
b[j + j * b_dim1] = ej;
b[j + 1 + j * b_dim1] = 0.;
i__1 = j - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
temp = b[i__ + (j - 1) * b_dim1];
b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - xr * temp;
b[j + i__ * b_dim1] = b[j + 1 + i__ * b_dim1] - xi * temp;
b[i__ + j * b_dim1] = temp;
b[j + 1 + i__ * b_dim1] = 0.;
/* L190: */
}
b[j + 1 + (j - 1) * b_dim1] = *wi;
b[j - 1 + (j - 1) * b_dim1] += xi * *wi;
b[j + (j - 1) * b_dim1] -= xr * *wi;
}
else
{
/* Eliminate without interchange. */
if (absbjj == 0.)
{
b[j + j * b_dim1] = *eps3;
b[j + 1 + j * b_dim1] = 0.;
absbjj = *eps3;
}
ej = ej / absbjj / absbjj;
xr = b[j + j * b_dim1] * ej;
xi = -b[j + 1 + j * b_dim1] * ej;
i__1 = j - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
b[i__ + (j - 1) * b_dim1] = b[i__ + (j - 1) * b_dim1] - xr * b[i__ + j * b_dim1] + xi * b[j + 1 + i__ * b_dim1];
b[j + i__ * b_dim1] = -xr * b[j + 1 + i__ * b_dim1] - xi * b[i__ + j * b_dim1];
/* L200: */
}
b[j + (j - 1) * b_dim1] += *wi;
}
/* Compute 1-norm of offdiagonal elements of j-th column. */
i__1 = j - 1;
i__2 = j - 1;
work[j] = dasum_(&i__1, &b[j * b_dim1 + 1], &c__1) + dasum_(& i__2, &b[j + 1 + b_dim1], ldb);
/* L210: */
}
if (b[b_dim1 + 1] == 0. && b[b_dim1 + 2] == 0.)
{
b[b_dim1 + 1] = *eps3;
}
work[1] = 0.;
i1 = 1;
i2 = *n;
i3 = 1;
}
i__1 = *n;
for (its = 1;
its <= i__1;
++its)
{
scale = 1.;
vmax = 1.;
vcrit = *bignum;
/* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector, */
/* or U**T*(xr,xi) = scale*(vr,vi) for a left eigenvector, */
/* overwriting (xr,xi) on (vr,vi). */
i__2 = i2;
i__3 = i3;
for (i__ = i1;
i__3 < 0 ? i__ >= i__2 : i__ <= i__2;
i__ += i__3)
{
if (work[i__] > vcrit)
{
rec = 1. / vmax;
dscal_(n, &rec, &vr[1], &c__1);
dscal_(n, &rec, &vi[1], &c__1);
scale *= rec;
vmax = 1.;
vcrit = *bignum;
}
xr = vr[i__];
xi = vi[i__];
if (*rightv)
{
i__4 = *n;
for (j = i__ + 1;
j <= i__4;
++j)
{
xr = xr - b[i__ + j * b_dim1] * vr[j] + b[j + 1 + i__ * b_dim1] * vi[j];
xi = xi - b[i__ + j * b_dim1] * vi[j] - b[j + 1 + i__ * b_dim1] * vr[j];
/* L220: */
}
}
else
{
i__4 = i__ - 1;
for (j = 1;
j <= i__4;
++j)
{
xr = xr - b[j + i__ * b_dim1] * vr[j] + b[i__ + 1 + j * b_dim1] * vi[j];
xi = xi - b[j + i__ * b_dim1] * vi[j] - b[i__ + 1 + j * b_dim1] * vr[j];
/* L230: */
}
}
w = (d__1 = b[i__ + i__ * b_dim1], abs(d__1)) + (d__2 = b[i__ + 1 + i__ * b_dim1], abs(d__2));
if (w > *smlnum)
{
if (w < 1.)
{
w1 = abs(xr) + abs(xi);
if (w1 > w * *bignum)
{
rec = 1. / w1;
dscal_(n, &rec, &vr[1], &c__1);
dscal_(n, &rec, &vi[1], &c__1);
xr = vr[i__];
xi = vi[i__];
scale *= rec;
vmax *= rec;
}
}
/* Divide by diagonal element of B. */
dladiv_(&xr, &xi, &b[i__ + i__ * b_dim1], &b[i__ + 1 + i__ * b_dim1], &vr[i__], &vi[i__]);
/* Computing MAX */
d__3 = (d__1 = vr[i__], abs(d__1)) + (d__2 = vi[i__], abs( d__2));
vmax = max(d__3,vmax);
vcrit = *bignum / vmax;
}
else
{
i__4 = *n;
for (j = 1;
j <= i__4;
++j)
{
vr[j] = 0.;
vi[j] = 0.;
/* L240: */
}
vr[i__] = 1.;
vi[i__] = 1.;
scale = 0.;
vmax = 1.;
vcrit = *bignum;
}
/* L250: */
}
/* Test for sufficient growth in the norm of (VR,VI). */
vnorm = dasum_(n, &vr[1], &c__1) + dasum_(n, &vi[1], &c__1);
if (vnorm >= growto * scale)
{
goto L280;
}
/* Choose a new orthogonal starting vector and try again. */
y = *eps3 / (rootn + 1.);
vr[1] = *eps3;
vi[1] = 0.;
i__3 = *n;
for (i__ = 2;
i__ <= i__3;
++i__)
{
vr[i__] = y;
vi[i__] = 0.;
/* L260: */
}
vr[*n - its + 1] -= *eps3 * rootn;
/* L270: */
}
/* Failure to find eigenvector in N iterations */
*info = 1;
L280: /* Normalize eigenvector. */
vnorm = 0.;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Computing MAX */
d__3 = vnorm;
d__4 = (d__1 = vr[i__], abs(d__1)) + (d__2 = vi[i__] , abs(d__2)); // , expr subst
vnorm = max(d__3,d__4);
/* L290: */
}
d__1 = 1. / vnorm;
dscal_(n, &d__1, &vr[1], &c__1);
d__1 = 1. / vnorm;
dscal_(n, &d__1, &vi[1], &c__1);
}
return 0;
/* End of DLAEIN */
}
double dasum(const int N,
const double *X,
const int incX) {
return dasum_(&N, X, &incX);
}
/* Subroutine */ int dget02_(char *trans, integer *m, integer *n, integer *
nrhs, doublereal *a, integer *lda, doublereal *x, integer *ldx,
doublereal *b, integer *ldb, doublereal *rwork, doublereal *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
integer j, n1, n2;
doublereal eps;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
extern doublereal dasum_(integer *, doublereal *, integer *);
doublereal anorm, bnorm, xnorm;
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGET02 computes the residual for a solution of a system of linear */
/* equations A*x = b or A'*x = b: */
/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A *x = b */
/* = 'T': A'*x = b, where A' is the transpose of A */
/* = 'C': A'*x = b, where A' is the transpose of A */
/* 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. */
/* NRHS (input) INTEGER */
/* The number of columns of B, the matrix of right hand sides. */
/* NRHS >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The original M x N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* The computed solution vectors for the system of linear */
/* equations. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. If TRANS = 'N', */
/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the right hand side vectors for the system of */
/* linear equations. */
/* On exit, B is overwritten with the difference B - A*X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. IF TRANS = 'N', */
/* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
/* RESID (output) DOUBLE PRECISION */
/* The maximum over the number of right hand sides of */
/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if M = 0 or N = 0 or NRHS = 0 */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--rwork;
/* Function Body */
if (*m <= 0 || *n <= 0 || *nrhs == 0) {
*resid = 0.;
return 0;
}
if (lsame_(trans, "T") || lsame_(trans, "C")) {
n1 = *n;
n2 = *m;
} else {
n1 = *m;
n2 = *n;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
anorm = dlange_("1", &n1, &n2, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Compute B - A*X (or B - A'*X ) and store in B. */
dgemm_(trans, "No transpose", &n1, nrhs, &n2, &c_b7, &a[a_offset], lda, &
x[x_offset], ldx, &c_b8, &b[b_offset], ldb)
;
/* Compute the maximum over the number of right hand sides of */
/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) . */
*resid = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bnorm = dasum_(&n1, &b[j * b_dim1 + 1], &c__1);
xnorm = dasum_(&n2, &x[j * x_dim1 + 1], &c__1);
if (xnorm <= 0.) {
*resid = 1. / eps;
} else {
/* Computing MAX */
d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
*resid = max(d__1,d__2);
}
/* L10: */
}
return 0;
/* End of DGET02 */
} /* dget02_ */
/* Subroutine */ int dgbt02_(char *trans, integer *m, integer *n, integer *kl,
integer *ku, integer *nrhs, doublereal *a, integer *lda, doublereal *
x, integer *ldx, doublereal *b, integer *ldb, doublereal *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
i__3;
doublereal d__1, d__2;
/* Local variables */
static integer j;
extern /* Subroutine */ int dgbmv_(char *, integer *, integer *, integer *
, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
extern doublereal dasum_(integer *, doublereal *, integer *);
static doublereal anorm, bnorm;
static integer i1, i2, n1;
static doublereal xnorm;
static integer kd;
extern doublereal dlamch_(char *);
static doublereal eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DGBT02 computes the residual for a solution of a banded system of
equations A*x = b or A'*x = b:
RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS).
where EPS is the machine precision.
Arguments
=========
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A *x = b
= 'T': A'*x = b, where A' is the transpose of A
= 'C': A'*x = b, where A' is the transpose of A
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.
NRHS (input) INTEGER
The number of columns of B. NRHS >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
The original matrix A in band storage, stored in rows 1 to
KL+KU+1.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,KL+KU+1).
X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
The computed solution vectors for the system of linear
equations.
LDX (input) INTEGER
The leading dimension of the array X. If TRANS = 'N',
LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M).
B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
On entry, the right hand side vectors for the system of
linear equations.
On exit, B is overwritten with the difference B - A*X.
LDB (input) INTEGER
The leading dimension of the array B. IF TRANS = 'N',
LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
RESID (output) DOUBLE PRECISION
The maximum over the number of right hand sides of
norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
=====================================================================
Quick return if N = 0 pr NRHS = 0
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
if (*m <= 0 || *n <= 0 || *nrhs <= 0) {
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
kd = *ku + 1;
anorm = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = kd + 1 - j;
i1 = max(i__2,1);
/* Computing MIN */
i__2 = kd + *m - j, i__3 = *kl + kd;
i2 = min(i__2,i__3);
/* Computing MAX */
i__2 = i2 - i1 + 1;
d__1 = anorm, d__2 = dasum_(&i__2, &a_ref(i1, j), &c__1);
anorm = max(d__1,d__2);
/* L10: */
}
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
if (lsame_(trans, "T") || lsame_(trans, "C")) {
n1 = *n;
} else {
n1 = *m;
}
/* Compute B - A*X (or B - A'*X ) */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dgbmv_(trans, m, n, kl, ku, &c_b8, &a[a_offset], lda, &x_ref(1, j), &
c__1, &c_b10, &b_ref(1, j), &c__1);
/* L20: */
}
/* Compute the maximum over the number of right hand sides of
norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
*resid = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bnorm = dasum_(&n1, &b_ref(1, j), &c__1);
xnorm = dasum_(&n1, &x_ref(1, j), &c__1);
if (xnorm <= 0.) {
*resid = 1. / eps;
} else {
/* Computing MAX */
d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
*resid = max(d__1,d__2);
}
/* L30: */
}
return 0;
/* End of DGBT02 */
} /* dgbt02_ */
int dlatps_(char *uplo, char *trans, char *diag, char *
normin, int *n, double *ap, double *x, double *scale,
double *cnorm, int *info)
{
/* System generated locals */
int i__1, i__2, i__3;
double d__1, d__2, d__3;
/* Local variables */
int i__, j, ip;
double xj, rec, tjj;
int jinc, jlen;
extern double ddot_(int *, double *, int *, double *,
int *);
double xbnd;
int imax;
double tmax, tjjs, xmax, grow, sumj;
extern int dscal_(int *, double *, double *,
int *);
extern int lsame_(char *, char *);
double tscal, uscal;
extern double dasum_(int *, double *, int *);
int jlast;
extern int daxpy_(int *, double *, double *,
int *, double *, int *);
int upper;
extern int dtpsv_(char *, char *, char *, int *,
double *, double *, int *);
extern double dlamch_(char *);
extern int idamax_(int *, double *, int *);
extern int xerbla_(char *, int *);
double bignum;
int notran;
int jfirst;
double smlnum;
int nounit;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLATPS solves one of the triangular systems */
/* A *x = s*b or A'*x = s*b */
/* with scaling to prevent overflow, where A is an upper or lower */
/* triangular matrix stored in packed form. Here A' denotes the */
/* transpose of A, x and b are n-element vectors, and s is a scaling */
/* factor, usually less than or equal to 1, chosen so that the */
/* components of x will be less than the overflow threshold. If the */
/* unscaled problem will not cause overflow, the Level 2 BLAS routine */
/* DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */
/* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation applied to A. */
/* = 'N': Solve A * x = s*b (No transpose) */
/* = 'T': Solve A'* x = s*b (Transpose) */
/* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* NORMIN (input) CHARACTER*1 */
/* Specifies whether CNORM has been set or not. */
/* = 'Y': CNORM contains the column norms on entry */
/* = 'N': CNORM is not set on entry. On exit, the norms will */
/* be computed and stored in CNORM. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
/* The upper or lower triangular 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. */
/* X (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the right hand side b of the triangular system. */
/* On exit, X is overwritten by the solution vector x. */
/* SCALE (output) DOUBLE PRECISION */
/* The scaling factor s for the triangular system */
/* A * x = s*b or A'* x = s*b. */
/* If SCALE = 0, the matrix A is singular or badly scaled, and */
/* the vector x is an exact or approximate solution to A*x = 0. */
/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */
/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
/* contains the norm of the off-diagonal part of the j-th column */
/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
/* must be greater than or equal to the 1-norm. */
/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
/* returns the 1-norm of the offdiagonal part of the j-th column */
/* of A. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* Further Details */
/* ======= ======= */
/* A rough bound on x is computed; if that is less than overflow, DTPSV */
/* is called, otherwise, specific code is used which checks for possible */
/* overflow or divide-by-zero at every operation. */
/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
/* if A is lower triangular is */
/* x[1:n] := b[1:n] */
/* for j = 1, ..., n */
/* x(j) := x(j) / A(j,j) */
/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
/* end */
/* Define bounds on the components of x after j iterations of the loop: */
/* M(j) = bound on x[1:j] */
/* G(j) = bound on x[j+1:n] */
/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
/* Then for iteration j+1 we have */
/* M(j+1) <= G(j) / | A(j+1,j+1) | */
/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
/* column j+1 of A, not counting the diagonal. Hence */
/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
/* 1<=i<=j */
/* and */
/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
/* 1<=i< j */
/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTPSV if the */
/* reciprocal of the largest M(j), j=1,..,n, is larger than */
/* MAX(underflow, 1/overflow). */
/* The bound on x(j) is also used to determine when a step in the */
/* columnwise method can be performed without fear of overflow. If */
/* the computed bound is greater than a large constant, x is scaled to */
/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
/* Similarly, a row-wise scheme is used to solve A'*x = b. The basic */
/* algorithm for A upper triangular is */
/* for j = 1, ..., n */
/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
/* end */
/* We simultaneously compute two bounds */
/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
/* M(j) = bound on x(i), 1<=i<=j */
/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
/* Then the bound on x(j) is */
/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
/* 1<=i<=j */
/* and we can safely call DTPSV if 1/M(n) and 1/G(n) are both greater */
/* than MAX(underflow, 1/overflow). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--cnorm;
--x;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (! lsame_(normin, "Y") && ! lsame_(normin,
"N")) {
*info = -4;
} else if (*n < 0) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLATPS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = dlamch_("Safe minimum") / dlamch_("Precision");
bignum = 1. / smlnum;
*scale = 1.;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagonal. */
if (upper) {
/* A is upper triangular. */
ip = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
cnorm[j] = dasum_(&i__2, &ap[ip], &c__1);
ip += j;
/* L10: */
}
} else {
/* A is lower triangular. */
ip = 1;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
cnorm[j] = dasum_(&i__2, &ap[ip + 1], &c__1);
ip = ip + *n - j + 1;
/* L20: */
}
cnorm[*n] = 0.;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM. */
imax = idamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum) {
tscal = 1.;
} else {
tscal = 1. / (smlnum * tmax);
dscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine DTPSV can be used. */
j = idamax_(n, &x[1], &c__1);
xmax = (d__1 = x[j], ABS(d__1));
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
}
if (tscal != 1.) {
grow = 0.;
goto L50;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, G(0) = max{x(i), i=1,...,n}. */
grow = 1. / MAX(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = *n;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L50;
}
/* M(j) = G(j-1) / ABS(A(j,j)) */
tjj = (d__1 = ap[ip], ABS(d__1));
/* Computing MIN */
d__1 = xbnd, d__2 = MIN(1.,tjj) * grow;
xbnd = MIN(d__1,d__2);
if (tjj + cnorm[j] >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / ABS(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.;
}
ip += jinc * jlen;
--jlen;
/* L30: */
}
grow = xbnd;
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
d__1 = 1., d__2 = 1. / MAX(xbnd,smlnum);
grow = MIN(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L50;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1. / (cnorm[j] + 1.);
/* L40: */
}
}
L50:
;
} else {
/* Compute the growth in A' * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
}
if (tscal != 1.) {
grow = 0.;
goto L80;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, M(0) = max{x(i), i=1,...,n}. */
grow = 1. / MAX(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L80;
}
/* G(j) = MAX( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
xj = cnorm[j] + 1.;
/* Computing MIN */
d__1 = grow, d__2 = xbnd / xj;
grow = MIN(d__1,d__2);
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / ABS(A(j,j)) */
tjj = (d__1 = ap[ip], ABS(d__1));
if (xj > tjj) {
xbnd *= tjj / xj;
}
++jlen;
ip += jinc * jlen;
/* L60: */
}
grow = MIN(grow,xbnd);
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
d__1 = 1., d__2 = 1. / MAX(xbnd,smlnum);
grow = MIN(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L80;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.;
grow /= xj;
/* L70: */
}
}
L80:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
/* elements of X is not too small. */
dtpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum) {
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum / xmax;
dscal_(n, scale, &x[1], &c__1);
xmax = bignum;
}
if (notran) {
/* Solve A * x = b */
ip = jfirst * (jfirst + 1) / 2;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
xj = (d__1 = x[j], ABS(d__1));
if (nounit) {
tjjs = ap[ip] * tscal;
} else {
tjjs = tscal;
if (tscal == 1.) {
goto L100;
}
}
tjj = ABS(tjjs);
if (tjj > smlnum) {
/* ABS(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1. / xj;
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j] /= tjjs;
xj = (d__1 = x[j], ABS(d__1));
} else if (tjj > 0.) {
/* 0 < ABS(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/ABS(x(j)))*ABS(A(j,j))*BIGNUM */
/* to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.) {
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
x[j] /= tjjs;
xj = (d__1 = x[j], ABS(d__1));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0, and compute a solution to A*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
x[i__] = 0.;
/* L90: */
}
x[j] = 1.;
xj = 1.;
*scale = 0.;
xmax = 0.;
}
L100:
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.) {
rec = 1. / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*ABS(x(j))). */
rec *= .5;
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
dscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5;
}
if (upper) {
if (j > 1) {
/* Compute the update */
/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
i__3 = j - 1;
d__1 = -x[j] * tscal;
daxpy_(&i__3, &d__1, &ap[ip - j + 1], &c__1, &x[1], &
c__1);
i__3 = j - 1;
i__ = idamax_(&i__3, &x[1], &c__1);
xmax = (d__1 = x[i__], ABS(d__1));
}
ip -= j;
} else {
if (j < *n) {
/* Compute the update */
/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
i__3 = *n - j;
d__1 = -x[j] * tscal;
daxpy_(&i__3, &d__1, &ap[ip + 1], &c__1, &x[j + 1], &
c__1);
i__3 = *n - j;
i__ = j + idamax_(&i__3, &x[j + 1], &c__1);
xmax = (d__1 = x[i__], ABS(d__1));
}
ip = ip + *n - j + 1;
}
/* L110: */
}
} else {
/* Solve A' * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
xj = (d__1 = x[j], ABS(d__1));
uscal = tscal;
rec = 1. / MAX(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5;
if (nounit) {
tjjs = ap[ip] * tscal;
} else {
tjjs = tscal;
}
tjj = ABS(tjjs);
if (tjj > 1.) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = MIN(d__1,d__2);
uscal /= tjjs;
}
if (rec < 1.) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
sumj = 0.;
if (uscal == 1.) {
/* If the scaling needed for A in the dot product is 1, */
/* call DDOT to perform the dot product. */
if (upper) {
i__3 = j - 1;
sumj = ddot_(&i__3, &ap[ip - j + 1], &c__1, &x[1], &
c__1);
} else if (j < *n) {
i__3 = *n - j;
sumj = ddot_(&i__3, &ap[ip + 1], &c__1, &x[j + 1], &
c__1);
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
sumj += ap[ip - j + i__] * uscal * x[i__];
/* L120: */
}
} else if (j < *n) {
i__3 = *n - j;
for (i__ = 1; i__ <= i__3; ++i__) {
sumj += ap[ip + i__] * uscal * x[j + i__];
/* L130: */
}
}
}
if (uscal == tscal) {
/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
x[j] -= sumj;
xj = (d__1 = x[j], ABS(d__1));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjjs = ap[ip] * tscal;
} else {
tjjs = tscal;
if (tscal == 1.) {
goto L150;
}
}
tjj = ABS(tjjs);
if (tjj > smlnum) {
/* ABS(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/ABS(x(j)). */
rec = 1. / xj;
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j] /= tjjs;
} else if (tjj > 0.) {
/* 0 < ABS(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/ABS(x(j)))*ABS(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
x[j] /= tjjs;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0, and compute a solution to A'*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
x[i__] = 0.;
/* L140: */
}
x[j] = 1.;
*scale = 0.;
xmax = 0.;
}
L150:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */
/* product has already been divided by 1/A(j,j). */
x[j] = x[j] / tjjs - sumj;
}
/* Computing MAX */
d__2 = xmax, d__3 = (d__1 = x[j], ABS(d__1));
xmax = MAX(d__2,d__3);
++jlen;
ip += jinc * jlen;
/* L160: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.) {
d__1 = 1. / tscal;
dscal_(n, &d__1, &cnorm[1], &c__1);
}
return 0;
/* End of DLATPS */
} /* dlatps_ */
/* Subroutine */ int dlatrs_(char *uplo, char *trans, char *diag, char *
normin, integer *n, doublereal *a, integer *lda, doublereal *x,
doublereal *scale, doublereal *cnorm, integer *info)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1992
Purpose
=======
DLATRS solves one of the triangular systems
A *x = s*b or A'*x = s*b
with scaling to prevent overflow. Here A is an upper or lower
triangular matrix, A' denotes the transpose of A, x and b are
n-element vectors, and s is a scaling factor, usually less than
or equal to 1, chosen so that the components of x will be less than
the overflow threshold. If the unscaled problem will not cause
overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A
is singular (A(j,j) = 0 for some j), then s is set to 0 and a
non-trivial solution to A*x = 0 is returned.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
TRANS (input) CHARACTER*1
Specifies the operation applied to A.
= 'N': Solve A * x = s*b (No transpose)
= 'T': Solve A'* x = s*b (Transpose)
= 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)
DIAG (input) CHARACTER*1
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
NORMIN (input) CHARACTER*1
Specifies whether CNORM has been set or not.
= 'Y': CNORM contains the column norms on entry
= 'N': CNORM is not set on entry. On exit, the norms will
be computed and stored in CNORM.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
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.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max (1,N).
X (input/output) DOUBLE PRECISION array, dimension (N)
On entry, the right hand side b of the triangular system.
On exit, X is overwritten by the solution vector x.
SCALE (output) DOUBLE PRECISION
The scaling factor s for the triangular system
A * x = s*b or A'* x = s*b.
If SCALE = 0, the matrix A is singular or badly scaled, and
the vector x is an exact or approximate solution to A*x = 0.
CNORM (input or output) DOUBLE PRECISION array, dimension (N)
If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
contains the norm of the off-diagonal part of the j-th column
of A. If TRANS = 'N', CNORM(j) must be greater than or equal
to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
must be greater than or equal to the 1-norm.
If NORMIN = 'N', CNORM is an output argument and CNORM(j)
returns the 1-norm of the offdiagonal part of the j-th column
of A.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
Further Details
======= =======
A rough bound on x is computed; if that is less than overflow, DTRSV
is called, otherwise, specific code is used which checks for possible
overflow or divide-by-zero at every operation.
A columnwise scheme is used for solving A*x = b. The basic algorithm
if A is lower triangular is
x[1:n] := b[1:n]
for j = 1, ..., n
x(j) := x(j) / A(j,j)
x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
end
Define bounds on the components of x after j iterations of the loop:
M(j) = bound on x[1:j]
G(j) = bound on x[j+1:n]
Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
Then for iteration j+1 we have
M(j+1) <= G(j) / | A(j+1,j+1) |
G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
<= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
where CNORM(j+1) is greater than or equal to the infinity-norm of
column j+1 of A, not counting the diagonal. Hence
G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
1<=i<=j
and
|x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
1<=i< j
Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the
reciprocal of the largest M(j), j=1,..,n, is larger than
max(underflow, 1/overflow).
The bound on x(j) is also used to determine when a step in the
columnwise method can be performed without fear of overflow. If
the computed bound is greater than a large constant, x is scaled to
prevent overflow, but if the bound overflows, x is set to 0, x(j) to
1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
Similarly, a row-wise scheme is used to solve A'*x = b. The basic
algorithm for A upper triangular is
for j = 1, ..., n
x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
end
We simultaneously compute two bounds
G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
M(j) = bound on x(i), 1<=i<=j
The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
Then the bound on x(j) is
M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
<= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
1<=i<=j
and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater
than max(underflow, 1/overflow).
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b36 = .5;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Local variables */
static integer jinc;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal xbnd;
static integer imax;
static doublereal tmax, tjjs, xmax, grow, sumj;
static integer i__, j;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
static doublereal tscal, uscal;
extern doublereal dasum_(integer *, doublereal *, integer *);
static integer jlast;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static logical upper;
extern /* Subroutine */ int dtrsv_(char *, char *, char *, integer *,
doublereal *, integer *, doublereal *, integer *);
extern doublereal dlamch_(char *);
static doublereal xj;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal bignum;
static logical notran;
static integer jfirst;
static doublereal smlnum;
static logical nounit;
static doublereal rec, tjj;
#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;
--x;
--cnorm;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (! lsame_(normin, "Y") && ! lsame_(normin,
"N")) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLATRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = dlamch_("Safe minimum") / dlamch_("Precision");
bignum = 1. / smlnum;
*scale = 1.;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagonal. */
if (upper) {
/* A is upper triangular. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
cnorm[j] = dasum_(&i__2, &a_ref(1, j), &c__1);
/* L10: */
}
} else {
/* A is lower triangular. */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
cnorm[j] = dasum_(&i__2, &a_ref(j + 1, j), &c__1);
/* L20: */
}
cnorm[*n] = 0.;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is
greater than BIGNUM. */
imax = idamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum) {
tscal = 1.;
} else {
tscal = 1. / (smlnum * tmax);
dscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the
Level 2 BLAS routine DTRSV can be used. */
j = idamax_(n, &x[1], &c__1);
xmax = (d__1 = x[j], abs(d__1));
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
}
if (tscal != 1.) {
grow = 0.;
goto L50;
}
if (nounit) {
/* A is non-unit triangular.
Compute GROW = 1/G(j) and XBND = 1/M(j).
Initially, G(0) = max{x(i), i=1,...,n}. */
grow = 1. / max(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L50;
}
/* M(j) = G(j-1) / abs(A(j,j)) */
tjj = (d__1 = a_ref(j, j), abs(d__1));
/* Computing MIN */
d__1 = xbnd, d__2 = min(1.,tjj) * grow;
xbnd = min(d__1,d__2);
if (tjj + cnorm[j] >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.;
}
/* L30: */
}
grow = xbnd;
} else {
/* A is unit triangular.
Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
Computing MIN */
d__1 = 1., d__2 = 1. / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L50;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1. / (cnorm[j] + 1.);
/* L40: */
}
}
L50:
;
} else {
/* Compute the growth in A' * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
}
if (tscal != 1.) {
grow = 0.;
goto L80;
}
if (nounit) {
/* A is non-unit triangular.
Compute GROW = 1/G(j) and XBND = 1/M(j).
Initially, M(0) = max{x(i), i=1,...,n}. */
grow = 1. / max(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L80;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
xj = cnorm[j] + 1.;
/* Computing MIN */
d__1 = grow, d__2 = xbnd / xj;
grow = min(d__1,d__2);
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
tjj = (d__1 = a_ref(j, j), abs(d__1));
if (xj > tjj) {
xbnd *= tjj / xj;
}
/* L60: */
}
grow = min(grow,xbnd);
} else {
/* A is unit triangular.
Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
Computing MIN */
d__1 = 1., d__2 = 1. / max(xbnd,smlnum);
grow = min(d__1,d__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L80;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.;
grow /= xj;
/* L70: */
}
}
L80:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on
elements of X is not too small. */
dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum) {
/* Scale X so that its components are less than or equal to
BIGNUM in absolute value. */
*scale = bignum / xmax;
dscal_(n, scale, &x[1], &c__1);
xmax = bignum;
}
if (notran) {
/* Solve A * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
xj = (d__1 = x[j], abs(d__1));
if (nounit) {
tjjs = a_ref(j, j) * tscal;
} else {
tjjs = tscal;
if (tscal == 1.) {
goto L100;
}
}
tjj = abs(tjjs);
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1. / xj;
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j] /= tjjs;
xj = (d__1 = x[j], abs(d__1));
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.) {
/* Scale by 1/CNORM(j) to avoid overflow when
multiplying x(j) times column j. */
rec /= cnorm[j];
}
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
x[j] /= tjjs;
xj = (d__1 = x[j], abs(d__1));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
scale = 0, and compute a solution to A*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
x[i__] = 0.;
/* L90: */
}
x[j] = 1.;
xj = 1.;
*scale = 0.;
xmax = 0.;
}
L100:
/* Scale x if necessary to avoid overflow when adding a
multiple of column j of A. */
if (xj > 1.) {
rec = 1. / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5;
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
dscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5;
}
if (upper) {
if (j > 1) {
/* Compute the update
x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
i__3 = j - 1;
d__1 = -x[j] * tscal;
daxpy_(&i__3, &d__1, &a_ref(1, j), &c__1, &x[1], &
c__1);
i__3 = j - 1;
i__ = idamax_(&i__3, &x[1], &c__1);
xmax = (d__1 = x[i__], abs(d__1));
}
} else {
if (j < *n) {
/* Compute the update
x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
i__3 = *n - j;
d__1 = -x[j] * tscal;
daxpy_(&i__3, &d__1, &a_ref(j + 1, j), &c__1, &x[j +
1], &c__1);
i__3 = *n - j;
i__ = j + idamax_(&i__3, &x[j + 1], &c__1);
xmax = (d__1 = x[i__], abs(d__1));
}
}
/* L110: */
}
} else {
/* Solve A' * x = b */
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k).
k<>j */
xj = (d__1 = x[j], abs(d__1));
uscal = tscal;
rec = 1. / max(xmax,1.);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5;
if (nounit) {
tjjs = a_ref(j, j) * tscal;
} else {
tjjs = tscal;
}
tjj = abs(tjjs);
if (tjj > 1.) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1.
Computing MIN */
d__1 = 1., d__2 = rec * tjj;
rec = min(d__1,d__2);
uscal /= tjjs;
}
if (rec < 1.) {
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
sumj = 0.;
if (uscal == 1.) {
/* If the scaling needed for A in the dot product is 1,
call DDOT to perform the dot product. */
if (upper) {
i__3 = j - 1;
sumj = ddot_(&i__3, &a_ref(1, j), &c__1, &x[1], &c__1)
;
} else if (j < *n) {
i__3 = *n - j;
sumj = ddot_(&i__3, &a_ref(j + 1, j), &c__1, &x[j + 1]
, &c__1);
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
sumj += a_ref(i__, j) * uscal * x[i__];
/* L120: */
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
sumj += a_ref(i__, j) * uscal * x[i__];
/* L130: */
}
}
}
if (uscal == tscal) {
/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
was not used to scale the dotproduct. */
x[j] -= sumj;
xj = (d__1 = x[j], abs(d__1));
if (nounit) {
tjjs = a_ref(j, j) * tscal;
} else {
tjjs = tscal;
if (tscal == 1.) {
goto L150;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = abs(tjjs);
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1. / xj;
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j] /= tjjs;
} else if (tjj > 0.) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
dscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
x[j] /= tjjs;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
scale = 0, and compute a solution to A'*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
x[i__] = 0.;
/* L140: */
}
x[j] = 1.;
*scale = 0.;
xmax = 0.;
}
L150:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - sumj if the dot
product has already been divided by 1/A(j,j). */
x[j] = x[j] / tjjs - sumj;
}
/* Computing MAX */
d__2 = xmax, d__3 = (d__1 = x[j], abs(d__1));
xmax = max(d__2,d__3);
/* L160: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.) {
d__1 = 1. / tscal;
dscal_(n, &d__1, &cnorm[1], &c__1);
}
return 0;
/* End of DLATRS */
} /* dlatrs_ */
/* Subroutine */ int dlacn2_(integer *n, doublereal *v, doublereal *x,
integer *isgn, doublereal *est, integer *kase, integer *isave)
{
/* -- LAPACK auxiliary routine (version 3.1) --
Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
November 2006
Purpose
=======
DLACN2 estimates the 1-norm of a square, real matrix A.
Reverse communication is used for evaluating matrix-vector products.
Arguments
=========
N (input) INTEGER
The order of the matrix. N >= 1.
V (workspace) DOUBLE PRECISION array, dimension (N)
On the final return, V = A*W, where EST = norm(V)/norm(W)
(W is not returned).
X (input/output) DOUBLE PRECISION array, dimension (N)
On an intermediate return, X should be overwritten by
A * X, if KASE=1,
A' * X, if KASE=2,
and DLACN2 must be re-called with all the other parameters
unchanged.
ISGN (workspace) INTEGER array, dimension (N)
EST (input/output) DOUBLE PRECISION
On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
unchanged from the previous call to DLACN2.
On exit, EST is an estimate (a lower bound) for norm(A).
KASE (input/output) INTEGER
On the initial call to DLACN2, KASE should be 0.
On an intermediate return, KASE will be 1 or 2, indicating
whether X should be overwritten by A * X or A' * X.
On the final return from DLACN2, KASE will again be 0.
ISAVE (input/output) INTEGER array, dimension (3)
ISAVE is used to save variables between calls to DLACN2
Further Details
======= =======
Contributed by Nick Higham, University of Manchester.
Originally named SONEST, dated March 16, 1988.
Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
a real or complex matrix, with applications to condition estimation",
ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
This is a thread safe version of DLACON, which uses the array ISAVE
in place of a SAVE statement, as follows:
DLACON DLACN2
JUMP ISAVE(1)
J ISAVE(2)
ITER ISAVE(3)
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b11 = 1.;
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
integer i_dnnt(doublereal *);
/* Local variables */
static integer i__;
static doublereal temp;
extern doublereal dasum_(integer *, doublereal *, integer *);
static integer jlast;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
static doublereal altsgn, estold;
--isave;
--isgn;
--x;
--v;
/* Function Body */
if (*kase == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 1. / (doublereal) (*n);
/* L10: */
}
*kase = 1;
isave[1] = 1;
return 0;
}
switch (isave[1]) {
case 1: goto L20;
case 2: goto L40;
case 3: goto L70;
case 4: goto L110;
case 5: goto L140;
}
/* ................ ENTRY (ISAVE( 1 ) = 1)
FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
L20:
if (*n == 1) {
v[1] = x[1];
*est = abs(v[1]);
/* ... QUIT */
goto L150;
}
*est = dasum_(n, &x[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = d_sign(&c_b11, &x[i__]);
isgn[i__] = i_dnnt(&x[i__]);
/* L30: */
}
*kase = 2;
isave[1] = 2;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 2)
FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L40:
isave[2] = idamax_(n, &x[1], &c__1);
isave[3] = 2;
/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
L50:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 0.;
/* L60: */
}
x[isave[2]] = 1.;
*kase = 1;
isave[1] = 3;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 3)
X HAS BEEN OVERWRITTEN BY A*X. */
L70:
dcopy_(n, &x[1], &c__1, &v[1], &c__1);
estold = *est;
*est = dasum_(n, &v[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = d_sign(&c_b11, &x[i__]);
if (i_dnnt(&d__1) != isgn[i__]) {
goto L90;
}
/* L80: */
}
/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
goto L120;
L90:
/* TEST FOR CYCLING. */
if (*est <= estold) {
goto L120;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = d_sign(&c_b11, &x[i__]);
isgn[i__] = i_dnnt(&x[i__]);
/* L100: */
}
*kase = 2;
isave[1] = 4;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 4)
X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
L110:
jlast = isave[2];
isave[2] = idamax_(n, &x[1], &c__1);
if (x[jlast] != (d__1 = x[isave[2]], abs(d__1)) && isave[3] < 5) {
++isave[3];
goto L50;
}
/* ITERATION COMPLETE. FINAL STAGE. */
L120:
altsgn = 1.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) +
1.);
altsgn = -altsgn;
/* L130: */
}
*kase = 1;
isave[1] = 5;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 5)
X HAS BEEN OVERWRITTEN BY A*X. */
L140:
temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.;
if (temp > *est) {
dcopy_(n, &x[1], &c__1, &v[1], &c__1);
*est = temp;
}
L150:
*kase = 0;
return 0;
/* End of DLACN2 */
} /* dlacn2_ */
doublereal dqrt12_(integer *m, integer *n, doublereal *a, integer *lda,
doublereal *s, doublereal *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal ret_val;
/* Local variables */
static integer iscl, info;
static doublereal anrm;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer i__, j;
extern doublereal dasum_(integer *, doublereal *, integer *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), dgebd2_(integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *
, doublereal *, doublereal *, integer *);
static doublereal dummy[1];
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
static integer mn;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dbdsqr_(char *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *);
static doublereal bignum, smlnum, nrmsvl;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
/* -- LAPACK test 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
=======
DQRT12 computes the singular values `svlues' of the upper trapezoid
of A(1:M,1:N) and returns the ratio
|| s - svlues||/(||svlues||*eps*max(M,N))
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A.
N (input) INTEGER
The number of columns of the matrix A.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
The M-by-N matrix A. Only the upper trapezoid is referenced.
LDA (input) INTEGER
The leading dimension of the array A.
S (input) DOUBLE PRECISION array, dimension (min(M,N))
The singular values of the matrix A.
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
LWORK (input) INTEGER
The length of the array WORK. LWORK >= M*N + 4*min(M,N) +
max(M,N).
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--s;
--work;
/* Function Body */
ret_val = 0.;
/* Test that enough workspace is supplied */
if (*lwork < *m * *n + (min(*m,*n) << 2) + max(*m,*n)) {
xerbla_("DQRT12", &c__7);
return ret_val;
}
/* Quick return if possible */
mn = min(*m,*n);
if ((doublereal) mn <= 0.) {
return ret_val;
}
nrmsvl = dnrm2_(&mn, &s[1], &c__1);
/* Copy upper triangle of A into work */
dlaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
work[(j - 1) * *m + i__] = a_ref(i__, j);
/* L10: */
}
/* L20: */
}
/* Get machine parameters */
smlnum = dlamch_("S") / dlamch_("P");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Scale work if max entry outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", m, n, &work[1], m, dummy);
iscl = 0;
if (anrm > 0. && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &work[1], m, &info);
iscl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &work[1], m, &info);
iscl = 1;
}
if (anrm != 0.) {
/* Compute SVD of work */
dgebd2_(m, n, &work[1], m, &work[*m * *n + 1], &work[*m * *n + mn + 1]
, &work[*m * *n + (mn << 1) + 1], &work[*m * *n + mn * 3 + 1],
&work[*m * *n + (mn << 2) + 1], &info);
dbdsqr_("Upper", &mn, &c__0, &c__0, &c__0, &work[*m * *n + 1], &work[*
m * *n + mn + 1], dummy, &mn, dummy, &c__1, dummy, &mn, &work[
*m * *n + (mn << 1) + 1], &info);
if (iscl == 1) {
if (anrm > bignum) {
dlascl_("G", &c__0, &c__0, &bignum, &anrm, &mn, &c__1, &work[*
m * *n + 1], &mn, &info);
}
if (anrm < smlnum) {
dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &mn, &c__1, &work[*
m * *n + 1], &mn, &info);
}
}
} else {
i__1 = mn;
for (i__ = 1; i__ <= i__1; ++i__) {
work[*m * *n + i__] = 0.;
/* L30: */
}
}
/* Compare s and singular values of work */
daxpy_(&mn, &c_b33, &s[1], &c__1, &work[*m * *n + 1], &c__1);
ret_val = dasum_(&mn, &work[*m * *n + 1], &c__1) / (dlamch_("Epsilon") * (doublereal) max(*m,*n));
if (nrmsvl != 0.) {
ret_val /= nrmsvl;
}
return ret_val;
/* End of DQRT12 */
} /* dqrt12_ */
/* Subroutine */ int dchkgt_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, doublereal *thresh, logical *tsterr,
doublereal *a, doublereal *af, doublereal *b, doublereal *x,
doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char transs[1*3] = "N" "T" "C";
/* Format strings */
static char fmt_9999[] = "(12x,\002N =\002,i5,\002,\002,10x,\002 type"
" \002,i2,\002, test(\002,i2,\002) = \002,g12.5)";
static char fmt_9997[] = "(\002 NORM ='\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) = \002,g12."
"5)";
static char fmt_9998[] = "(\002 TRANS='\002,a1,\002', N =\002,i5,\002, N"
"RHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) = \002,g"
"12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
/* Local variables */
integer i__, j, k, m, n;
doublereal z__[3];
integer in, kl, ku, ix, lda;
doublereal cond;
integer mode, koff, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char norm[1], type__[1];
integer nrun;
integer nfail, iseed[4];
doublereal rcond;
integer nimat;
doublereal anorm;
integer itran;
char trans[1];
integer izero, nerrs;
logical zerot;
doublereal rcondc;
doublereal rcondi;
doublereal rcondo;
doublereal ainvnm;
logical trfcon;
doublereal result[7];
/* Fortran I/O blocks */
static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKGT tests DGTTRF, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) DOUBLE PRECISION */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* A (workspace) DOUBLE PRECISION array, dimension (NMAX*4) */
/* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*4) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (2*NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--af;
--a;
--nsval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "GT", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
derrge_(path, nout);
}
infoc_1.infot = 0;
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
/* Do for each value of N in NVAL. */
n = nval[in];
/* Computing MAX */
i__2 = n - 1;
m = max(i__2,0);
lda = max(1,n);
nimat = 12;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L100;
}
/* Set up parameters with DLATB4. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Types 1-6: generate matrices of known condition number. */
/* Computing MAX */
i__3 = 2 - ku, i__4 = 3 - max(1,n);
koff = max(i__3,i__4);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "Z", &af[koff], &c__3, &work[1], &
info);
/* Check the error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
dcopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
dcopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
dcopy_(&n, &af[2], &c__3, &a[m + 1], &c__1);
} else {
/* Types 7-12: generate tridiagonal matrices with */
/* unknown condition numbers. */
if (! zerot || ! dotype[7]) {
/* Generate a matrix with elements from [-1,1]. */
i__3 = n + (m << 1);
dlarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.) {
i__3 = n + (m << 1);
dscal_(&i__3, &anorm, &a[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
a[n] = z__[1];
if (n > 1) {
a[1] = z__[2];
}
} else if (izero == n) {
a[n * 3 - 2] = z__[0];
a[(n << 1) - 1] = z__[1];
} else {
a[(n << 1) - 2 + izero] = z__[0];
a[n - 1 + izero] = z__[1];
a[izero] = z__[2];
}
}
/* If IMAT > 7, set one column of the matrix to 0. */
if (! zerot) {
izero = 0;
} else if (imat == 8) {
izero = 1;
z__[1] = a[n];
a[n] = 0.;
if (n > 1) {
z__[2] = a[1];
a[1] = 0.;
}
} else if (imat == 9) {
izero = n;
z__[0] = a[n * 3 - 2];
z__[1] = a[(n << 1) - 1];
a[n * 3 - 2] = 0.;
a[(n << 1) - 1] = 0.;
} else {
izero = (n + 1) / 2;
i__3 = n - 1;
for (i__ = izero; i__ <= i__3; ++i__) {
a[(n << 1) - 2 + i__] = 0.;
a[n - 1 + i__] = 0.;
a[i__] = 0.;
/* L20: */
}
a[n * 3 - 2] = 0.;
a[(n << 1) - 1] = 0.;
}
}
/* + TEST 1 */
/* Factor A as L*U and compute the ratio */
/* norm(L*U - A) / (n * norm(A) * EPS ) */
i__3 = n + (m << 1);
dcopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
s_copy(srnamc_1.srnamt, "DGTTRF", (ftnlen)32, (ftnlen)6);
dgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m << 1)
+ 1], &iwork[1], &info);
/* Check error code from DGTTRF. */
if (info != izero) {
alaerh_(path, "DGTTRF", &info, &izero, " ", &n, &n, &c__1, &
c__1, &c_n1, &imat, &nfail, &nerrs, nout);
}
trfcon = info != 0;
dgtt01_(&n, &a[1], &a[m + 1], &a[n + m + 1], &af[1], &af[m + 1], &
af[n + m + 1], &af[n + (m << 1) + 1], &iwork[1], &work[1],
&lda, &rwork[1], result);
/* Print the test ratio if it is .GE. THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(doublereal));
e_wsfe();
++nfail;
}
++nrun;
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran - 1]
;
if (itran == 1) {
*(unsigned char *)norm = 'O';
} else {
*(unsigned char *)norm = 'I';
}
anorm = dlangt_(norm, &n, &a[1], &a[m + 1], &a[n + m + 1]);
if (! trfcon) {
/* Use DGTTRS to solve for one column at a time of inv(A) */
/* or inv(A^T), computing the maximum column sum as we */
/* go. */
ainvnm = 0.;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
x[j] = 0.;
/* L30: */
}
x[i__] = 1.;
dgttrs_(trans, &n, &c__1, &af[1], &af[m + 1], &af[n +
m + 1], &af[n + (m << 1) + 1], &iwork[1], &x[
1], &lda, &info);
/* Computing MAX */
d__1 = ainvnm, d__2 = dasum_(&n, &x[1], &c__1);
ainvnm = max(d__1,d__2);
/* L40: */
}
/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
if (itran == 1) {
rcondo = rcondc;
} else {
rcondi = rcondc;
}
} else {
rcondc = 0.;
}
/* + TEST 7 */
/* Estimate the reciprocal of the condition number of the */
/* matrix. */
s_copy(srnamc_1.srnamt, "DGTCON", (ftnlen)32, (ftnlen)6);
dgtcon_(norm, &n, &af[1], &af[m + 1], &af[n + m + 1], &af[n +
(m << 1) + 1], &iwork[1], &anorm, &rcond, &work[1], &
iwork[n + 1], &info);
/* Check error code from DGTCON. */
if (info != 0) {
alaerh_(path, "DGTCON", &info, &c__0, norm, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[6] = dget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__7, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[6], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
/* L50: */
}
/* Skip the remaining tests if the matrix is singular. */
if (trfcon) {
goto L100;
}
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
/* Generate NRHS random solution vectors. */
ix = 1;
i__4 = nrhs;
for (j = 1; j <= i__4; ++j) {
dlarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L60: */
}
for (itran = 1; itran <= 3; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
if (itran == 1) {
rcondc = rcondo;
} else {
rcondc = rcondi;
}
/* Set the right hand side. */
dlagtm_(trans, &n, &nrhs, &c_b63, &a[1], &a[m + 1], &a[n
+ m + 1], &xact[1], &lda, &c_b64, &b[1], &lda);
/* + TEST 2 */
/* Solve op(A) * X = B and compute the residual. */
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "DGTTRS", (ftnlen)32, (ftnlen)6);
dgttrs_(trans, &n, &nrhs, &af[1], &af[m + 1], &af[n + m +
1], &af[n + (m << 1) + 1], &iwork[1], &x[1], &lda,
&info);
/* Check error code from DGTTRS. */
if (info != 0) {
alaerh_(path, "DGTTRS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
dgtt02_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&x[1], &lda, &work[1], &lda, &rwork[1], &result[
1]);
/* + TEST 3 */
/* Check solution from generated exact solution. */
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* + TESTS 4, 5, and 6 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "DGTRFS", (ftnlen)32, (ftnlen)6);
dgtrfs_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&af[1], &af[m + 1], &af[n + m + 1], &af[n + (m <<
1) + 1], &iwork[1], &b[1], &lda, &x[1], &lda, &
rwork[1], &rwork[nrhs + 1], &work[1], &iwork[n +
1], &info);
/* Check error code from DGTRFS. */
if (info != 0) {
alaerh_(path, "DGTRFS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
dgtt05_(trans, &n, &nrhs, &a[1], &a[m + 1], &a[n + m + 1],
&b[1], &lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &rwork[nrhs + 1], &result[4]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 2; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* L90: */
}
L100:
;
}
/* L110: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKGT */
} /* dchkgt_ */
/* DECK DTRCO */
/* Subroutine */ int dtrco_(doublereal *t, integer *ldt, integer *n,
doublereal *rcond, doublereal *z__, integer *job)
{
/* System generated locals */
integer t_dim1, t_offset, i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
static integer j, k, l;
static doublereal s, w;
static integer i1, j1, j2;
static doublereal ek;
static integer kk;
static doublereal sm, wk, wkm;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern doublereal dasum_(integer *, doublereal *, integer *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static logical lower;
static doublereal tnorm, ynorm;
/* ***BEGIN PROLOGUE DTRCO */
/* ***PURPOSE Estimate the condition number of a triangular matrix. */
/* ***LIBRARY SLATEC (LINPACK) */
/* ***CATEGORY D2A3 */
/* ***TYPE DOUBLE PRECISION (STRCO-S, DTRCO-D, CTRCO-C) */
/* ***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, */
/* TRIANGULAR MATRIX */
/* ***AUTHOR Moler, C. B., (U. of New Mexico) */
/* ***DESCRIPTION */
/* DTRCO estimates the condition of a double precision triangular */
/* matrix. */
/* On Entry */
/* T DOUBLE PRECISION(LDT,N) */
/* T contains the triangular matrix. The zero */
/* elements of the matrix are not referenced, and */
/* the corresponding elements of the array can be */
/* used to store other information. */
/* LDT INTEGER */
/* LDT is the leading dimension of the array T. */
/* N INTEGER */
/* N is the order of the system. */
/* JOB INTEGER */
/* = 0 T is lower triangular. */
/* = nonzero T is upper triangular. */
/* On Return */
/* RCOND DOUBLE PRECISION */
/* an estimate of the reciprocal condition of T . */
/* For the system T*X = B , relative perturbations */
/* in T and B of size EPSILON may cause */
/* relative perturbations in X of size EPSILON/RCOND . */
/* If RCOND is so small that the logical expression */
/* 1.0 + RCOND .EQ. 1.0 */
/* is true, then T may be singular to working */
/* precision. In particular, RCOND is zero if */
/* exact singularity is detected or the estimate */
/* underflows. */
/* Z DOUBLE PRECISION(N) */
/* a work vector whose contents are usually unimportant. */
/* If T is close to a singular matrix, then Z is */
/* an approximate null vector in the sense that */
/* NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED DASUM, DAXPY, DSCAL */
/* ***REVISION HISTORY (YYMMDD) */
/* 780814 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890831 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE DTRCO */
/* ***FIRST EXECUTABLE STATEMENT DTRCO */
/* Parameter adjustments */
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
--z__;
/* Function Body */
lower = *job == 0;
/* COMPUTE 1-NORM OF T */
tnorm = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
l = j;
if (lower) {
l = *n + 1 - j;
}
i1 = 1;
if (lower) {
i1 = j;
}
/* Computing MAX */
d__1 = tnorm, d__2 = dasum_(&l, &t[i1 + j * t_dim1], &c__1);
tnorm = max(d__1,d__2);
/* L10: */
}
/* RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) . */
/* ESTIMATE = NORM(Z)/NORM(Y) WHERE T*Z = Y AND TRANS(T)*Y = E . */
/* TRANS(T) IS THE TRANSPOSE OF T . */
/* THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL */
/* GROWTH IN THE ELEMENTS OF Y . */
/* THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. */
/* SOLVE TRANS(T)*Y = E */
ek = 1.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
z__[j] = 0.;
/* L20: */
}
i__1 = *n;
for (kk = 1; kk <= i__1; ++kk) {
k = kk;
if (lower) {
k = *n + 1 - kk;
}
if (z__[k] != 0.) {
d__1 = -z__[k];
ek = d_sign(&ek, &d__1);
}
if ((d__1 = ek - z__[k], abs(d__1)) <= (d__2 = t[k + k * t_dim1], abs(
d__2))) {
goto L30;
}
s = (d__1 = t[k + k * t_dim1], abs(d__1)) / (d__2 = ek - z__[k], abs(
d__2));
dscal_(n, &s, &z__[1], &c__1);
ek = s * ek;
L30:
wk = ek - z__[k];
wkm = -ek - z__[k];
s = abs(wk);
sm = abs(wkm);
if (t[k + k * t_dim1] == 0.) {
goto L40;
}
wk /= t[k + k * t_dim1];
wkm /= t[k + k * t_dim1];
goto L50;
L40:
wk = 1.;
wkm = 1.;
L50:
if (kk == *n) {
goto L90;
}
j1 = k + 1;
if (lower) {
j1 = 1;
}
j2 = *n;
if (lower) {
j2 = k - 1;
}
i__2 = j2;
for (j = j1; j <= i__2; ++j) {
sm += (d__1 = z__[j] + wkm * t[k + j * t_dim1], abs(d__1));
z__[j] += wk * t[k + j * t_dim1];
s += (d__1 = z__[j], abs(d__1));
/* L60: */
}
if (s >= sm) {
goto L80;
}
w = wkm - wk;
wk = wkm;
i__2 = j2;
for (j = j1; j <= i__2; ++j) {
z__[j] += w * t[k + j * t_dim1];
/* L70: */
}
L80:
L90:
z__[k] = wk;
/* L100: */
}
s = 1. / dasum_(n, &z__[1], &c__1);
dscal_(n, &s, &z__[1], &c__1);
ynorm = 1.;
/* SOLVE T*Z = Y */
i__1 = *n;
for (kk = 1; kk <= i__1; ++kk) {
k = *n + 1 - kk;
if (lower) {
k = kk;
}
if ((d__1 = z__[k], abs(d__1)) <= (d__2 = t[k + k * t_dim1], abs(d__2)
)) {
goto L110;
}
s = (d__1 = t[k + k * t_dim1], abs(d__1)) / (d__2 = z__[k], abs(d__2))
;
dscal_(n, &s, &z__[1], &c__1);
ynorm = s * ynorm;
L110:
if (t[k + k * t_dim1] != 0.) {
z__[k] /= t[k + k * t_dim1];
}
if (t[k + k * t_dim1] == 0.) {
z__[k] = 1.;
}
i1 = 1;
if (lower) {
i1 = k + 1;
}
if (kk >= *n) {
goto L120;
}
w = -z__[k];
i__2 = *n - kk;
daxpy_(&i__2, &w, &t[i1 + k * t_dim1], &c__1, &z__[i1], &c__1);
L120:
/* L130: */
;
}
/* MAKE ZNORM = 1.0 */
s = 1. / dasum_(n, &z__[1], &c__1);
dscal_(n, &s, &z__[1], &c__1);
ynorm = s * ynorm;
if (tnorm != 0.) {
*rcond = ynorm / tnorm;
}
if (tnorm == 0.) {
*rcond = 0.;
}
return 0;
} /* dtrco_ */
/* Subroutine */ int dlacon_(integer *n, doublereal *v, doublereal *x,
integer *isgn, doublereal *est, integer *kase)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DLACON estimates the 1-norm of a square, real matrix A.
Reverse communication is used for evaluating matrix-vector products.
Arguments
=========
N (input) INTEGER
The order of the matrix. N >= 1.
V (workspace) DOUBLE PRECISION array, dimension (N)
On the final return, V = A*W, where EST = norm(V)/norm(W)
(W is not returned).
X (input/output) DOUBLE PRECISION array, dimension (N)
On an intermediate return, X should be overwritten by
A * X, if KASE=1,
A' * X, if KASE=2,
and DLACON must be re-called with all the other parameters
unchanged.
ISGN (workspace) INTEGER array, dimension (N)
EST (output) DOUBLE PRECISION
An estimate (a lower bound) for norm(A).
KASE (input/output) INTEGER
On the initial call to DLACON, KASE should be 0.
On an intermediate return, KASE will be 1 or 2, indicating
whether X should be overwritten by A * X or A' * X.
On the final return from DLACON, KASE will again be 0.
Further Details
======= =======
Contributed by Nick Higham, University of Manchester.
Originally named SONEST, dated March 16, 1988.
Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
a real or complex matrix, with applications to condition estimation",
ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static doublereal c_b11 = 1.;
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
integer i_dnnt(doublereal *);
/* Local variables */
static integer iter;
static doublereal temp;
static integer jump, i, j;
extern doublereal dasum_(integer *, doublereal *, integer *);
static integer jlast;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
static doublereal altsgn, estold;
#define ISGN(I) isgn[(I)-1]
#define X(I) x[(I)-1]
#define V(I) v[(I)-1]
if (*kase == 0) {
i__1 = *n;
for (i = 1; i <= *n; ++i) {
X(i) = 1. / (doublereal) (*n);
/* L10: */
}
*kase = 1;
jump = 1;
return 0;
}
switch (jump) {
case 1: goto L20;
case 2: goto L40;
case 3: goto L70;
case 4: goto L110;
case 5: goto L140;
}
/* ................ ENTRY (JUMP = 1)
FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
L20:
if (*n == 1) {
V(1) = X(1);
*est = abs(V(1));
/* ... QUIT */
goto L150;
}
*est = dasum_(n, &X(1), &c__1);
i__1 = *n;
for (i = 1; i <= *n; ++i) {
X(i) = d_sign(&c_b11, &X(i));
ISGN(i) = i_dnnt(&X(i));
/* L30: */
}
*kase = 2;
jump = 2;
return 0;
/* ................ ENTRY (JUMP = 2)
FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. */
L40:
j = idamax_(n, &X(1), &c__1);
iter = 2;
/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
L50:
i__1 = *n;
for (i = 1; i <= *n; ++i) {
X(i) = 0.;
/* L60: */
}
X(j) = 1.;
*kase = 1;
jump = 3;
return 0;
/* ................ ENTRY (JUMP = 3)
X HAS BEEN OVERWRITTEN BY A*X. */
L70:
dcopy_(n, &X(1), &c__1, &V(1), &c__1);
estold = *est;
*est = dasum_(n, &V(1), &c__1);
i__1 = *n;
for (i = 1; i <= *n; ++i) {
d__1 = d_sign(&c_b11, &X(i));
if (i_dnnt(&d__1) != ISGN(i)) {
goto L90;
}
/* L80: */
}
/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
goto L120;
L90:
/* TEST FOR CYCLING. */
if (*est <= estold) {
goto L120;
}
i__1 = *n;
for (i = 1; i <= *n; ++i) {
X(i) = d_sign(&c_b11, &X(i));
ISGN(i) = i_dnnt(&X(i));
/* L100: */
}
*kase = 2;
jump = 4;
return 0;
/* ................ ENTRY (JUMP = 4)
X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. */
L110:
jlast = j;
j = idamax_(n, &X(1), &c__1);
if (X(jlast) != (d__1 = X(j), abs(d__1)) && iter < 5) {
++iter;
goto L50;
}
/* ITERATION COMPLETE. FINAL STAGE. */
L120:
altsgn = 1.;
i__1 = *n;
for (i = 1; i <= *n; ++i) {
X(i) = altsgn * ((doublereal) (i - 1) / (doublereal) (*n - 1) + 1.);
altsgn = -altsgn;
/* L130: */
}
*kase = 1;
jump = 5;
return 0;
/* ................ ENTRY (JUMP = 5)
X HAS BEEN OVERWRITTEN BY A*X. */
L140:
temp = dasum_(n, &X(1), &c__1) / (doublereal) (*n * 3) * 2.;
if (temp > *est) {
dcopy_(n, &X(1), &c__1, &V(1), &c__1);
*est = temp;
}
L150:
*kase = 0;
return 0;
/* End of DLACON */
} /* dlacon_ */
/* Subroutine */ int dlatdf_(integer *ijob, integer *n, doublereal *z__,
integer *ldz, doublereal *rhs, doublereal *rdsum, doublereal *rdscal,
integer *ipiv, integer *jpiv)
{
/* -- LAPACK auxiliary 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
=======
DLATDF uses the LU factorization of the n-by-n matrix Z computed by
DGETC2 and computes a contribution to the reciprocal Dif-estimate
by solving Z * x = b for x, and choosing the r.h.s. b such that
the norm of x is as large as possible. On entry RHS = b holds the
contribution from earlier solved sub-systems, and on return RHS = x.
The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q,
where P and Q are permutation matrices. L is lower triangular with
unit diagonal elements and U is upper triangular.
Arguments
=========
IJOB (input) INTEGER
IJOB = 2: First compute an approximative null-vector e
of Z using DGECON, e is normalized and solve for
Zx = +-e - f with the sign giving the greater value
of 2-norm(x). About 5 times as expensive as Default.
IJOB .ne. 2: Local look ahead strategy where all entries of
the r.h.s. b is choosen as either +1 or -1 (Default).
N (input) INTEGER
The number of columns of the matrix Z.
Z (input) DOUBLE PRECISION array, dimension (LDZ, N)
On entry, the LU part of the factorization of the n-by-n
matrix Z computed by DGETC2: Z = P * L * U * Q
LDZ (input) INTEGER
The leading dimension of the array Z. LDA >= max(1, N).
RHS (input/output) DOUBLE PRECISION array, dimension N.
On entry, RHS contains contributions from other subsystems.
On exit, RHS contains the solution of the subsystem with
entries acoording to the value of IJOB (see above).
RDSUM (input/output) DOUBLE PRECISION
On entry, the sum of squares of computed contributions to
the Dif-estimate under computation by DTGSYL, where the
scaling factor RDSCAL (see below) has been factored out.
On exit, the corresponding sum of squares updated with the
contributions from the current sub-system.
If TRANS = 'T' RDSUM is not touched.
NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL.
RDSCAL (input/output) DOUBLE PRECISION
On entry, scaling factor used to prevent overflow in RDSUM.
On exit, RDSCAL is updated w.r.t. the current contributions
in RDSUM.
If TRANS = 'T', RDSCAL is not touched.
NOTE: RDSCAL only makes sense when DTGSY2 is called by
DTGSYL.
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).
Further Details
===============
Based on contributions by
Bo Kagstrom and Peter Poromaa, Department of Computing Science,
Umea University, S-901 87 Umea, Sweden.
This routine is a further developed implementation of algorithm
BSOLVE in [1] using complete pivoting in the LU factorization.
[1] Bo Kagstrom and Lars Westin,
Generalized Schur Methods with Condition Estimators for
Solving the Generalized Sylvester Equation, IEEE Transactions
on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.
[2] Peter Poromaa,
On Efficient and Robust Estimators for the Separation
between two Regular Matrix Pairs with Applications in
Condition Estimation. Report IMINF-95.05, Departement of
Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b23 = 1.;
static doublereal c_b37 = -1.;
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static integer info;
static doublereal temp, work[32];
static integer i__, j, k;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern doublereal dasum_(integer *, doublereal *, integer *);
static doublereal pmone;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static doublereal sminu;
static integer iwork[8];
static doublereal splus;
extern /* Subroutine */ int dgesc2_(integer *, doublereal *, integer *,
doublereal *, integer *, integer *, doublereal *);
static doublereal bm, bp;
extern /* Subroutine */ int dgecon_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
integer *);
static doublereal xm[8], xp[8];
extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *,
doublereal *, doublereal *), dlaswp_(integer *, doublereal *,
integer *, integer *, integer *, integer *, integer *);
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--rhs;
--ipiv;
--jpiv;
/* Function Body */
if (*ijob != 2) {
/* Apply permutations IPIV to RHS */
i__1 = *n - 1;
dlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1);
/* Solve for L-part choosing RHS either to +1 or -1. */
pmone = -1.;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
bp = rhs[j] + 1.;
bm = rhs[j] - 1.;
splus = 1.;
/* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and
SMIN computed more efficiently than in BSOLVE [1]. */
i__2 = *n - j;
splus += ddot_(&i__2, &z___ref(j + 1, j), &c__1, &z___ref(j + 1,
j), &c__1);
i__2 = *n - j;
sminu = ddot_(&i__2, &z___ref(j + 1, j), &c__1, &rhs[j + 1], &
c__1);
splus *= rhs[j];
if (splus > sminu) {
rhs[j] = bp;
} else if (sminu > splus) {
rhs[j] = bm;
} else {
/* In this case the updating sums are equal and we can
choose RHS(J) +1 or -1. The first time this happens
we choose -1, thereafter +1. This is a simple way to
get good estimates of matrices like Byers well-known
example (see [1]). (Not done in BSOLVE.) */
rhs[j] += pmone;
pmone = 1.;
}
/* Compute the remaining r.h.s. */
temp = -rhs[j];
i__2 = *n - j;
daxpy_(&i__2, &temp, &z___ref(j + 1, j), &c__1, &rhs[j + 1], &
c__1);
/* L10: */
}
/* Solve for U-part, look-ahead for RHS(N) = +-1. This is not done
in BSOLVE and will hopefully give us a better estimate because
any ill-conditioning of the original matrix is transfered to U
and not to L. U(N, N) is an approximation to sigma_min(LU). */
i__1 = *n - 1;
dcopy_(&i__1, &rhs[1], &c__1, xp, &c__1);
xp[*n - 1] = rhs[*n] + 1.;
rhs[*n] += -1.;
splus = 0.;
sminu = 0.;
for (i__ = *n; i__ >= 1; --i__) {
temp = 1. / z___ref(i__, i__);
xp[i__ - 1] *= temp;
rhs[i__] *= temp;
i__1 = *n;
for (k = i__ + 1; k <= i__1; ++k) {
xp[i__ - 1] -= xp[k - 1] * (z___ref(i__, k) * temp);
rhs[i__] -= rhs[k] * (z___ref(i__, k) * temp);
/* L20: */
}
splus += (d__1 = xp[i__ - 1], abs(d__1));
sminu += (d__1 = rhs[i__], abs(d__1));
/* L30: */
}
if (splus > sminu) {
dcopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Apply the permutations JPIV to the computed solution (RHS) */
i__1 = *n - 1;
dlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1);
/* Compute the sum of squares */
dlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
} else {
/* IJOB = 2, Compute approximate nullvector XM of Z */
dgecon_("I", n, &z__[z_offset], ldz, &c_b23, &temp, work, iwork, &
info);
dcopy_(n, &work[*n], &c__1, xm, &c__1);
/* Compute RHS */
i__1 = *n - 1;
dlaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1);
temp = 1. / sqrt(ddot_(n, xm, &c__1, xm, &c__1));
dscal_(n, &temp, xm, &c__1);
dcopy_(n, xm, &c__1, xp, &c__1);
daxpy_(n, &c_b23, &rhs[1], &c__1, xp, &c__1);
daxpy_(n, &c_b37, xm, &c__1, &rhs[1], &c__1);
dgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &temp);
dgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &temp);
if (dasum_(n, xp, &c__1) > dasum_(n, &rhs[1], &c__1)) {
dcopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Compute the sum of squares */
dlassq_(n, &rhs[1], &c__1, rdscal, rdsum);
}
return 0;
/* End of DLATDF */
} /* dlatdf_ */
void main1_()
{
/*
for xpress.com
*/
static Integer three = (Integer) 3, IONE = (Integer) 1;
static Integer IZERO = (Integer) 0;
static DoublePrecision DZERO = (DoublePrecision) 0.0e0;
Integer index;
Integer nocare_, norder_, nonode_, ihost_, ialnod_, ialprc_;
Integer me_, host_, nproc_;
char range, order;
Integer n, ii, me, indx, k, i, jndx, iii;
Integer iseed[4];
Integer *mapA, *mapB, *mapZ;
Integer *mapvecA, *mapvecB, *mapvecZ;
Integer *iscratch;
DoublePrecision **iptr;
Integer is_size, rsize, ptr_size;
Integer nprocs, isize;
Integer info;
DoublePrecision *scratch, *eval, *dptr;
DoublePrecision *diagA, *subdiagA, *diagB, *subdiagB;
DoublePrecision *matrixA, *matrixB, *matrixZ;
DoublePrecision **vecA, **vecB, **vecZ;
DoublePrecision **vecAA, **vecBB, **vecZZ;
DoublePrecision res, t_com;
DoublePrecision time1, time2;
DoublePrecision mxclock_();
#ifdef TIMING
extern TIMINGG test_timing;
#endif
static Integer countlist();
extern void geneig_res();
extern void b_ortho();
extern void tim_com();
extern void mxend_();
extern void mxinit_(), mxtime_();
extern void mxpara_();
extern Integer mxnprc_();
extern Integer mxmynd_();
extern void memreq_();
extern Integer nnodes_();
extern Integer ci_size_();
extern void pdsygv_();
extern DoublePrecision dlarnd_();
extern DoublePrecision dasum_();
extern DoublePrecision fabs();
/*
extern char malloc();
*/
extern void dspgv2_();
mxinit_();
me = mxmynd_();
nprocs = mxnprc_();
#ifdef TIMING
test_timing.choleski = 0.0e0;
test_timing.inverse = 0.0e0;
test_timing.conjug = 0.0e0;
test_timing.householder = 0.0e0;
test_timing.pstebz = 0.0e0;
test_timing.pstein = 0.0e0;
test_timing.mxm5x = 0.0e0;
test_timing.mxm25 = 0.0e0;
test_timing.pdspevx = 0.0e0;
test_timing.pdspgvx = 0.0e0;
#endif
k = 0;
n = 500;
diagA = (DoublePrecision *) malloc( n * sizeof(DoublePrecision));
subdiagA = (DoublePrecision *) malloc( n * sizeof(DoublePrecision));
diagB = (DoublePrecision *) malloc( n * sizeof(DoublePrecision));
subdiagB = (DoublePrecision *) malloc( n * sizeof(DoublePrecision));
if( diagA == NULL || subdiagA == NULL || diagB == NULL || subdiagB == NULL ) {
fprintf(stderr, " me = %d: ERROR not enough memory for diagA or subdiagA, ...\n",
me );
exit(-1);
}
iscratch = (Integer *) malloc ( (4*n + 100) * sizeof(Integer));
if ((mapA = (Integer *) malloc( n * sizeof(Integer))) == NULL ) {
fprintf(stderr, " me = %d: ERROR not enough memory for mapA %d \n", me, n );
exit(-1);
}
if ((mapB = (Integer *) malloc( n * sizeof(Integer))) == NULL ) {
fprintf(stderr, " me = %d: ERROR in memory allocation, not enough memory for mapB \n");
exit(-1);
}
if ((mapZ = (Integer *) malloc( n * sizeof(Integer))) == NULL ) {
fprintf(stderr, " ERROR in memory allocation, not enough memory for mapZ \n");
exit(-1);
}
/*
set the column mapping of processors
*/
for ( ii = 0; ii < n; ii++ ) {
indx = ( ii % nprocs);
mapA[ii] = 0;
mapB[ii] = 0;
}
for ( ii = 0 ; ii < n; ii++ ) {
indx = ( ii % nprocs);
mapZ[ii] = 0;
}
/*
if ( nprocs > 2 ) {
mapZ[0] = nprocs-1;
for ( ii = 1; ii < n; ii++) {
indx = ( ii % (nprocs - 1));
mapZ[ii] = indx;
}
}
else {
for ( ii = 0; ii < n; ii++) {
indx = ( ii % nprocs );
mapZ[ii] = indx;
}
}
*/
for ( i = 0; i < 3; i++ )
iseed[i] = 1;
iseed[3] = 2*me*100 + 3;
/*
for symmetric matrix with this data distribution
*/
ii = ci_size_( &me, &n, mapA );
if ( ii > 0 ) {
if ( (matrixA = (DoublePrecision *) malloc( ii * sizeof(DoublePrecision))) == NULL ) {
fprintf(stderr, " me %d ERROR in memory allocation, not enough memory for matrixA memory size = %d \n", me, ii);
exit(-1);
}
}
dptr = matrixA;
for ( indx = 0; indx < ii; indx++ ) {
*( dptr++ ) = 0.0e0;
}
ii = countlist ( me, mapA, &n );
if ( ii > 0 ) {
if ( ( vecA = ( DoublePrecision ** ) malloc ( ii * sizeof(DoublePrecision *))) == NULL ) {
fprintf(stderr, "me = %d: ERROR in memory allocation, not enough memory for vecA %d \n", me, ii );
exit(-1);
}
}
else {
if ( ( vecA = ( DoublePrecision ** ) malloc ( n * sizeof(DoublePrecision *))) == NULL ) {
fprintf(stderr, "me = %d: ERROR in memory allocation, not enough memory for vecA %d \n", me, n );
exit(-1);
}
}
i = 0;
dptr = matrixA;
for ( indx = 0; indx < n; indx++ ) {
if ( mapA[indx] == me ) {
vecA[i] = dptr;
i++;
dptr += ( n - indx);
}
}
i = 0;
for ( indx = 0; indx < n; indx++ ){
/*
* A is symmetric, tri-diagonal. Set diagA, subdiagA equal
* to diagonal and subdiagonal parts of matrix.
* diagA and subdiagA are used to compute residual.
*/
diagA[indx] = 1.0/( indx + 1 );
subdiagA[indx] = -1.0e0;
if ( mapA[indx] == me ) {
vecA[i][0] = 1.0/( indx + 1 );
if ( indx != (n-1))
vecA[i][1] = -1.0e0;
i++;
}
}
subdiagA[0] = 0.0e0;
ii = ci_size_( &me, &n, mapB );
if ( (matrixB = (DoublePrecision *) malloc( ii * sizeof(DoublePrecision))) == NULL ) {
fprintf(stderr, " me %d ERROR in memory allocation, not enough memory for matrixB \n", me);
exit(-1);
}
zero_out ( ii, matrixB);
dptr = matrixB;
for ( indx = 0; indx < ii; indx++ ) {
*( dptr++ ) = 0.0e0;
}
ii = countlist ( me, mapB, &n );
if ( ( vecB = ( DoublePrecision ** ) malloc ( ii * sizeof(DoublePrecision *))) == NULL ) {
fprintf(stderr, "me = %d: ERROR in memory allocation, not enough memory for vecA \n", me);
exit(-1);
}
i = 0;
dptr = matrixB;
for ( indx = 0; indx < n; indx++ ) {
/*
* B is symmetric, tri-diagonal. Set diagB, subdiagB equal
* to diagonal and subdiagonal parts of matrix.
* diagB and subdiagB are used to compute residual.
*/
diagB[indx] = 20.0e0;
subdiagB[indx] = -1.0e0;
if ( mapB[indx] == me ) { /* column */
vecB[i] = dptr;
vecB[i][0] = 20.0e0;
if ( indx != ( n-1))
vecB[i][1]= -1.0e0;
dptr += ( n-indx);
i++;
}
}
subdiagB[0] = 0.0e0;
/*
use the utility routine count_list to determine the number of columns of Z that are stored
on this processor using the above distribution
*/
ii = countlist ( me, mapZ, &n );
if ( ( vecZ = ( DoublePrecision ** ) malloc ( ii * sizeof(DoublePrecision *))) == NULL ) {
fprintf(stderr, "me = %d: ERROR in memory allocation, not enough memory for vecA allocation = %d \n", me, ii);
exit(-1);
}
if ( (matrixZ = (DoublePrecision *) malloc( ii * n * sizeof(DoublePrecision))) == NULL ) {
fprintf(stderr, "me = %d: ERROR in memory allocation, not enough memory for matrixZ \n", me);
exit(-1);
}
dptr = matrixZ;
i = ii*n;
zero_out( i, matrixZ );
dptr = matrixZ;
k = 0;
for ( i = 0; i < ii; i++ ) {
vecZ[i] = dptr;
dptr += n;
}
if ( (eval = (DoublePrecision *) malloc( n * sizeof(DoublePrecision ))) == NULL ) {
fprintf(stderr, "me = %d: ERROR in memory allocation, not enough memory for eigenvalue space \n", me);
exit(-1);
}
index = 0;
/*
* fprintf(stderr, "me = %d: just before memreq \n", me);
*/
rsize = 0;
isize = 0;
ptr_size = 0;
/*
for ( iii = 0; iii < n; iii++ )
fprintf(stderr, " me = %ld iii = %ld mapA = %ld mapB = %ld mapZ = %ld \n", me, iii, mapA[iii], mapB[iii], mapZ[iii]);
*/
memreq_( &index, &n, mapA, mapB, mapZ, &isize, &rsize, &ptr_size, iscratch );
/*
* fprintf(stderr, "me = %d: just after memreq isize = %d rsize = %d ptr_size %d \n", me, isize, rsize, ptr_size);
*/
free(iscratch);
if ( (iscratch = (Integer *) malloc( 2*isize * sizeof(Integer))) == NULL ) {
fprintf(stderr, " me = %d ERROR in memory allocation, not enough memory for integer scratch space \n", me);
exit(-1);
}
rsize = 2 * rsize;
if ( (scratch = (DoublePrecision *) malloc( rsize * sizeof(DoublePrecision))) == NULL ) {
fprintf(stderr, " me %d ERROR in memory allocation, not enough memory for DoublePrecision scratch space \n", me);
exit(-1);
}
if ( (iptr = (DoublePrecision **) malloc( 2*ptr_size * sizeof(DoublePrecision *))) == NULL ) {
fprintf(stderr, " me %d ERROR in memory allocation, not enough memory for pointer scratch space \n", me);
exit(-1);
}
mxsync_();
if( me == 0 )
fprintf(stderr, " geneig_la \n" );
#ifdef TIMING
mxsync_();
time1 = mxclock_();
#endif
time1 = mxclock_();
/*
* indx = 1;
* for ( iii = 0; iii < 1; iii++ ){
* mxtime_( &IZERO, &t_com );
* pdspgv ( &indx, &n, vecA, mapA, vecB, mapB, vecZ, mapZ, eval, iscratch,
* &isize, iptr, &ptr_size ,scratch, &rsize, &info);
* }
*/
indx = 1;
range = 'V';
order = 'L';
dspgv2_( &indx, &range, &order, &n, matrixA, matrixB, eval, matrixZ, &n,
scratch, iscratch, &info);
fflush(stdout);
#ifdef TIMING
mxsync_();
test_timing.pdspgvx = mxclock_() - time1;
mxtime_( &IONE, &t_com );
ii = 0;
if ( n < 30 ){
if ( info == 0 ) {
for ( k = 0; k < n; k++ ) {
if ( mapZ[k] == me ) {
*scratch = dasum_( &n , vecZ[ii], &IONE );
ii++;
}
}
}
}
if (me == 0 ){
fprintf(stderr, " n = %d nprocs = %d \n", n, nprocs);
fprintf(stderr, " pdspgvx = %f \n", test_timing.pdspgvx);
}
#endif
geneig_res( &n, diagA, subdiagA, diagB, subdiagB, vecZ, mapZ, eval,
iscratch, scratch, &res, &info);
if (me == 0 )
fprintf(stderr, " A Z - D B Z residual = %g \n", res);
i = 0;
for ( indx = 0; indx < n; indx++ ) {
if ( mapB[indx] == me ) {
ii = n-indx;
zero_out( ii, vecB[i] );
vecB[i][0] = 20.0e0;
if ( indx != ( n-1))
vecB[i][1]= -1.0e0;
i++;
}
}
mxsync_();
b_ortho( &n, vecB, mapB, &n, vecZ, mapZ, iptr, iscratch, scratch, &res, &info);
if( me == 0 )
fprintf(stderr, " Z' B Z - I residual = %g \n", res);
ii = 0;
if ( n < 30 ){
if ( info == 0 ) {
for ( k = 0; k < n; k++ ) {
if ( mapZ[k] == me ) {
*scratch = dasum_( &n , vecZ[ii], &IONE );
ii++;
}
}
}
}
free(iptr);
free(scratch);
free(iscratch);
free(eval);
free(matrixZ);
free(vecZ);
free(vecB);
free(matrixB);
free(vecA);
free(matrixA);
free(mapZ);
free(mapB);
free(mapA);
return;
/*
mxpend_();
*/
}
doublereal dqrt12_(integer *m, integer *n, doublereal *a, integer *lda,
doublereal *s, doublereal *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal ret_val;
/* Local variables */
integer i__, j, mn, iscl, info;
doublereal anrm;
extern doublereal dnrm2_(integer *, doublereal *, integer *), dasum_(
integer *, doublereal *, integer *);
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), dgebd2_(integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *
, doublereal *, doublereal *, integer *);
doublereal dummy[1];
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *), dlaset_(char *, integer *, integer
*, doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dbdsqr_(char *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *);
doublereal bignum, smlnum, nrmsvl;
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DQRT12 computes the singular values `svlues' of the upper trapezoid */
/* of A(1:M,1:N) and returns the ratio */
/* || s - svlues||/(||svlues||*eps*max(M,N)) */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The M-by-N matrix A. Only the upper trapezoid is referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* S (input) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The singular values of the matrix A. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= max(M*N + 4*min(M,N) + */
/* max(M,N), M*N+2*MIN( M, N )+4*N). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--s;
--work;
/* Function Body */
ret_val = 0.;
/* Test that enough workspace is supplied */
/* Computing MAX */
i__1 = *m * *n + (min(*m,*n) << 2) + max(*m,*n), i__2 = *m * *n + (min(*m,
*n) << 1) + (*n << 2);
if (*lwork < max(i__1,i__2)) {
xerbla_("DQRT12", &c__7);
return ret_val;
}
/* Quick return if possible */
mn = min(*m,*n);
if ((doublereal) mn <= 0.) {
return ret_val;
}
nrmsvl = dnrm2_(&mn, &s[1], &c__1);
/* Copy upper triangle of A into work */
dlaset_("Full", m, n, &c_b6, &c_b6, &work[1], m);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = min(j,*m);
for (i__ = 1; i__ <= i__2; ++i__) {
work[(j - 1) * *m + i__] = a[i__ + j * a_dim1];
/* L10: */
}
/* L20: */
}
/* Get machine parameters */
smlnum = dlamch_("S") / dlamch_("P");
bignum = 1. / smlnum;
dlabad_(&smlnum, &bignum);
/* Scale work if max entry outside range [SMLNUM,BIGNUM] */
anrm = dlange_("M", m, n, &work[1], m, dummy);
iscl = 0;
if (anrm > 0. && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &work[1], m, &info);
iscl = 1;
} else if (anrm > bignum) {
/* Scale matrix norm down to BIGNUM */
dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &work[1], m, &info);
iscl = 1;
}
if (anrm != 0.) {
/* Compute SVD of work */
dgebd2_(m, n, &work[1], m, &work[*m * *n + 1], &work[*m * *n + mn + 1]
, &work[*m * *n + (mn << 1) + 1], &work[*m * *n + mn * 3 + 1],
&work[*m * *n + (mn << 2) + 1], &info);
dbdsqr_("Upper", &mn, &c__0, &c__0, &c__0, &work[*m * *n + 1], &work[*
m * *n + mn + 1], dummy, &mn, dummy, &c__1, dummy, &mn, &work[
*m * *n + (mn << 1) + 1], &info);
if (iscl == 1) {
if (anrm > bignum) {
dlascl_("G", &c__0, &c__0, &bignum, &anrm, &mn, &c__1, &work[*
m * *n + 1], &mn, &info);
}
if (anrm < smlnum) {
dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &mn, &c__1, &work[*
m * *n + 1], &mn, &info);
}
}
} else {
i__1 = mn;
for (i__ = 1; i__ <= i__1; ++i__) {
work[*m * *n + i__] = 0.;
/* L30: */
}
}
/* Compare s and singular values of work */
daxpy_(&mn, &c_b33, &s[1], &c__1, &work[*m * *n + 1], &c__1);
ret_val = dasum_(&mn, &work[*m * *n + 1], &c__1) / (dlamch_("Epsilon") * (doublereal) max(*m,*n));
if (nrmsvl != 0.) {
ret_val /= nrmsvl;
}
return ret_val;
/* End of DQRT12 */
} /* dqrt12_ */
/* Subroutine */ int dlacon_(integer *n, doublereal *v, doublereal *x,
integer *isgn, doublereal *est, integer *kase)
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
integer i_dnnt(doublereal *);
/* Local variables */
static integer i__, j, iter;
static doublereal temp;
static integer jump;
extern doublereal dasum_(integer *, doublereal *, integer *);
static integer jlast;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
static doublereal altsgn, estold;
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* February 29, 1992 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLACON estimates the 1-norm of a square, real matrix A. */
/* Reverse communication is used for evaluating matrix-vector products. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 1. */
/* V (workspace) DOUBLE PRECISION array, dimension (N) */
/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
/* (W is not returned). */
/* X (input/output) DOUBLE PRECISION array, dimension (N) */
/* On an intermediate return, X should be overwritten by */
/* A * X, if KASE=1, */
/* A' * X, if KASE=2, */
/* and DLACON must be re-called with all the other parameters */
/* unchanged. */
/* ISGN (workspace) INTEGER array, dimension (N) */
/* EST (output) DOUBLE PRECISION */
/* An estimate (a lower bound) for norm(A). */
/* KASE (input/output) INTEGER */
/* On the initial call to DLACON, KASE should be 0. */
/* On an intermediate return, KASE will be 1 or 2, indicating */
/* whether X should be overwritten by A * X or A' * X. */
/* On the final return from DLACON, KASE will again be 0. */
/* Further Details */
/* ======= ======= */
/* Contributed by Nick Higham, University of Manchester. */
/* Originally named SONEST, dated March 16, 1988. */
/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
/* a real or complex matrix, with applications to condition estimation", */
/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Save statement .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--isgn;
--x;
--v;
/* Function Body */
if (*kase == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 1. / (doublereal) (*n);
/* L10: */
}
*kase = 1;
jump = 1;
return 0;
}
switch (jump) {
case 1: goto L20;
case 2: goto L40;
case 3: goto L70;
case 4: goto L110;
case 5: goto L140;
}
/* ................ ENTRY (JUMP = 1) */
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
L20:
if (*n == 1) {
v[1] = x[1];
*est = abs(v[1]);
/* ... QUIT */
goto L150;
}
*est = dasum_(n, &x[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = d_sign(&c_b11, &x[i__]);
isgn[i__] = i_dnnt(&x[i__]);
/* L30: */
}
*kase = 2;
jump = 2;
return 0;
/* ................ ENTRY (JUMP = 2) */
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. */
L40:
j = idamax_(n, &x[1], &c__1);
iter = 2;
/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
L50:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 0.;
/* L60: */
}
x[j] = 1.;
*kase = 1;
jump = 3;
return 0;
/* ................ ENTRY (JUMP = 3) */
/* X HAS BEEN OVERWRITTEN BY A*X. */
L70:
dcopy_(n, &x[1], &c__1, &v[1], &c__1);
estold = *est;
*est = dasum_(n, &v[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__1 = d_sign(&c_b11, &x[i__]);
if (i_dnnt(&d__1) != isgn[i__]) {
goto L90;
}
/* L80: */
}
/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
goto L120;
L90:
/* TEST FOR CYCLING. */
if (*est <= estold) {
goto L120;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = d_sign(&c_b11, &x[i__]);
isgn[i__] = i_dnnt(&x[i__]);
/* L100: */
}
*kase = 2;
jump = 4;
return 0;
/* ................ ENTRY (JUMP = 4) */
/* X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. */
L110:
jlast = j;
j = idamax_(n, &x[1], &c__1);
if (x[jlast] != (d__1 = x[j], abs(d__1)) && iter < 5) {
++iter;
goto L50;
}
/* ITERATION COMPLETE. FINAL STAGE. */
L120:
altsgn = 1.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) +
1.);
altsgn = -altsgn;
/* L130: */
}
*kase = 1;
jump = 5;
return 0;
/* ................ ENTRY (JUMP = 5) */
/* X HAS BEEN OVERWRITTEN BY A*X. */
L140:
temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.;
if (temp > *est) {
dcopy_(n, &x[1], &c__1, &v[1], &c__1);
*est = temp;
}
L150:
*kase = 0;
return 0;
/* End of DLACON */
} /* dlacon_ */
/* Subroutine */ int dqrt15_(integer *scale, integer *rksel, integer *m,
integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b,
integer *ldb, doublereal *s, integer *rank, doublereal *norma,
doublereal *normb, integer *iseed, doublereal *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
static integer info;
static doublereal temp;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer j;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dlarf_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *), dgemm_(char *, char *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
extern doublereal dasum_(integer *, doublereal *, integer *);
static doublereal dummy[1];
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
static integer mn;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
extern doublereal dlarnd_(integer *, integer *);
extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *,
integer *), dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *);
static doublereal bignum;
extern /* Subroutine */ int dlaror_(char *, char *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *), dlarnv_(integer *, integer *, integer *,
doublereal *);
static doublereal smlnum, eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
/* -- LAPACK test 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
=======
DQRT15 generates a matrix with full or deficient rank and of various
norms.
Arguments
=========
SCALE (input) INTEGER
SCALE = 1: normally scaled matrix
SCALE = 2: matrix scaled up
SCALE = 3: matrix scaled down
RKSEL (input) INTEGER
RKSEL = 1: full rank matrix
RKSEL = 2: rank-deficient matrix
M (input) INTEGER
The number of rows of the matrix A.
N (input) INTEGER
The number of columns of A.
NRHS (input) INTEGER
The number of columns of B.
A (output) DOUBLE PRECISION array, dimension (LDA,N)
The M-by-N matrix A.
LDA (input) INTEGER
The leading dimension of the array A.
B (output) DOUBLE PRECISION array, dimension (LDB, NRHS)
A matrix that is in the range space of matrix A.
LDB (input) INTEGER
The leading dimension of the array B.
S (output) DOUBLE PRECISION array, dimension MIN(M,N)
Singular values of A.
RANK (output) INTEGER
number of nonzero singular values of A.
NORMA (output) DOUBLE PRECISION
one-norm of A.
NORMB (output) DOUBLE PRECISION
one-norm of B.
ISEED (input/output) integer array, dimension (4)
seed for random number generator.
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
LWORK (input) INTEGER
length of work space required.
LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--s;
--iseed;
--work;
/* Function Body */
mn = min(*m,*n);
/* Computing MAX */
i__1 = *m + mn, i__2 = mn * *nrhs, i__1 = max(i__1,i__2), i__2 = (*n << 1)
+ *m;
if (*lwork < max(i__1,i__2)) {
xerbla_("DQRT15", &c__16);
return 0;
}
smlnum = dlamch_("Safe minimum");
bignum = 1. / smlnum;
eps = dlamch_("Epsilon");
smlnum = smlnum / eps / eps;
bignum = 1. / smlnum;
/* Determine rank and (unscaled) singular values */
if (*rksel == 1) {
*rank = mn;
} else if (*rksel == 2) {
*rank = mn * 3 / 4;
i__1 = mn;
for (j = *rank + 1; j <= i__1; ++j) {
s[j] = 0.;
/* L10: */
}
} else {
xerbla_("DQRT15", &c__2);
}
if (*rank > 0) {
/* Nontrivial case */
s[1] = 1.;
i__1 = *rank;
for (j = 2; j <= i__1; ++j) {
L20:
temp = dlarnd_(&c__1, &iseed[1]);
if (temp > .1) {
s[j] = abs(temp);
} else {
goto L20;
}
/* L30: */
}
dlaord_("Decreasing", rank, &s[1], &c__1);
/* Generate 'rank' columns of a random orthogonal matrix in A */
dlarnv_(&c__2, &iseed[1], m, &work[1]);
d__1 = 1. / dnrm2_(m, &work[1], &c__1);
dscal_(m, &d__1, &work[1], &c__1);
dlaset_("Full", m, rank, &c_b18, &c_b19, &a[a_offset], lda)
;
dlarf_("Left", m, rank, &work[1], &c__1, &c_b22, &a[a_offset], lda, &
work[*m + 1]);
/* workspace used: m+mn
Generate consistent rhs in the range space of A */
i__1 = *rank * *nrhs;
dlarnv_(&c__2, &iseed[1], &i__1, &work[1]);
dgemm_("No transpose", "No transpose", m, nrhs, rank, &c_b19, &a[
a_offset], lda, &work[1], rank, &c_b18, &b[b_offset], ldb);
/* work space used: <= mn *nrhs
generate (unscaled) matrix A */
i__1 = *rank;
for (j = 1; j <= i__1; ++j) {
dscal_(m, &s[j], &a_ref(1, j), &c__1);
/* L40: */
}
if (*rank < *n) {
i__1 = *n - *rank;
dlaset_("Full", m, &i__1, &c_b18, &c_b18, &a_ref(1, *rank + 1),
lda);
}
dlaror_("Right", "No initialization", m, n, &a[a_offset], lda, &iseed[
1], &work[1], &info);
} else {
/* work space used 2*n+m
Generate null matrix and rhs */
i__1 = mn;
for (j = 1; j <= i__1; ++j) {
s[j] = 0.;
/* L50: */
}
dlaset_("Full", m, n, &c_b18, &c_b18, &a[a_offset], lda);
dlaset_("Full", m, nrhs, &c_b18, &c_b18, &b[b_offset], ldb)
;
}
/* Scale the matrix */
if (*scale != 1) {
*norma = dlange_("Max", m, n, &a[a_offset], lda, dummy);
if (*norma != 0.) {
if (*scale == 2) {
/* matrix scaled up */
dlascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
a_offset], lda, &info);
dlascl_("General", &c__0, &c__0, norma, &bignum, &mn, &c__1, &
s[1], &mn, &info);
dlascl_("General", &c__0, &c__0, norma, &bignum, m, nrhs, &b[
b_offset], ldb, &info);
} else if (*scale == 3) {
/* matrix scaled down */
dlascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
a_offset], lda, &info);
dlascl_("General", &c__0, &c__0, norma, &smlnum, &mn, &c__1, &
s[1], &mn, &info);
dlascl_("General", &c__0, &c__0, norma, &smlnum, m, nrhs, &b[
b_offset], ldb, &info);
} else {
xerbla_("DQRT15", &c__1);
return 0;
}
}
}
*norma = dasum_(&mn, &s[1], &c__1);
*normb = dlange_("One-norm", m, nrhs, &b[b_offset], ldb, dummy)
;
return 0;
/* End of DQRT15 */
} /* dqrt15_ */
/*< SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) >*/
/* Subroutine */ int dlacon_(integer *n, doublereal *v, doublereal *x,
integer *isgn, doublereal *est, integer *kase)
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
double d_sign(doublereal *, doublereal *);
integer i_dnnt(doublereal *);
/* Local variables */
static integer i__, j, iter;
static doublereal temp;
static integer jump;
extern doublereal dasum_(integer *, doublereal *, integer *);
static integer jlast;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
extern integer idamax_(integer *, doublereal *, integer *);
static doublereal altsgn, estold;
fprintf(stderr,
"WARNING: dlacon_ has not been converted for thread safety "
"because the vnl test suite does not manage to call it "
"through dgges. Please send the case for which you get this "
"message to the vxl-users mailing list:\n"
"https://lists.sourceforge.net/lists/listinfo/vxl-users\n\n");
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* February 29, 1992 */
/* .. Scalar Arguments .. */
/*< INTEGER KASE, N >*/
/*< DOUBLE PRECISION EST >*/
/* .. */
/* .. Array Arguments .. */
/*< INTEGER ISGN( * ) >*/
/*< DOUBLE PRECISION V( * ), X( * ) >*/
/* .. */
/* Purpose */
/* ======= */
/* DLACON estimates the 1-norm of a square, real matrix A. */
/* Reverse communication is used for evaluating matrix-vector products. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 1. */
/* V (workspace) DOUBLE PRECISION array, dimension (N) */
/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
/* (W is not returned). */
/* X (input/output) DOUBLE PRECISION array, dimension (N) */
/* On an intermediate return, X should be overwritten by */
/* A * X, if KASE=1, */
/* A' * X, if KASE=2, */
/* and DLACON must be re-called with all the other parameters */
/* unchanged. */
/* ISGN (workspace) INTEGER array, dimension (N) */
/* EST (output) DOUBLE PRECISION */
/* An estimate (a lower bound) for norm(A). */
/* KASE (input/output) INTEGER */
/* On the initial call to DLACON, KASE should be 0. */
/* On an intermediate return, KASE will be 1 or 2, indicating */
/* whether X should be overwritten by A * X or A' * X. */
/* On the final return from DLACON, KASE will again be 0. */
/* Further Details */
/* ======= ======= */
/* Contributed by Nick Higham, University of Manchester. */
/* Originally named SONEST, dated March 16, 1988. */
/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */
/* a real or complex matrix, with applications to condition estimation", */
/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */
/* ===================================================================== */
/* .. Parameters .. */
/*< INTEGER ITMAX >*/
/*< PARAMETER ( ITMAX = 5 ) >*/
/*< DOUBLE PRECISION ZERO, ONE, TWO >*/
/*< PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) >*/
/* .. */
/* .. Local Scalars .. */
/*< INTEGER I, ITER, J, JLAST, JUMP >*/
/*< DOUBLE PRECISION ALTSGN, ESTOLD, TEMP >*/
/* .. */
/* .. External Functions .. */
/*< INTEGER IDAMAX >*/
/*< DOUBLE PRECISION DASUM >*/
/*< EXTERNAL IDAMAX, DASUM >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL DCOPY >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC ABS, DBLE, NINT, SIGN >*/
/* .. */
/* .. Save statement .. */
/*< SAVE >*/
/* .. */
/* .. Executable Statements .. */
/*< IF( KASE.EQ.0 ) THEN >*/
/* Parameter adjustments */
--isgn;
--x;
--v;
/* Function Body */
if (*kase == 0) {
/*< DO 10 I = 1, N >*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< X( I ) = ONE / DBLE( N ) >*/
x[i__] = 1. / (doublereal) (*n);
/*< 10 CONTINUE >*/
/* L10: */
}
/*< KASE = 1 >*/
*kase = 1;
/*< JUMP = 1 >*/
jump = 1;
/*< RETURN >*/
return 0;
/*< END IF >*/
}
/*< GO TO ( 20, 40, 70, 110, 140 )JUMP >*/
switch (jump) {
case 1: goto L20;
case 2: goto L40;
case 3: goto L70;
case 4: goto L110;
case 5: goto L140;
}
/* ................ ENTRY (JUMP = 1) */
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */
/*< 20 CONTINUE >*/
L20:
/*< IF( N.EQ.1 ) THEN >*/
if (*n == 1) {
/*< V( 1 ) = X( 1 ) >*/
v[1] = x[1];
/*< EST = ABS( V( 1 ) ) >*/
*est = abs(v[1]);
/* ... QUIT */
/*< GO TO 150 >*/
goto L150;
/*< END IF >*/
}
/*< EST = DASUM( N, X, 1 ) >*/
*est = dasum_(n, &x[1], &c__1);
/*< DO 30 I = 1, N >*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< X( I ) = SIGN( ONE, X( I ) ) >*/
x[i__] = d_sign(&c_b11, &x[i__]);
/*< ISGN( I ) = NINT( X( I ) ) >*/
isgn[i__] = i_dnnt(&x[i__]);
/*< 30 CONTINUE >*/
/* L30: */
}
/*< KASE = 2 >*/
*kase = 2;
/*< JUMP = 2 >*/
jump = 2;
/*< RETURN >*/
return 0;
/* ................ ENTRY (JUMP = 2) */
/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
/*< 40 CONTINUE >*/
L40:
/*< J = IDAMAX( N, X, 1 ) >*/
j = idamax_(n, &x[1], &c__1);
/*< ITER = 2 >*/
iter = 2;
/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */
/*< 50 CONTINUE >*/
L50:
/*< DO 60 I = 1, N >*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< X( I ) = ZERO >*/
x[i__] = 0.;
/*< 60 CONTINUE >*/
/* L60: */
}
/*< X( J ) = ONE >*/
x[j] = 1.;
/*< KASE = 1 >*/
*kase = 1;
/*< JUMP = 3 >*/
jump = 3;
/*< RETURN >*/
return 0;
/* ................ ENTRY (JUMP = 3) */
/* X HAS BEEN OVERWRITTEN BY A*X. */
/*< 70 CONTINUE >*/
L70:
/*< CALL DCOPY( N, X, 1, V, 1 ) >*/
dcopy_(n, &x[1], &c__1, &v[1], &c__1);
/*< ESTOLD = EST >*/
estold = *est;
/*< EST = DASUM( N, V, 1 ) >*/
*est = dasum_(n, &v[1], &c__1);
/*< DO 80 I = 1, N >*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< >*/
d__1 = d_sign(&c_b11, &x[i__]);
if (i_dnnt(&d__1) != isgn[i__]) {
goto L90;
}
/*< 80 CONTINUE >*/
/* L80: */
}
/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */
/*< GO TO 120 >*/
goto L120;
/*< 90 CONTINUE >*/
L90:
/* TEST FOR CYCLING. */
/*< >*/
if (*est <= estold) {
goto L120;
}
/*< DO 100 I = 1, N >*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< X( I ) = SIGN( ONE, X( I ) ) >*/
x[i__] = d_sign(&c_b11, &x[i__]);
/*< ISGN( I ) = NINT( X( I ) ) >*/
isgn[i__] = i_dnnt(&x[i__]);
/*< 100 CONTINUE >*/
/* L100: */
}
/*< KASE = 2 >*/
*kase = 2;
/*< JUMP = 4 >*/
jump = 4;
/*< RETURN >*/
return 0;
/* ................ ENTRY (JUMP = 4) */
/* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. */
/*< 110 CONTINUE >*/
L110:
/*< JLAST = J >*/
jlast = j;
/*< J = IDAMAX( N, X, 1 ) >*/
j = idamax_(n, &x[1], &c__1);
/*< IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN >*/
if (x[jlast] != (d__1 = x[j], abs(d__1)) && iter < 5) {
/*< ITER = ITER + 1 >*/
++iter;
/*< GO TO 50 >*/
goto L50;
/*< END IF >*/
}
/* ITERATION COMPLETE. FINAL STAGE. */
/*< 120 CONTINUE >*/
L120:
/*< ALTSGN = ONE >*/
altsgn = 1.;
/*< DO 130 I = 1, N >*/
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) >*/
x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) +
1.);
/*< ALTSGN = -ALTSGN >*/
altsgn = -altsgn;
/*< 130 CONTINUE >*/
/* L130: */
}
/*< KASE = 1 >*/
*kase = 1;
/*< JUMP = 5 >*/
jump = 5;
/*< RETURN >*/
return 0;
/* ................ ENTRY (JUMP = 5) */
/* X HAS BEEN OVERWRITTEN BY A*X. */
/*< 140 CONTINUE >*/
L140:
/*< TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) >*/
temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.;
/*< IF( TEMP.GT.EST ) THEN >*/
if (temp > *est) {
/*< CALL DCOPY( N, X, 1, V, 1 ) >*/
dcopy_(n, &x[1], &c__1, &v[1], &c__1);
/*< EST = TEMP >*/
*est = temp;
/*< END IF >*/
}
/*< 150 CONTINUE >*/
L150:
/*< KASE = 0 >*/
*kase = 0;
/*< RETURN >*/
return 0;
/* End of DLACON */
/*< END >*/
} /* dlacon_ */
double dasum( int n, double *x, int incx)
{
return dasum_(&n, x, &incx);
}
/* DECK DPLPDM */
/* Subroutine */ int dplpdm_(integer *mrelas, integer *nvars__, integer *lmx,
integer *lbm, integer *nredc, integer *info, integer *iopt, integer *
ibasis, integer *imat, integer *ibrc, integer *ipr, integer *iwr,
integer *ind, integer *ibb, doublereal *anorm, doublereal *eps,
doublereal *uu, doublereal *gg, doublereal *amat, doublereal *basmat,
doublereal *csc, doublereal *wr, logical *singlr, logical *redbas)
{
/* System generated locals */
address a__1[2];
integer ibrc_dim1, ibrc_offset, i__1, i__2[2];
char ch__1[55];
/* Local variables */
static integer i__, j, k;
static doublereal aij, one;
static integer nzbm;
static doublereal zero;
static char xern3[16];
extern /* Subroutine */ int la05ad_(doublereal *, integer *, integer *,
integer *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *);
extern doublereal dasum_(integer *, doublereal *, integer *);
static integer iplace;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen), dpnnzr_(integer *, doublereal
*, integer *, doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static icilist io___10 = { 0, xern3, 0, "(1PE15.6)", 16, 1 };
/* ***BEGIN PROLOGUE DPLPDM */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DSPLP */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (SPLPDM-S, DPLPDM-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* THIS SUBPROGRAM IS FROM THE DSPLP( ) PACKAGE. IT PERFORMS THE */
/* TASK OF DEFINING THE ENTRIES OF THE BASIS MATRIX AND */
/* DECOMPOSING IT USING THE LA05 PACKAGE. */
/* IT IS THE MAIN PART OF THE PROCEDURE (DECOMPOSE BASIS MATRIX). */
/* ***SEE ALSO DSPLP */
/* ***ROUTINES CALLED DASUM, DPNNZR, LA05AD, XERMSG */
/* ***COMMON BLOCKS LA05DD */
/* ***REVISION HISTORY (YYMMDD) */
/* 811215 DATE WRITTEN */
/* 890605 Added DASUM to list of DOUBLE PRECISION variables. */
/* 890605 Removed unreferenced labels. (WRB) */
/* 891009 Removed unreferenced variable. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900328 Added TYPE section. (WRB) */
/* 900510 Convert XERRWV calls to XERMSG calls, convert do-it-yourself */
/* DO loops to DO loops. (RWC) */
/* ***END PROLOGUE DPLPDM */
/* COMMON BLOCK USED BY LA05 () PACKAGE.. */
/* ***FIRST EXECUTABLE STATEMENT DPLPDM */
/* Parameter adjustments */
ibrc_dim1 = *lbm;
ibrc_offset = 1 + ibrc_dim1;
ibrc -= ibrc_offset;
--ibasis;
--imat;
--ipr;
--iwr;
--ind;
--ibb;
--amat;
--basmat;
--csc;
--wr;
/* Function Body */
zero = 0.;
one = 1.;
/* DEFINE BASIS MATRIX BY COLUMNS FOR SPARSE MATRIX EQUATION SOLVER. */
/* THE LA05AD() SUBPROGRAM REQUIRES THE NONZERO ENTRIES OF THE MATRIX */
/* TOGETHER WITH THE ROW AND COLUMN INDICES. */
nzbm = 0;
/* DEFINE DEPENDENT VARIABLE COLUMNS. THESE ARE */
/* COLS. OF THE IDENTITY MATRIX AND IMPLICITLY GENERATED. */
i__1 = *mrelas;
for (k = 1; k <= i__1; ++k) {
j = ibasis[k];
if (j > *nvars__) {
++nzbm;
if (ind[j] == 2) {
basmat[nzbm] = one;
} else {
basmat[nzbm] = -one;
}
ibrc[nzbm + ibrc_dim1] = j - *nvars__;
ibrc[nzbm + (ibrc_dim1 << 1)] = k;
} else {
/* DEFINE THE INDEP. VARIABLE COLS. THIS REQUIRES RETRIEVING */
/* THE COLS. FROM THE SPARSE MATRIX DATA STRUCTURE. */
i__ = 0;
L10:
dpnnzr_(&i__, &aij, &iplace, &amat[1], &imat[1], &j);
if (i__ > 0) {
++nzbm;
basmat[nzbm] = aij * csc[j];
ibrc[nzbm + ibrc_dim1] = i__;
ibrc[nzbm + (ibrc_dim1 << 1)] = k;
goto L10;
}
}
/* L20: */
}
*singlr = FALSE_;
/* RECOMPUTE MATRIX NORM USING CRUDE NORM = SUM OF MAGNITUDES. */
*anorm = dasum_(&nzbm, &basmat[1], &c__1);
la05dd_1.small = *eps * *anorm;
/* GET AN L-U FACTORIZATION OF THE BASIS MATRIX. */
++(*nredc);
*redbas = TRUE_;
la05ad_(&basmat[1], &ibrc[ibrc_offset], &nzbm, lbm, mrelas, &ipr[1], &iwr[
1], &wr[1], gg, uu);
/* CHECK RETURN VALUE OF ERROR FLAG, GG. */
if (*gg >= zero) {
return 0;
}
if (*gg == -7.f) {
xermsg_("SLATEC", "DPLPDM", "IN DSPLP, SHORT ON STORAGE FOR LA05AD. "
" USE PRGOPT(*) TO GIVE MORE.", &c__28, iopt, (ftnlen)6, (
ftnlen)6, (ftnlen)67);
*info = -28;
} else if (*gg == -5.f) {
*singlr = TRUE_;
} else {
s_wsfi(&io___10);
do_fio(&c__1, (char *)&(*gg), (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__2[0] = 39, a__1[0] = "IN DSPLP, LA05AD RETURNED ERROR FLAG = ";
i__2[1] = 16, a__1[1] = xern3;
s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)55);
xermsg_("SLATEC", "DPLPDM", ch__1, &c__27, iopt, (ftnlen)6, (ftnlen)6,
(ftnlen)55);
*info = -27;
}
return 0;
} /* dplpdm_ */
/* Subroutine */ int dstein_(integer * n, doublereal * d__, doublereal * e,
integer * m, doublereal * w, integer * iblock,
integer * isplit, doublereal * z__, integer * ldz,
doublereal * work, integer * iwork,
integer * ifail, integer * info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3, d__4, d__5;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer jblk, nblk;
extern doublereal ddot_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer jmax;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static integer i__, j;
extern /* Subroutine */ int dscal_(integer *, doublereal *,
doublereal *,
integer *);
static integer iseed[4], gpind, iinfo;
extern doublereal dasum_(integer *, doublereal *, integer *);
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer b1;
extern /* Subroutine */ int daxpy_(integer *, doublereal *,
doublereal *,
integer *, doublereal *, integer *);
static integer j1;
static doublereal ortol;
static integer indrv1, indrv2, indrv3, indrv4, indrv5, bn;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int dlagtf_(integer *, doublereal *,
doublereal *,
doublereal *, doublereal *,
doublereal *, doublereal *,
integer *, integer *);
static doublereal xj;
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *), dlagts_(
integer
*,
integer
*,
doublereal
*,
doublereal
*,
doublereal
*,
doublereal
*,
integer
*,
doublereal
*,
doublereal
*,
integer
*);
static integer nrmchk;
extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
doublereal *);
static integer blksiz;
static doublereal onenrm, dtpcrt, pertol, scl, eps, sep, nrm, tol;
static integer its;
static doublereal xjm, ztr, eps1;
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
/* -- LAPACK routine (instrumented to count operations, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Common block to return operation count and iteration count
ITCNT is initialized to 0, OPS is only incremented
Purpose
=======
DSTEIN computes the eigenvectors of a real symmetric tridiagonal
matrix T corresponding to specified eigenvalues, using inverse
iteration.
The maximum number of iterations allowed for each eigenvector is
specified by an internal parameter MAXITS (currently set to 5).
Arguments
=========
N (input) INTEGER
The order of the matrix. N >= 0.
D (input) DOUBLE PRECISION array, dimension (N)
The n diagonal elements of the tridiagonal matrix T.
E (input) DOUBLE PRECISION array, dimension (N)
The (n-1) subdiagonal elements of the tridiagonal matrix
T, in elements 1 to N-1. E(N) need not be set.
M (input) INTEGER
The number of eigenvectors to be found. 0 <= M <= N.
W (input) DOUBLE PRECISION array, dimension (N)
The first M elements of W contain the eigenvalues for
which eigenvectors are to be computed. The eigenvalues
should be grouped by split-off block and ordered from
smallest to largest within the block. ( The output array
W from DSTEBZ with ORDER = 'B' is expected here. )
IBLOCK (input) INTEGER array, dimension (N)
The submatrix indices associated with the corresponding
eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
the first submatrix from the top, =2 if W(i) belongs to
the second submatrix, etc. ( The output array IBLOCK
from DSTEBZ is expected here. )
ISPLIT (input) INTEGER array, dimension (N)
The splitting points, at which T breaks up into submatrices.
The first submatrix consists of rows/columns 1 to
ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
through ISPLIT( 2 ), etc.
( The output array ISPLIT from DSTEBZ is expected here. )
Z (output) DOUBLE PRECISION array, dimension (LDZ, M)
The computed eigenvectors. The eigenvector associated
with the eigenvalue W(i) is stored in the i-th column of
Z. Any vector which fails to converge is set to its current
iterate after MAXITS iterations.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= max(1,N).
WORK (workspace) DOUBLE PRECISION array, dimension (5*N)
IWORK (workspace) INTEGER array, dimension (N)
IFAIL (output) INTEGER array, dimension (M)
On normal exit, all elements of IFAIL are zero.
If one or more eigenvectors fail to converge after
MAXITS iterations, then their indices are stored in
array IFAIL.
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, then i eigenvectors failed to converge
in MAXITS iterations. Their indices are stored in
array IFAIL.
Internal Parameters
===================
MAXITS INTEGER, default = 5
The maximum number of iterations performed.
EXTRA INTEGER, default = 2
The number of iterations performed after norm growth
criterion is satisfied, should be at least 1.
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--e;
--w;
--iblock;
--isplit;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--iwork;
--ifail;
/* Function Body */
*info = 0;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
ifail[i__] = 0;
/* L10: */
}
if (*n < 0) {
*info = -1;
} else if (*m < 0 || *m > *n) {
*info = -4;
} else if (*ldz < max(1, *n)) {
*info = -9;
} else {
i__1 = *m;
for (j = 2; j <= i__1; ++j) {
if (iblock[j] < iblock[j - 1]) {
*info = -6;
goto L30;
}
if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) {
*info = -5;
goto L30;
}
/* L20: */
}
L30:
;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSTEIN", &i__1);
return 0;
}
/* Initialize iteration count. */
latime_1.itcnt = 0.;
/* Quick return if possible */
if (*n == 0 || *m == 0) {
return 0;
} else if (*n == 1) {
z___ref(1, 1) = 1.;
return 0;
}
/* Get machine constants. */
eps = dlamch_("Precision");
/* Initialize seed for random number generator DLARNV. */
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = 1;
/* L40: */
}
/* Initialize pointers. */
indrv1 = 0;
indrv2 = indrv1 + *n;
indrv3 = indrv2 + *n;
indrv4 = indrv3 + *n;
indrv5 = indrv4 + *n;
/* Compute eigenvectors of matrix blocks. */
j1 = 1;
i__1 = iblock[*m];
for (nblk = 1; nblk <= i__1; ++nblk) {
/* Find starting and ending indices of block nblk. */
if (nblk == 1) {
b1 = 1;
} else {
b1 = isplit[nblk - 1] + 1;
}
bn = isplit[nblk];
blksiz = bn - b1 + 1;
if (blksiz == 1) {
goto L60;
}
gpind = b1;
/* Compute reorthogonalization criterion and stopping criterion. */
onenrm = (d__1 = d__[b1], abs(d__1)) + (d__2 =
e[b1], abs(d__2));
/* Computing MAX */
d__3 = onenrm, d__4 = (d__1 = d__[bn], abs(d__1)) + (d__2 =
e[bn - 1],
abs(d__2));
onenrm = max(d__3, d__4);
i__2 = bn - 1;
for (i__ = b1 + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
d__4 = onenrm, d__5 = (d__1 =
d__[i__], abs(d__1)) + (d__2 =
e[i__ -
1],
abs
(d__2)) +
(d__3 = e[i__], abs(d__3));
onenrm = max(d__4, d__5);
/* L50: */
}
ortol = onenrm * .001;
dtpcrt = sqrt(.1 / blksiz);
/* Increment opcount for computing criteria. */
latime_1.ops = latime_1.ops + ((bn - b1) << 1) + 3;
/* Loop through eigenvalues of block nblk. */
L60:
jblk = 0;
i__2 = *m;
for (j = j1; j <= i__2; ++j) {
if (iblock[j] != nblk) {
j1 = j;
goto L160;
}
++jblk;
xj = w[j];
/* Skip all the work if the block size is one. */
if (blksiz == 1) {
work[indrv1 + 1] = 1.;
goto L120;
}
/* If eigenvalues j and j-1 are too close, add a relatively
small perturbation. */
if (jblk > 1) {
eps1 = (d__1 = eps * xj, abs(d__1));
pertol = eps1 * 10.;
sep = xj - xjm;
if (sep < pertol) {
xj = xjm + pertol;
}
}
its = 0;
nrmchk = 0;
/* Get random starting vector. */
dlarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]);
/* Increment opcount for getting random starting vector.
( DLARND(2,.) requires 9 flops. ) */
latime_1.ops += blksiz * 9;
/* Copy the matrix T so it won't be destroyed in factorization. */
dcopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1],
&c__1);
i__3 = blksiz - 1;
dcopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1);
i__3 = blksiz - 1;
dcopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1);
/* Compute LU factors with partial pivoting ( PT = LU ) */
tol = 0.;
dlagtf_(&blksiz, &work[indrv4 + 1], &xj,
&work[indrv2 + 2], &work[indrv3 + 1], &tol,
&work[indrv5 + 1], &iwork[1], &iinfo);
/* Increment opcount for computing LU factors.
( DLAGTF(BLKSIZ,...) requires about 8*BLKSIZ flops. ) */
latime_1.ops += blksiz << 3;
/* Update iteration count. */
L70:
++its;
if (its > 5) {
goto L100;
}
/* Normalize and scale the righthand side vector Pb.
Computing MAX */
d__2 = eps, d__3 = (d__1 =
work[indrv4 + blksiz], abs(d__1));
scl =
blksiz * onenrm * max(d__2, d__3) / dasum_(&blksiz,
&work
[indrv1 +
1],
&c__1);
dscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
/* Solve the system LU = Pb. */
dlagts_(&c_n1, &blksiz, &work[indrv4 + 1],
&work[indrv2 + 2], &work[indrv3 + 1],
&work[indrv5 + 1], &iwork[1], &work[indrv1 + 1],
&tol, &iinfo);
/* Increment opcount for scaling and solving linear system.
( DLAGTS(-1,BLKSIZ,...) requires about 8*BLKSIZ flops. ) */
latime_1.ops = latime_1.ops + 3 + blksiz * 10;
/* Reorthogonalize by modified Gram-Schmidt if eigenvalues are
close enough. */
if (jblk == 1) {
goto L90;
}
if ((d__1 = xj - xjm, abs(d__1)) > ortol) {
gpind = j;
}
if (gpind != j) {
i__3 = j - 1;
for (i__ = gpind; i__ <= i__3; ++i__) {
ztr =
-ddot_(&blksiz, &work[indrv1 + 1],
&c__1, &z___ref(b1, i__),
&c__1);
daxpy_(&blksiz, &ztr, &z___ref(b1, i__),
&c__1, &work[indrv1 + 1], &c__1);
/* L80: */
}
/* Increment opcount for reorthogonalizing. */
latime_1.ops += (j - gpind) * blksiz << 2;
}
/* Check the infinity norm of the iterate. */
L90:
jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1);
nrm = (d__1 = work[indrv1 + jmax], abs(d__1));
/* Continue for additional iterations after norm reaches
stopping criterion. */
if (nrm < dtpcrt) {
goto L70;
}
++nrmchk;
if (nrmchk < 3) {
goto L70;
}
goto L110;
/* If stopping criterion was not satisfied, update info and
store eigenvector number in array ifail. */
L100:
++(*info);
ifail[*info] = j;
/* Accept iterate as jth eigenvector. */
L110:
scl = 1. / dnrm2_(&blksiz, &work[indrv1 + 1], &c__1);
jmax = idamax_(&blksiz, &work[indrv1 + 1], &c__1);
if (work[indrv1 + jmax] < 0.) {
scl = -scl;
}
dscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
/* Increment opcount for scaling. */
latime_1.ops += blksiz * 3;
L120:
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
z___ref(i__, j) = 0.;
/* L130: */
}
i__3 = blksiz;
for (i__ = 1; i__ <= i__3; ++i__) {
z___ref(b1 + i__ - 1, j) = work[indrv1 + i__];
/* L140: */
}
/* Save the shift to check eigenvalue spacing at next
iteration. */
xjm = xj;
/* L150: */
}
L160:
;
}
return 0;
/* End of DSTEIN */
} /* dstein_ */
/* Subroutine */ int dgtt02_(char *trans, integer *n, integer *nrhs,
doublereal *dl, doublereal *d__, doublereal *du, doublereal *x,
integer *ldx, doublereal *b, integer *ldb, doublereal *rwork,
doublereal *resid)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
integer j;
doublereal eps;
doublereal anorm, bnorm, xnorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DGTT02 computes the residual for the solution to a tridiagonal */
/* system of equations: */
/* RESID = norm(B - op(A)*X) / (norm(A) * norm(X) * EPS), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========= */
/* TRANS (input) CHARACTER */
/* Specifies the form of the residual. */
/* = 'N': B - A * X (No transpose) */
/* = 'T': B - A'* X (Transpose) */
/* = 'C': B - A'* X (Conjugate transpose = Transpose) */
/* N (input) INTEGTER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* DL (input) DOUBLE PRECISION array, dimension (N-1) */
/* The (n-1) sub-diagonal elements of A. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The diagonal elements of A. */
/* DU (input) DOUBLE PRECISION array, dimension (N-1) */
/* The (n-1) super-diagonal elements of A. */
/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* The computed solution vectors X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the right hand side vectors for the system of */
/* linear equations. */
/* On exit, B is overwritten with the difference B - op(A)*X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESID (output) DOUBLE PRECISION */
/* norm(B - op(A)*X) / (norm(A) * norm(X) * EPS) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0 */
/* Parameter adjustments */
--dl;
--d__;
--du;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--rwork;
/* Function Body */
*resid = 0.;
if (*n <= 0 || *nrhs == 0) {
return 0;
}
/* Compute the maximum over the number of right hand sides of */
/* norm(B - op(A)*X) / ( norm(A) * norm(X) * EPS ). */
if (lsame_(trans, "N")) {
anorm = dlangt_("1", n, &dl[1], &d__[1], &du[1]);
} else {
anorm = dlangt_("I", n, &dl[1], &d__[1], &du[1]);
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Compute B - op(A)*X. */
dlagtm_(trans, n, nrhs, &c_b6, &dl[1], &d__[1], &du[1], &x[x_offset], ldx,
&c_b7, &b[b_offset], ldb);
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bnorm = dasum_(n, &b[j * b_dim1 + 1], &c__1);
xnorm = dasum_(n, &x[j * x_dim1 + 1], &c__1);
if (xnorm <= 0.) {
*resid = 1. / eps;
} else {
/* Computing MAX */
d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
*resid = max(d__1,d__2);
}
/* L10: */
}
return 0;
/* End of DGTT02 */
} /* dgtt02_ */
/*< 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 */ int dtbt02_(char *uplo, char *trans, char *diag, integer *n,
integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal
*x, integer *ldx, doublereal *b, integer *ldb, doublereal *work,
doublereal *resid)
{
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
extern doublereal dasum_(integer *, doublereal *, integer *);
static doublereal anorm, bnorm;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dtbmv_(char *, char *, char *, integer *
, integer *, doublereal *, integer *, doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static doublereal xnorm;
extern doublereal dlamch_(char *), dlantb_(char *, char *, char *,
integer *, integer *, doublereal *, integer *, doublereal *);
static doublereal eps;
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DTBT02 computes the residual for the computed solution to a
triangular system of linear equations A*x = b or A' *x = b when
A is a triangular band matrix. Here A' is the transpose of A and
x and b are N by NRHS matrices. The test ratio is the maximum over
the number of right hand sides of
norm(b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
where op(A) denotes A or A' and EPS is the machine epsilon.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
TRANS (input) CHARACTER*1
Specifies the operation applied to A.
= 'N': A *x = b (No transpose)
= 'T': A'*x = b (Transpose)
= 'C': A'*x = b (Conjugate transpose = Transpose)
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.
KD (input) INTEGER
The number of superdiagonals or subdiagonals of the
triangular band matrix A. KD >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices X and B. NRHS >= 0.
AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
The upper or lower triangular 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).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KD+1.
X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
The computed solution vectors for the system of linear
equations.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
The right hand side vectors for the system of linear
equations.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
WORK (workspace) DOUBLE PRECISION array, dimension (N)
RESID (output) DOUBLE PRECISION
The maximum over the number of right hand sides of
norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
=====================================================================
Quick exit if N = 0 or NRHS = 0
Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--work;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.;
return 0;
}
/* Compute the 1-norm of A or A'. */
if (lsame_(trans, "N")) {
anorm = dlantb_("1", uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]
);
} else {
anorm = dlantb_("I", uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]
);
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Compute the maximum over the number of right hand sides of
norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ). */
*resid = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dcopy_(n, &x_ref(1, j), &c__1, &work[1], &c__1);
dtbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], &
c__1);
daxpy_(n, &c_b10, &b_ref(1, j), &c__1, &work[1], &c__1);
bnorm = dasum_(n, &work[1], &c__1);
xnorm = dasum_(n, &x_ref(1, j), &c__1);
if (xnorm <= 0.) {
*resid = 1. / eps;
} else {
/* Computing MAX */
d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
*resid = max(d__1,d__2);
}
/* L10: */
}
return 0;
/* End of DTBT02 */
} /* dtbt02_ */
