/* Subroutine */ int sasumsub_(integer *n, real *x, integer *incx, real *asum)
{
extern doublereal sasum_(integer *, real *, integer *);
/* Parameter adjustments */
--x;
/* Function Body */
*asum = sasum_(n, &x[1], incx);
return 0;
} /* sasumsub_ */
int toScalarF(int code, KFVEC(x), FVEC(r)) {
REQUIRES(rn==1,BAD_SIZE);
DEBUGMSG("toScalarF");
float res;
integer one = 1;
integer n = xn;
switch(code) {
case 0: { res = snrm2_(&n,xp,&one); break; }
case 1: { res = sasum_(&n,xp,&one); break; }
case 2: { res = vector_max_index_f(V(x)); break; }
case 3: { res = vector_max_f(V(x)); break; }
case 4: { res = vector_min_index_f(V(x)); break; }
case 5: { res = vector_min_f(V(x)); break; }
default: ERROR(BAD_CODE);
}
rp[0] = res;
OK
}
/* Subroutine */ int strt02_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, real *a, integer *lda, real *x, integer *ldx, real *b,
integer *ldb, real *work, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2;
/* Local variables */
integer j;
real eps;
real anorm, bnorm;
real xnorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STRT02 computes the residual for the computed solution to a */
/* triangular system of linear equations A*x = b or A'*x = b. */
/* Here A is a triangular matrix, 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. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices X and B. NRHS >= 0. */
/* A (input) REAL 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) REAL 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) REAL 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) REAL array, dimension (N) */
/* RESID (output) REAL */
/* 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 */
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;
--work;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
/* Compute the 1-norm of A or A'. */
if (lsame_(trans, "N")) {
anorm = slantr_("1", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
} else {
anorm = slantr_("I", uplo, diag, n, n, &a[a_offset], lda, &work[1]);
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
if (anorm <= 0.f) {
*resid = 1.f / 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.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
strmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
saxpy_(n, &c_b10, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
bnorm = sasum_(n, &work[1], &c__1);
xnorm = sasum_(n, &x[j * x_dim1 + 1], &c__1);
if (xnorm <= 0.f) {
*resid = 1.f / eps;
} else {
/* Computing MAX */
r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
*resid = dmax(r__1,r__2);
}
/* L10: */
}
return 0;
/* End of STRT02 */
} /* strt02_ */
/* Subroutine */ int slatps_(char *uplo, char *trans, char *diag, char *
normin, integer *n, real *ap, real *x, real *scale, real *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
=======
SLATPS 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
STPSV 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) REAL 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) REAL 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) REAL
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) REAL 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, STPSV
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 STPSV 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 STPSV 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 real c_b36 = .5f;
/* System generated locals */
integer i__1, i__2, i__3;
real r__1, r__2, r__3;
/* Local variables */
static integer jinc, jlen;
static real xbnd;
static integer imax;
static real tmax, tjjs;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
static real xmax, grow, sumj;
static integer i__, j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real tscal, uscal;
static integer jlast;
extern doublereal sasum_(integer *, real *, integer *);
static logical upper;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *), stpsv_(char *, char *, char *, integer *,
real *, real *, integer *);
static integer ip;
static real xj;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
extern integer isamax_(integer *, real *, integer *);
static logical notran;
static integer jfirst;
static real smlnum;
static logical nounit;
static real rec, tjj;
--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_("SLATPS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = slamch_("Safe minimum") / slamch_("Precision");
bignum = 1.f / smlnum;
*scale = 1.f;
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] = sasum_(&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] = sasum_(&i__2, &ap[ip + 1], &c__1);
ip = ip + *n - j + 1;
/* L20: */
}
cnorm[*n] = 0.f;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is
greater than BIGNUM. */
imax = isamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum) {
tscal = 1.f;
} else {
tscal = 1.f / (smlnum * tmax);
sscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the
Level 2 BLAS routine STPSV can be used. */
j = isamax_(n, &x[1], &c__1);
xmax = (r__1 = x[j], dabs(r__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.f) {
grow = 0.f;
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.f / dmax(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 = (r__1 = ap[ip], dabs(r__1));
/* Computing MIN */
r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
xbnd = dmin(r__1,r__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.f;
}
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 */
r__1 = 1.f, r__2 = 1.f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__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.f / (cnorm[j] + 1.f);
/* 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.f) {
grow = 0.f;
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.f / dmax(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.f;
/* Computing MIN */
r__1 = grow, r__2 = xbnd / xj;
grow = dmin(r__1,r__2);
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
tjj = (r__1 = ap[ip], dabs(r__1));
if (xj > tjj) {
xbnd *= tjj / xj;
}
++jlen;
ip += jinc * jlen;
/* L60: */
}
grow = dmin(grow,xbnd);
} else {
/* A is unit triangular.
Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
Computing MIN */
r__1 = 1.f, r__2 = 1.f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__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.f;
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. */
stpsv_(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;
sscal_(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 = (r__1 = x[j], dabs(r__1));
if (nounit) {
tjjs = ap[ip] * tscal;
} else {
tjjs = tscal;
if (tscal == 1.f) {
goto L95;
}
}
tjj = dabs(tjjs);
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1.f / xj;
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j] /= tjjs;
xj = (r__1 = x[j], dabs(r__1));
} else if (tjj > 0.f) {
/* 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.f) {
/* Scale by 1/CNORM(j) to avoid overflow when
multiplying x(j) times column j. */
rec /= cnorm[j];
}
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
x[j] /= tjjs;
xj = (r__1 = x[j], dabs(r__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.f;
/* L90: */
}
x[j] = 1.f;
xj = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L95:
/* Scale x if necessary to avoid overflow when adding a
multiple of column j of A. */
if (xj > 1.f) {
rec = 1.f / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5f;
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
sscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5f;
}
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;
r__1 = -x[j] * tscal;
saxpy_(&i__3, &r__1, &ap[ip - j + 1], &c__1, &x[1], &
c__1);
i__3 = j - 1;
i__ = isamax_(&i__3, &x[1], &c__1);
xmax = (r__1 = x[i__], dabs(r__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;
r__1 = -x[j] * tscal;
saxpy_(&i__3, &r__1, &ap[ip + 1], &c__1, &x[j + 1], &
c__1);
i__3 = *n - j;
i__ = j + isamax_(&i__3, &x[j + 1], &c__1);
xmax = (r__1 = x[i__], dabs(r__1));
}
ip = ip + *n - j + 1;
}
/* L100: */
}
} 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 = (r__1 = x[j], dabs(r__1));
uscal = tscal;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
tjjs = ap[ip] * tscal;
} else {
tjjs = tscal;
}
tjj = dabs(tjjs);
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1.
Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
uscal /= tjjs;
}
if (rec < 1.f) {
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
sumj = 0.f;
if (uscal == 1.f) {
/* If the scaling needed for A in the dot product is 1,
call SDOT to perform the dot product. */
if (upper) {
i__3 = j - 1;
sumj = sdot_(&i__3, &ap[ip - j + 1], &c__1, &x[1], &
c__1);
} else if (j < *n) {
i__3 = *n - j;
sumj = sdot_(&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__];
/* L110: */
}
} else if (j < *n) {
i__3 = *n - j;
for (i__ = 1; i__ <= i__3; ++i__) {
sumj += ap[ip + i__] * uscal * x[j + i__];
/* L120: */
}
}
}
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 = (r__1 = x[j], dabs(r__1));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjjs = ap[ip] * tscal;
} else {
tjjs = tscal;
if (tscal == 1.f) {
goto L135;
}
}
tjj = dabs(tjjs);
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j] /= tjjs;
} else if (tjj > 0.f) {
/* 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;
sscal_(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.f;
/* L130: */
}
x[j] = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L135:
;
} 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 */
r__2 = xmax, r__3 = (r__1 = x[j], dabs(r__1));
xmax = dmax(r__2,r__3);
++jlen;
ip += jinc * jlen;
/* L140: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.f) {
r__1 = 1.f / tscal;
sscal_(n, &r__1, &cnorm[1], &c__1);
}
return 0;
/* End of SLATPS */
} /* slatps_ */
doublereal sqrt12_(integer *m, integer *n, real *a, integer *lda, real *s,
real *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real ret_val;
/* Local variables */
integer i__, j, mn, iscl, info;
real anrm;
extern doublereal snrm2_(integer *, real *, integer *), sasum_(integer *,
real *, integer *);
real dummy[1];
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *), sgebd2_(integer *, integer *, real *, integer
*, real *, real *, real *, real *, real *, integer *), slabad_(
real *, real *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *);
real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *), slaset_(char *, integer *, integer *, real *, real *,
real *, integer *), sbdsqr_(char *, integer *, integer *,
integer *, integer *, real *, real *, real *, integer *, real *,
integer *, real *, integer *, real *, integer *);
real 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 */
/* ======= */
/* SQRT12 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) REAL 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) REAL array, dimension (min(M,N)) */
/* The singular values of the matrix A. */
/* WORK (workspace) REAL 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.f;
/* 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_("SQRT12", &c__7);
return ret_val;
}
/* Quick return if possible */
mn = min(*m,*n);
if ((real) mn <= 0.f) {
return ret_val;
}
nrmsvl = snrm2_(&mn, &s[1], &c__1);
/* Copy upper triangle of A into work */
slaset_("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 = slamch_("S") / slamch_("P");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Scale work if max entry outside range [SMLNUM,BIGNUM] */
anrm = slange_("M", m, n, &work[1], m, dummy);
iscl = 0;
if (anrm > 0.f && anrm < smlnum) {
/* Scale matrix norm up to SMLNUM */
slascl_("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 */
slascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &work[1], m, &info);
iscl = 1;
}
if (anrm != 0.f) {
/* Compute SVD of work */
sgebd2_(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);
sbdsqr_("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) {
slascl_("G", &c__0, &c__0, &bignum, &anrm, &mn, &c__1, &work[*
m * *n + 1], &mn, &info);
}
if (anrm < smlnum) {
slascl_("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.f;
/* L30: */
}
}
/* Compare s and singular values of work */
saxpy_(&mn, &c_b33, &s[1], &c__1, &work[*m * *n + 1], &c__1);
ret_val = sasum_(&mn, &work[*m * *n + 1], &c__1) / (slamch_("Epsilon") * (real) max(*m,*n));
if (nrmsvl != 0.f) {
ret_val /= nrmsvl;
}
return ret_val;
/* End of SQRT12 */
} /* sqrt12_ */
/* Subroutine */ int sstein_(integer *n, real *d, real *e, integer *m, real *
w, integer *iblock, integer *isplit, real *z, integer *ldz, real *
work, integer *iwork, integer *ifail, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SSTEIN 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) REAL array, dimension (N)
The n diagonal elements of the tridiagonal matrix T.
E (input) REAL 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) REAL 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 SSTEBZ 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 SSTEBZ 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 SSTEBZ is expected here. )
Z (output) REAL 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) REAL 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
Function Body */
/* Table of constant values */
static integer c__2 = 2;
static integer c__1 = 1;
static integer c_n1 = -1;
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3;
real r__1, r__2, r__3, r__4, r__5;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer jblk, nblk, jmax;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *),
snrm2_(integer *, real *, integer *);
static integer i, j, iseed[4], gpind, iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static integer b1;
extern doublereal sasum_(integer *, real *, integer *);
static integer j1;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static real ortol;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *);
static integer indrv1, indrv2, indrv3, indrv4, indrv5, bn;
static real xj;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *), slagtf_(
integer *, real *, real *, real *, real *, real *, real *,
integer *, integer *);
static integer nrmchk;
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slagts_(integer *, integer *, real *, real *,
real *, real *, integer *, real *, real *, integer *);
static integer blksiz;
static real onenrm, pertol;
extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
*);
static real stpcrt, scl, eps, ctr, sep, nrm, tol;
static integer its;
static real xjm, eps1;
#define ISEED(I) iseed[(I)]
#define D(I) d[(I)-1]
#define E(I) e[(I)-1]
#define W(I) w[(I)-1]
#define IBLOCK(I) iblock[(I)-1]
#define ISPLIT(I) isplit[(I)-1]
#define WORK(I) work[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define IFAIL(I) ifail[(I)-1]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
*info = 0;
i__1 = *m;
for (i = 1; i <= *m; ++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 <= *m; ++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_("SSTEIN", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *m == 0) {
return 0;
} else if (*n == 1) {
Z(1,1) = 1.f;
return 0;
}
/* Get machine constants. */
eps = slamch_("Precision");
/* Initialize seed for random number generator SLARNV. */
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 <= IBLOCK(*m); ++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 = (r__1 = D(b1), dabs(r__1)) + (r__2 = E(b1), dabs(r__2));
/* Computing MAX */
r__3 = onenrm, r__4 = (r__1 = D(bn), dabs(r__1)) + (r__2 = E(bn - 1),
dabs(r__2));
onenrm = dmax(r__3,r__4);
i__2 = bn - 1;
for (i = b1 + 1; i <= bn-1; ++i) {
/* Computing MAX */
r__4 = onenrm, r__5 = (r__1 = D(i), dabs(r__1)) + (r__2 = E(i - 1)
, dabs(r__2)) + (r__3 = E(i), dabs(r__3));
onenrm = dmax(r__4,r__5);
/* L50: */
}
ortol = onenrm * .001f;
stpcrt = sqrt(.1f / blksiz);
/* Loop through eigenvalues of block nblk. */
L60:
jblk = 0;
i__2 = *m;
for (j = j1; j <= *m; ++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.f;
goto L120;
}
/* If eigenvalues j and j-1 are too close, add a relativ
ely
small perturbation. */
if (jblk > 1) {
eps1 = (r__1 = eps * xj, dabs(r__1));
pertol = eps1 * 10.f;
sep = xj - xjm;
if (sep < pertol) {
xj = xjm + pertol;
}
}
its = 0;
nrmchk = 0;
/* Get random starting vector. */
slarnv_(&c__2, iseed, &blksiz, &WORK(indrv1 + 1));
/* Copy the matrix T so it won't be destroyed in factori
zation. */
scopy_(&blksiz, &D(b1), &c__1, &WORK(indrv4 + 1), &c__1);
i__3 = blksiz - 1;
scopy_(&i__3, &E(b1), &c__1, &WORK(indrv2 + 2), &c__1);
i__3 = blksiz - 1;
scopy_(&i__3, &E(b1), &c__1, &WORK(indrv3 + 1), &c__1);
/* Compute LU factors with partial pivoting ( PT = LU )
*/
tol = 0.f;
slagtf_(&blksiz, &WORK(indrv4 + 1), &xj, &WORK(indrv2 + 2), &WORK(
indrv3 + 1), &tol, &WORK(indrv5 + 1), &IWORK(1), &iinfo);
/* Update iteration count. */
L70:
++its;
if (its > 5) {
goto L100;
}
/* Normalize and scale the righthand side vector Pb.
Computing MAX */
r__2 = eps, r__3 = (r__1 = WORK(indrv4 + blksiz), dabs(r__1));
scl = blksiz * onenrm * dmax(r__2,r__3) / sasum_(&blksiz, &WORK(
indrv1 + 1), &c__1);
sscal_(&blksiz, &scl, &WORK(indrv1 + 1), &c__1);
/* Solve the system LU = Pb. */
slagts_(&c_n1, &blksiz, &WORK(indrv4 + 1), &WORK(indrv2 + 2), &
WORK(indrv3 + 1), &WORK(indrv5 + 1), &IWORK(1), &WORK(
indrv1 + 1), &tol, &iinfo);
/* Reorthogonalize by modified Gram-Schmidt if eigenvalu
es are
close enough. */
if (jblk == 1) {
goto L90;
}
if ((r__1 = xj - xjm, dabs(r__1)) > ortol) {
gpind = j;
}
if (gpind != j) {
i__3 = j - 1;
for (i = gpind; i <= j-1; ++i) {
ctr = -(doublereal)sdot_(&blksiz, &WORK(indrv1 + 1), &
c__1, &Z(b1,i), &c__1);
saxpy_(&blksiz, &ctr, &Z(b1,i), &c__1, &WORK(
indrv1 + 1), &c__1);
/* L80: */
}
}
/* Check the infinity norm of the iterate. */
L90:
jmax = isamax_(&blksiz, &WORK(indrv1 + 1), &c__1);
nrm = (r__1 = WORK(indrv1 + jmax), dabs(r__1));
/* Continue for additional iterations after norm reaches
stopping criterion. */
if (nrm < stpcrt) {
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.f / snrm2_(&blksiz, &WORK(indrv1 + 1), &c__1);
jmax = isamax_(&blksiz, &WORK(indrv1 + 1), &c__1);
if (WORK(indrv1 + jmax) < 0.f) {
scl = -(doublereal)scl;
}
sscal_(&blksiz, &scl, &WORK(indrv1 + 1), &c__1);
L120:
i__3 = *n;
for (i = 1; i <= *n; ++i) {
Z(i,j) = 0.f;
/* L130: */
}
i__3 = blksiz;
for (i = 1; i <= blksiz; ++i) {
Z(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 SSTEIN */
} /* sstein_ */
/* Subroutine */ int slatdf_(integer *ijob, integer *n, real *z__, integer *
ldz, real *rhs, real *rdsum, real *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
=======
SLATDF uses the LU factorization of the n-by-n matrix Z computed by
SGETC2 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 SGETC2 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 SGECON, 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) REAL array, dimension (LDZ, N)
On entry, the LU part of the factorization of the n-by-n
matrix Z computed by SGETC2: Z = P * L * U * Q
LDZ (input) INTEGER
The leading dimension of the array Z. LDA >= max(1, N).
RHS (input/output) REAL 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) REAL
On entry, the sum of squares of computed contributions to
the Dif-estimate under computation by STGSYL, 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 STGSY2 is called by STGSYL.
RDSCAL (input/output) REAL
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 STGSY2 is called by
STGSYL.
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 real c_b23 = 1.f;
static real c_b37 = -1.f;
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer info;
static real temp;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
static real work[32];
static integer i__, j, k;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real pmone;
extern doublereal sasum_(integer *, real *, integer *);
static real sminu;
static integer iwork[8];
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), saxpy_(integer *, real *, real *, integer *, real *,
integer *);
static real splus;
extern /* Subroutine */ int sgesc2_(integer *, real *, integer *, real *,
integer *, integer *, real *);
static real bm, bp, xm[8], xp[8];
extern /* Subroutine */ int sgecon_(char *, integer *, real *, integer *,
real *, real *, real *, integer *, integer *), slassq_(
integer *, real *, integer *, real *, real *), slaswp_(integer *,
real *, 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;
slaswp_(&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.f;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
bp = rhs[j] + 1.f;
bm = rhs[j] - 1.f;
splus = 1.f;
/* 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 += sdot_(&i__2, &z___ref(j + 1, j), &c__1, &z___ref(j + 1,
j), &c__1);
i__2 = *n - j;
sminu = sdot_(&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.f;
}
/* Compute the remaining r.h.s. */
temp = -rhs[j];
i__2 = *n - j;
saxpy_(&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;
scopy_(&i__1, &rhs[1], &c__1, xp, &c__1);
xp[*n - 1] = rhs[*n] + 1.f;
rhs[*n] += -1.f;
splus = 0.f;
sminu = 0.f;
for (i__ = *n; i__ >= 1; --i__) {
temp = 1.f / 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 += (r__1 = xp[i__ - 1], dabs(r__1));
sminu += (r__1 = rhs[i__], dabs(r__1));
/* L30: */
}
if (splus > sminu) {
scopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Apply the permutations JPIV to the computed solution (RHS) */
i__1 = *n - 1;
slaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1);
/* Compute the sum of squares */
slassq_(n, &rhs[1], &c__1, rdscal, rdsum);
} else {
/* IJOB = 2, Compute approximate nullvector XM of Z */
sgecon_("I", n, &z__[z_offset], ldz, &c_b23, &temp, work, iwork, &
info);
scopy_(n, &work[*n], &c__1, xm, &c__1);
/* Compute RHS */
i__1 = *n - 1;
slaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1);
temp = 1.f / sqrt(sdot_(n, xm, &c__1, xm, &c__1));
sscal_(n, &temp, xm, &c__1);
scopy_(n, xm, &c__1, xp, &c__1);
saxpy_(n, &c_b23, &rhs[1], &c__1, xp, &c__1);
saxpy_(n, &c_b37, xm, &c__1, &rhs[1], &c__1);
sgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &temp);
sgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &temp);
if (sasum_(n, xp, &c__1) > sasum_(n, &rhs[1], &c__1)) {
scopy_(n, xp, &c__1, &rhs[1], &c__1);
}
/* Compute the sum of squares */
slassq_(n, &rhs[1], &c__1, rdscal, rdsum);
}
return 0;
/* End of SLATDF */
} /* slatdf_ */
/* Subroutine */
int slaein_(logical *rightv, logical *noinit, integer *n, real *h__, integer *ldh, real *wr, real *wi, real *vr, real *vi, real *b, integer *ldb, real *work, real *eps3, real *smlnum, real *bignum, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j;
real w, x, y;
integer i1, i2, i3;
real w1, ei, ej, xi, xr, rec;
integer its, ierr;
real temp, norm, vmax;
extern real snrm2_(integer *, real *, integer *);
real scale;
extern /* Subroutine */
int sscal_(integer *, real *, real *, integer *);
char trans[1];
real vcrit;
extern real sasum_(integer *, real *, integer *);
real rootn, vnorm;
extern real slapy2_(real *, real *);
real absbii, absbjj;
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */
int sladiv_(real *, real *, real *, real *, real * , real *);
char normin[1];
real nrmsml;
extern /* Subroutine */
int slatrs_(char *, char *, char *, char *, integer *, real *, integer *, real *, real *, real *, integer *);
real 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((real) (*n));
growto = .1f / rootn;
/* Computing MAX */
r__1 = 1.f;
r__2 = *eps3 * rootn; // , expr subst
nrmsml = max(r__1,r__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.f)
{
/* 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 = snrm2_(n, &vr[1], &c__1);
r__1 = *eps3 * rootn / max(vnorm,nrmsml);
sscal_(n, &r__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 ((r__1 = b[i__ + i__ * b_dim1], f2c_abs(r__1)) < f2c_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.f)
{
b[i__ + i__ * b_dim1] = *eps3;
}
x = ei / b[i__ + i__ * b_dim1];
if (x != 0.f)
{
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.f)
{
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 ((r__1 = b[j + j * b_dim1], f2c_abs(r__1)) < f2c_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.f)
{
b[j + j * b_dim1] = *eps3;
}
x = ej / b[j + j * b_dim1];
if (x != 0.f)
{
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.f)
{
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. */
slatrs_("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 = sasum_(n, &vr[1], &c__1);
if (vnorm >= growto * scale)
{
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
temp = *eps3 / (rootn + 1.f);
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__ = isamax_(n, &vr[1], &c__1);
r__2 = 1.f / (r__1 = vr[i__], f2c_abs(r__1));
sscal_(n, &r__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.f;
/* L130: */
}
}
else
{
/* Scale supplied initial vector. */
r__1 = snrm2_(n, &vr[1], &c__1);
r__2 = snrm2_(n, &vi[1], &c__1);
norm = slapy2_(&r__1, &r__2);
rec = *eps3 * rootn / max(norm,nrmsml);
sscal_(n, &rec, &vr[1], &c__1);
sscal_(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.f;
/* L140: */
}
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
absbii = slapy2_(&b[i__ + i__ * b_dim1], &b[i__ + 1 + i__ * b_dim1]);
ei = h__[i__ + 1 + i__ * h_dim1];
if (absbii < f2c_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.f;
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.f;
/* 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.f)
{
b[i__ + i__ * b_dim1] = *eps3;
b[i__ + 1 + i__ * b_dim1] = 0.f;
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__] = sasum_(&i__2, &b[i__ + (i__ + 1) * b_dim1], ldb) + sasum_(&i__3, &b[i__ + 2 + i__ * b_dim1], &c__1);
/* L170: */
}
if (b[*n + *n * b_dim1] == 0.f && b[*n + 1 + *n * b_dim1] == 0.f)
{
b[*n + *n * b_dim1] = *eps3;
}
work[*n] = 0.f;
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.f;
/* L180: */
}
for (j = *n;
j >= 2;
--j)
{
ej = h__[j + (j - 1) * h_dim1];
absbjj = slapy2_(&b[j + j * b_dim1], &b[j + 1 + j * b_dim1]);
if (absbjj < f2c_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.f;
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.f;
/* 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.f)
{
b[j + j * b_dim1] = *eps3;
b[j + 1 + j * b_dim1] = 0.f;
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] = sasum_(&i__1, &b[j * b_dim1 + 1], &c__1) + sasum_(& i__2, &b[j + 1 + b_dim1], ldb);
/* L210: */
}
if (b[b_dim1 + 1] == 0.f && b[b_dim1 + 2] == 0.f)
{
b[b_dim1 + 1] = *eps3;
}
work[1] = 0.f;
i1 = 1;
i2 = *n;
i3 = 1;
}
i__1 = *n;
for (its = 1;
its <= i__1;
++its)
{
scale = 1.f;
vmax = 1.f;
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.f / vmax;
sscal_(n, &rec, &vr[1], &c__1);
sscal_(n, &rec, &vi[1], &c__1);
scale *= rec;
vmax = 1.f;
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 = (r__1 = b[i__ + i__ * b_dim1], f2c_abs(r__1)) + (r__2 = b[i__ + 1 + i__ * b_dim1], f2c_abs(r__2));
if (w > *smlnum)
{
if (w < 1.f)
{
w1 = f2c_abs(xr) + f2c_abs(xi);
if (w1 > w * *bignum)
{
rec = 1.f / w1;
sscal_(n, &rec, &vr[1], &c__1);
sscal_(n, &rec, &vi[1], &c__1);
xr = vr[i__];
xi = vi[i__];
scale *= rec;
vmax *= rec;
}
}
/* Divide by diagonal element of B. */
sladiv_(&xr, &xi, &b[i__ + i__ * b_dim1], &b[i__ + 1 + i__ * b_dim1], &vr[i__], &vi[i__]);
/* Computing MAX */
r__3 = (r__1 = vr[i__], f2c_abs(r__1)) + (r__2 = vi[i__], f2c_abs( r__2));
vmax = max(r__3,vmax);
vcrit = *bignum / vmax;
}
else
{
i__4 = *n;
for (j = 1;
j <= i__4;
++j)
{
vr[j] = 0.f;
vi[j] = 0.f;
/* L240: */
}
vr[i__] = 1.f;
vi[i__] = 1.f;
scale = 0.f;
vmax = 1.f;
vcrit = *bignum;
}
/* L250: */
}
/* Test for sufficient growth in the norm of (VR,VI). */
vnorm = sasum_(n, &vr[1], &c__1) + sasum_(n, &vi[1], &c__1);
if (vnorm >= growto * scale)
{
goto L280;
}
/* Choose a new orthogonal starting vector and try again. */
y = *eps3 / (rootn + 1.f);
vr[1] = *eps3;
vi[1] = 0.f;
i__3 = *n;
for (i__ = 2;
i__ <= i__3;
++i__)
{
vr[i__] = y;
vi[i__] = 0.f;
/* L260: */
}
vr[*n - its + 1] -= *eps3 * rootn;
/* L270: */
}
/* Failure to find eigenvector in N iterations */
*info = 1;
L280: /* Normalize eigenvector. */
vnorm = 0.f;
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Computing MAX */
r__3 = vnorm;
r__4 = (r__1 = vr[i__], f2c_abs(r__1)) + (r__2 = vi[i__] , f2c_abs(r__2)); // , expr subst
vnorm = max(r__3,r__4);
/* L290: */
}
r__1 = 1.f / vnorm;
sscal_(n, &r__1, &vr[1], &c__1);
r__1 = 1.f / vnorm;
sscal_(n, &r__1, &vi[1], &c__1);
}
return 0;
/* End of SLAEIN */
}
int sp_sget02(char *trans, int m, int n, int nrhs, SuperMatrix *A,
float *x, int ldx, float *b, int ldb, float *resid)
{
/*
Purpose
=======
SP_SGET02 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) SuperMatrix*, dimension (LDA,N)
The original M x N sparse matrix A.
X (input) FLOAT 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) FLOAT 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) FLOAT PRECISION
The maximum over the number of right hand sides of
norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
=====================================================================
*/
/* Table of constant values */
float alpha = -1.;
float beta = 1.;
int c__1 = 1;
/* System generated locals */
float d__1, d__2;
/* Local variables */
int j;
int n1, n2;
float anorm, bnorm;
float xnorm;
float eps;
/* Function prototypes */
extern int lsame_(char *, char *);
extern float slangs(char *, SuperMatrix *);
extern float sasum_(int *, float *, int *);
extern double slamch_(char *);
/* 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 = slamch_("Epsilon");
anorm = slangs("1", A);
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Compute B - A*X (or B - A'*X ) and store in B. */
sp_sgemm(trans, "N", n1, nrhs, n2, alpha, A, x, ldx, beta, b, ldb);
/* Compute the maximum over the number of right hand sides of
norm(B - A*X) / ( norm(A) * norm(X) * EPS ) . */
*resid = 0.;
for (j = 0; j < nrhs; ++j) {
bnorm = sasum_(&n1, &b[j*ldb], &c__1);
xnorm = sasum_(&n2, &x[j*ldx], &c__1);
if (xnorm <= 0.) {
*resid = 1. / eps;
} else {
/* Computing MAX */
d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
*resid = SUPERLU_MAX(d__1, d__2);
}
}
return 0;
} /* sp_sget02 */
/* Subroutine */ int sqrt16_(char *trans, integer *m, integer *n, integer *
nrhs, real *a, integer *lda, real *x, integer *ldx, real *b, integer *
ldb, real *rwork, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2;
/* Local variables */
integer j, n1, n2;
real eps;
real anorm, bnorm;
real xnorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SQRT16 computes the residual for a solution of a system of linear */
/* equations A*x = b or A'*x = b: */
/* RESID = norm(B - A*X) / ( max(m,n) * 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) REAL 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) REAL 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) REAL 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) REAL array, dimension (M) */
/* RESID (output) REAL */
/* The maximum over the number of right hand sides of */
/* norm(B - A*X) / ( max(m,n) * 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.f;
return 0;
}
if (lsame_(trans, "T") || lsame_(trans, "C")) {
anorm = slange_("I", m, n, &a[a_offset], lda, &rwork[1]);
n1 = *n;
n2 = *m;
} else {
anorm = slange_("1", m, n, &a[a_offset], lda, &rwork[1]);
n1 = *m;
n2 = *n;
}
eps = slamch_("Epsilon");
/* Compute B - A*X (or B - A'*X ) and store in B. */
sgemm_(trans, "No transpose", &n1, nrhs, &n2, &c_b8, &a[a_offset], lda, &
x[x_offset], ldx, &c_b9, &b[b_offset], ldb)
;
/* Compute the maximum over the number of right hand sides of */
/* norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ) . */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bnorm = sasum_(&n1, &b[j * b_dim1 + 1], &c__1);
xnorm = sasum_(&n2, &x[j * x_dim1 + 1], &c__1);
if (anorm == 0.f && bnorm == 0.f) {
*resid = 0.f;
} else if (anorm <= 0.f || xnorm <= 0.f) {
*resid = 1.f / eps;
} else {
/* Computing MAX */
r__1 = *resid, r__2 = bnorm / anorm / xnorm / (max(*m,*n) * eps);
*resid = dmax(r__1,r__2);
}
/* L10: */
}
return 0;
/* End of SQRT16 */
} /* sqrt16_ */
/* Subroutine */ int sbdt03_(char *uplo, integer *n, integer *kd, real *d__,
real *e, real *u, integer *ldu, real *s, real *vt, integer *ldvt,
real *work, real *resid)
{
/* System generated locals */
integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2;
real r__1, r__2, r__3, r__4;
/* Local variables */
integer i__, j;
real eps;
extern logical lsame_(char *, char *);
real bnorm;
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *);
extern doublereal sasum_(integer *, real *, integer *), slamch_(char *);
extern integer isamax_(integer *, real *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SBDT03 reconstructs a bidiagonal matrix B from its SVD: */
/* S = U' * B * V */
/* where U and V are orthogonal matrices and S is diagonal. */
/* The test ratio to test the singular value decomposition is */
/* RESID = norm( B - U * S * VT ) / ( n * norm(B) * EPS ) */
/* where VT = V' and EPS is the machine precision. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix B is upper or lower bidiagonal. */
/* = 'U': Upper bidiagonal */
/* = 'L': Lower bidiagonal */
/* N (input) INTEGER */
/* The order of the matrix B. */
/* KD (input) INTEGER */
/* The bandwidth of the bidiagonal matrix B. If KD = 1, the */
/* matrix B is bidiagonal, and if KD = 0, B is diagonal and E is */
/* not referenced. If KD is greater than 1, it is assumed to be */
/* 1, and if KD is less than 0, it is assumed to be 0. */
/* D (input) REAL array, dimension (N) */
/* The n diagonal elements of the bidiagonal matrix B. */
/* E (input) REAL array, dimension (N-1) */
/* The (n-1) superdiagonal elements of the bidiagonal matrix B */
/* if UPLO = 'U', or the (n-1) subdiagonal elements of B if */
/* UPLO = 'L'. */
/* U (input) REAL array, dimension (LDU,N) */
/* The n by n orthogonal matrix U in the reduction B = U'*A*P. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,N) */
/* S (input) REAL array, dimension (N) */
/* The singular values from the SVD of B, sorted in decreasing */
/* order. */
/* VT (input) REAL array, dimension (LDVT,N) */
/* The n by n orthogonal matrix V' in the reduction */
/* B = U * S * V'. */
/* LDVT (input) INTEGER */
/* The leading dimension of the array VT. */
/* WORK (workspace) REAL array, dimension (2*N) */
/* RESID (output) REAL */
/* The test ratio: norm(B - U * S * V') / ( n * norm(A) * EPS ) */
/* ====================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--s;
vt_dim1 = *ldvt;
vt_offset = 1 + vt_dim1;
vt -= vt_offset;
--work;
/* Function Body */
*resid = 0.f;
if (*n <= 0) {
return 0;
}
/* Compute B - U * S * V' one column at a time. */
bnorm = 0.f;
if (*kd >= 1) {
/* B is bidiagonal. */
if (lsame_(uplo, "U")) {
/* B is upper bidiagonal. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = s[i__] * vt[i__ + j * vt_dim1];
/* L10: */
}
sgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*
n + 1], &c__1, &c_b8, &work[1], &c__1);
work[j] += d__[j];
if (j > 1) {
work[j - 1] += e[j - 1];
/* Computing MAX */
r__3 = bnorm, r__4 = (r__1 = d__[j], dabs(r__1)) + (r__2 =
e[j - 1], dabs(r__2));
bnorm = dmax(r__3,r__4);
} else {
/* Computing MAX */
r__2 = bnorm, r__3 = (r__1 = d__[j], dabs(r__1));
bnorm = dmax(r__2,r__3);
}
/* Computing MAX */
r__1 = *resid, r__2 = sasum_(n, &work[1], &c__1);
*resid = dmax(r__1,r__2);
/* L20: */
}
} else {
/* B is lower bidiagonal. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = s[i__] * vt[i__ + j * vt_dim1];
/* L30: */
}
sgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*
n + 1], &c__1, &c_b8, &work[1], &c__1);
work[j] += d__[j];
if (j < *n) {
work[j + 1] += e[j];
/* Computing MAX */
r__3 = bnorm, r__4 = (r__1 = d__[j], dabs(r__1)) + (r__2 =
e[j], dabs(r__2));
bnorm = dmax(r__3,r__4);
} else {
/* Computing MAX */
r__2 = bnorm, r__3 = (r__1 = d__[j], dabs(r__1));
bnorm = dmax(r__2,r__3);
}
/* Computing MAX */
r__1 = *resid, r__2 = sasum_(n, &work[1], &c__1);
*resid = dmax(r__1,r__2);
/* L40: */
}
}
} else {
/* B is diagonal. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
work[*n + i__] = s[i__] * vt[i__ + j * vt_dim1];
/* L50: */
}
sgemv_("No transpose", n, n, &c_b6, &u[u_offset], ldu, &work[*n +
1], &c__1, &c_b8, &work[1], &c__1);
work[j] += d__[j];
/* Computing MAX */
r__1 = *resid, r__2 = sasum_(n, &work[1], &c__1);
*resid = dmax(r__1,r__2);
/* L60: */
}
j = isamax_(n, &d__[1], &c__1);
bnorm = (r__1 = d__[j], dabs(r__1));
}
/* Compute norm(B - U * S * V') / ( n * norm(B) * EPS ) */
eps = slamch_("Precision");
if (bnorm <= 0.f) {
if (*resid != 0.f) {
*resid = 1.f / eps;
}
} else {
if (bnorm >= *resid) {
*resid = *resid / bnorm / ((real) (*n) * eps);
} else {
if (bnorm < 1.f) {
/* Computing MIN */
r__1 = *resid, r__2 = (real) (*n) * bnorm;
*resid = dmin(r__1,r__2) / bnorm / ((real) (*n) * eps);
} else {
/* Computing MIN */
r__1 = *resid / bnorm, r__2 = (real) (*n);
*resid = dmin(r__1,r__2) / ((real) (*n) * eps);
}
}
}
return 0;
/* End of SBDT03 */
} /* sbdt03_ */
/* DECK SPINIT */
/* Subroutine */ int spinit_(integer *mrelas, integer *nvars__, real *costs,
real *bl, real *bu, integer *ind, real *primal, integer *info, real *
amat, real *csc, real *costsc, real *colnrm, real *xlamda, real *
anorm, real *rhs, real *rhsnrm, integer *ibasis, integer *ibb,
integer *imat, logical *lopt)
{
/* System generated locals */
real r__1, r__2, r__3;
/* Local variables */
static integer i__, j, ip;
static real aij, one;
static integer n20041, n20007, n20070, n20019, n20028, n20056, n20066,
n20074, n20078;
static real cmax, csum, zero, scalr;
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static integer iplace;
static logical colscp, minprb, contin, usrbas, cstscp;
static real testsc;
extern /* Subroutine */ int pnnzrs_(integer *, real *, integer *, real *,
integer *, integer *);
/* ***BEGIN PROLOGUE SPINIT */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to SPLP */
/* ***LIBRARY SLATEC */
/* ***TYPE SINGLE PRECISION (SPINIT-S, DPINIT-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* 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/. */
/* /REAL (12 BLANKS)/DOUBLE PRECISION/,/SCOPY/DCOPY/ */
/* REVISED 810519-0900 */
/* REVISED YYMMDD-HHMM */
/* INITIALIZATION SUBROUTINE FOR SPLP(*) PACKAGE. */
/* ***SEE ALSO SPLP */
/* ***ROUTINES CALLED PNNZRS, SASUM, SCOPY */
/* ***REVISION HISTORY (YYMMDD) */
/* 811215 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890605 Removed unreferenced labels. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* ***END PROLOGUE SPINIT */
/* ***FIRST EXECUTABLE STATEMENT SPINIT */
/* Parameter adjustments */
--lopt;
--imat;
--ibb;
--ibasis;
--rhs;
--colnrm;
--csc;
--amat;
--primal;
--ind;
--bu;
--bl;
--costs;
/* Function Body */
zero = 0.f;
one = 1.f;
contin = lopt[1];
usrbas = lopt[2];
colscp = lopt[5];
cstscp = lopt[6];
minprb = lopt[7];
/* SCALE DATA. NORMALIZE BOUNDS. FORM COLUMN CHECK SUMS. */
goto L30001;
/* INITIALIZE ACTIVE BASIS MATRIX. */
L20002:
goto L30002;
L20003:
return 0;
/* PROCEDURE (SCALE DATA. NORMALIZE BOUNDS. FORM COLUMN CHECK SUMS) */
/* DO COLUMN SCALING IF NOT PROVIDED BY THE USER. */
L30001:
if (colscp) {
goto L20004;
}
j = 1;
n20007 = *nvars__;
goto L20008;
L20007:
++j;
L20008:
if (n20007 - j < 0) {
goto L20009;
}
cmax = zero;
i__ = 0;
L20011:
pnnzrs_(&i__, &aij, &iplace, &amat[1], &imat[1], &j);
if (! (i__ == 0)) {
goto L20013;
}
goto L20012;
L20013:
/* Computing MAX */
r__1 = cmax, r__2 = dabs(aij);
cmax = dmax(r__1,r__2);
goto L20011;
L20012:
if (! (cmax == zero)) {
goto L20016;
}
csc[j] = one;
goto L20017;
L20016:
csc[j] = one / cmax;
L20017:
goto L20007;
L20009:
/* FORM CHECK SUMS OF COLUMNS. COMPUTE MATRIX NORM OF SCALED MATRIX. */
L20004:
*anorm = zero;
j = 1;
n20019 = *nvars__;
goto L20020;
L20019:
++j;
L20020:
if (n20019 - j < 0) {
goto L20021;
}
primal[j] = zero;
csum = zero;
i__ = 0;
L20023:
pnnzrs_(&i__, &aij, &iplace, &amat[1], &imat[1], &j);
if (! (i__ <= 0)) {
goto L20025;
}
goto L20024;
L20025:
primal[j] += aij;
csum += dabs(aij);
goto L20023;
L20024:
if (ind[j] == 2) {
csc[j] = -csc[j];
}
primal[j] *= csc[j];
colnrm[j] = (r__1 = csc[j] * csum, dabs(r__1));
/* Computing MAX */
r__1 = *anorm, r__2 = colnrm[j];
*anorm = dmax(r__1,r__2);
goto L20019;
/* IF THE USER HAS NOT PROVIDED COST VECTOR SCALING THEN SCALE IT */
/* USING THE MAX. NORM OF THE TRANSFORMED COST VECTOR, IF NONZERO. */
L20021:
testsc = zero;
j = 1;
n20028 = *nvars__;
goto L20029;
L20028:
++j;
L20029:
if (n20028 - j < 0) {
goto L20030;
}
/* Computing MAX */
r__2 = testsc, r__3 = (r__1 = csc[j] * costs[j], dabs(r__1));
testsc = dmax(r__2,r__3);
goto L20028;
L20030:
if (cstscp) {
goto L20032;
}
if (! (testsc > zero)) {
goto L20035;
}
*costsc = one / testsc;
goto L20036;
L20035:
*costsc = one;
L20036:
L20032:
*xlamda = (*costsc + *costsc) * testsc;
if (*xlamda == zero) {
*xlamda = one;
}
/* IF MAXIMIZATION PROBLEM, THEN CHANGE SIGN OF COSTSC AND LAMDA */
/* =WEIGHT FOR PENALTY-FEASIBILITY METHOD. */
if (minprb) {
goto L20038;
}
*costsc = -(*costsc);
L20038:
goto L20002;
/* :CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC */
/* PROCEDURE (INITIALIZE RHS(*),IBASIS(*), AND IBB(*)) */
/* INITIALLY SET RIGHT-HAND SIDE VECTOR TO ZERO. */
L30002:
scopy_(mrelas, &zero, &c__0, &rhs[1], &c__1);
/* TRANSLATE RHS ACCORDING TO CLASSIFICATION OF INDEPENDENT VARIABLES */
j = 1;
n20041 = *nvars__;
goto L20042;
L20041:
++j;
L20042:
if (n20041 - j < 0) {
goto L20043;
}
if (! (ind[j] == 1)) {
goto L20045;
}
scalr = -bl[j];
goto L20046;
L20045:
if (! (ind[j] == 2)) {
goto L10001;
}
scalr = -bu[j];
goto L20046;
L10001:
if (! (ind[j] == 3)) {
goto L10002;
}
scalr = -bl[j];
goto L20046;
L10002:
if (! (ind[j] == 4)) {
goto L10003;
}
scalr = zero;
L10003:
L20046:
if (! (scalr != zero)) {
goto L20048;
}
i__ = 0;
L20051:
pnnzrs_(&i__, &aij, &iplace, &amat[1], &imat[1], &j);
if (! (i__ <= 0)) {
goto L20053;
}
goto L20052;
L20053:
rhs[i__] = scalr * aij + rhs[i__];
goto L20051;
L20052:
L20048:
goto L20041;
/* TRANSLATE RHS ACCORDING TO CLASSIFICATION OF DEPENDENT VARIABLES. */
L20043:
i__ = *nvars__ + 1;
n20056 = *nvars__ + *mrelas;
goto L20057;
L20056:
++i__;
L20057:
if (n20056 - i__ < 0) {
goto L20058;
}
if (! (ind[i__] == 1)) {
goto L20060;
}
scalr = bl[i__];
goto L20061;
L20060:
if (! (ind[i__] == 2)) {
goto L10004;
}
scalr = bu[i__];
goto L20061;
L10004:
if (! (ind[i__] == 3)) {
goto L10005;
}
scalr = bl[i__];
goto L20061;
L10005:
if (! (ind[i__] == 4)) {
goto L10006;
}
scalr = zero;
L10006:
L20061:
rhs[i__ - *nvars__] += scalr;
goto L20056;
L20058:
*rhsnrm = sasum_(mrelas, &rhs[1], &c__1);
/* IF THIS IS NOT A CONTINUATION OR THE USER HAS NOT PROVIDED THE */
/* INITIAL BASIS, THEN THE INITIAL BASIS IS COMPRISED OF THE */
/* DEPENDENT VARIABLES. */
if (contin || usrbas) {
goto L20063;
}
j = 1;
n20066 = *mrelas;
goto L20067;
L20066:
++j;
L20067:
if (n20066 - j < 0) {
goto L20068;
}
ibasis[j] = *nvars__ + j;
goto L20066;
L20068:
/* DEFINE THE ARRAY IBB(*) */
L20063:
j = 1;
n20070 = *nvars__ + *mrelas;
goto L20071;
L20070:
++j;
L20071:
if (n20070 - j < 0) {
goto L20072;
}
ibb[j] = 1;
goto L20070;
L20072:
j = 1;
n20074 = *mrelas;
goto L20075;
L20074:
++j;
L20075:
if (n20074 - j < 0) {
goto L20076;
}
ibb[ibasis[j]] = -1;
goto L20074;
/* DEFINE THE REST OF IBASIS(*) */
L20076:
ip = *mrelas;
j = 1;
n20078 = *nvars__ + *mrelas;
goto L20079;
L20078:
++j;
L20079:
if (n20078 - j < 0) {
goto L20080;
}
if (! (ibb[j] > 0)) {
goto L20082;
}
++ip;
ibasis[ip] = j;
L20082:
goto L20078;
L20080:
goto L20003;
} /* spinit_ */
int slaein_(int *rightv, int *noinit, int *n,
float *h__, int *ldh, float *wr, float *wi, float *vr, float *vi, float
*b, int *ldb, float *work, float *eps3, float *smlnum, float *bignum,
int *info)
{
/* System generated locals */
int b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4;
float r__1, r__2, r__3, r__4;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int i__, j;
float w, x, y;
int i1, i2, i3;
float w1, ei, ej, xi, xr, rec;
int its, ierr;
float temp, norm, vmax;
extern double snrm2_(int *, float *, int *);
float scale;
extern int sscal_(int *, float *, float *, int *);
char trans[1];
float vcrit;
extern double sasum_(int *, float *, int *);
float rootn, vnorm;
extern double slapy2_(float *, float *);
float absbii, absbjj;
extern int isamax_(int *, float *, int *);
extern int sladiv_(float *, float *, float *, float *, float *
, float *);
char normin[1];
float nrmsml;
extern int slatrs_(char *, char *, char *, char *,
int *, float *, int *, float *, float *, float *, int *);
float growto;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAEIN uses inverse iteration to find a right or left eigenvector */
/* corresponding to the eigenvalue (WR,WI) of a float upper Hessenberg */
/* matrix H. */
/* Arguments */
/* ========= */
/* RIGHTV (input) LOGICAL */
/* = .TRUE. : compute right eigenvector; */
/* = .FALSE.: compute left eigenvector. */
/* NOINIT (input) LOGICAL */
/* = .TRUE. : no initial vector supplied in (VR,VI). */
/* = .FALSE.: initial vector supplied in (VR,VI). */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* H (input) REAL array, dimension (LDH,N) */
/* The upper Hessenberg matrix H. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= MAX(1,N). */
/* WR (input) REAL */
/* WI (input) REAL */
/* The float and imaginary parts of the eigenvalue of H whose */
/* corresponding right or left eigenvector is to be computed. */
/* VR (input/output) REAL array, dimension (N) */
/* VI (input/output) REAL array, dimension (N) */
/* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain */
/* a float starting vector for inverse iteration using the float */
/* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI */
/* must contain the float and imaginary parts of a complex */
/* starting vector for inverse iteration using the complex */
/* eigenvalue (WR,WI); otherwise VR and VI need not be set. */
/* On exit, if WI = 0.0 (float eigenvalue), VR contains the */
/* computed float eigenvector; if WI.ne.0.0 (complex eigenvalue), */
/* VR and VI contain the float and imaginary parts of the */
/* computed complex eigenvector. The eigenvector is normalized */
/* so that the component of largest magnitude has magnitude 1; */
/* here the magnitude of a complex number (x,y) is taken to be */
/* |x| + |y|. */
/* VI is not referenced if WI = 0.0. */
/* B (workspace) REAL array, dimension (LDB,N) */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= N+1. */
/* WORK (workspace) REAL array, dimension (N) */
/* EPS3 (input) REAL */
/* A small machine-dependent value which is used to perturb */
/* close eigenvalues, and to replace zero pivots. */
/* SMLNUM (input) REAL */
/* A machine-dependent value close to the underflow threshold. */
/* BIGNUM (input) REAL */
/* A machine-dependent value close to the overflow threshold. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* = 1: inverse iteration did not converge; VR is set to the */
/* last iterate, and so is VI if WI.ne.0.0. */
/* ===================================================================== */
/* .. 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((float) (*n));
growto = .1f / rootn;
/* Computing MAX */
r__1 = 1.f, r__2 = *eps3 * rootn;
nrmsml = MAX(r__1,r__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.f) {
/* 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 = snrm2_(n, &vr[1], &c__1);
r__1 = *eps3 * rootn / MAX(vnorm,nrmsml);
sscal_(n, &r__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 ((r__1 = b[i__ + i__ * b_dim1], ABS(r__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.f) {
b[i__ + i__ * b_dim1] = *eps3;
}
x = ei / b[i__ + i__ * b_dim1];
if (x != 0.f) {
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.f) {
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 ((r__1 = b[j + j * b_dim1], ABS(r__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.f) {
b[j + j * b_dim1] = *eps3;
}
x = ej / b[j + j * b_dim1];
if (x != 0.f) {
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.f) {
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'*x = scale*v for a left eigenvector, */
/* overwriting x on v. */
slatrs_("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 = sasum_(n, &vr[1], &c__1);
if (vnorm >= growto * scale) {
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
temp = *eps3 / (rootn + 1.f);
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__ = isamax_(n, &vr[1], &c__1);
r__2 = 1.f / (r__1 = vr[i__], ABS(r__1));
sscal_(n, &r__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.f;
/* L130: */
}
} else {
/* Scale supplied initial vector. */
r__1 = snrm2_(n, &vr[1], &c__1);
r__2 = snrm2_(n, &vi[1], &c__1);
norm = slapy2_(&r__1, &r__2);
rec = *eps3 * rootn / MAX(norm,nrmsml);
sscal_(n, &rec, &vr[1], &c__1);
sscal_(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.f;
/* L140: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
absbii = slapy2_(&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.f;
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.f;
/* 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.f) {
b[i__ + i__ * b_dim1] = *eps3;
b[i__ + 1 + i__ * b_dim1] = 0.f;
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__] = sasum_(&i__2, &b[i__ + (i__ + 1) * b_dim1], ldb)
+ sasum_(&i__3, &b[i__ + 2 + i__ * b_dim1], &c__1);
/* L170: */
}
if (b[*n + *n * b_dim1] == 0.f && b[*n + 1 + *n * b_dim1] == 0.f)
{
b[*n + *n * b_dim1] = *eps3;
}
work[*n] = 0.f;
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.f;
/* L180: */
}
for (j = *n; j >= 2; --j) {
ej = h__[j + (j - 1) * h_dim1];
absbjj = slapy2_(&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.f;
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.f;
/* 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.f) {
b[j + j * b_dim1] = *eps3;
b[j + 1 + j * b_dim1] = 0.f;
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] = sasum_(&i__1, &b[j * b_dim1 + 1], &c__1) + sasum_(&
i__2, &b[j + 1 + b_dim1], ldb);
/* L210: */
}
if (b[b_dim1 + 1] == 0.f && b[b_dim1 + 2] == 0.f) {
b[b_dim1 + 1] = *eps3;
}
work[1] = 0.f;
i1 = 1;
i2 = *n;
i3 = 1;
}
i__1 = *n;
for (its = 1; its <= i__1; ++its) {
scale = 1.f;
vmax = 1.f;
vcrit = *bignum;
/* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector, */
/* or U'*(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.f / vmax;
sscal_(n, &rec, &vr[1], &c__1);
sscal_(n, &rec, &vi[1], &c__1);
scale *= rec;
vmax = 1.f;
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 = (r__1 = b[i__ + i__ * b_dim1], ABS(r__1)) + (r__2 = b[
i__ + 1 + i__ * b_dim1], ABS(r__2));
if (w > *smlnum) {
if (w < 1.f) {
w1 = ABS(xr) + ABS(xi);
if (w1 > w * *bignum) {
rec = 1.f / w1;
sscal_(n, &rec, &vr[1], &c__1);
sscal_(n, &rec, &vi[1], &c__1);
xr = vr[i__];
xi = vi[i__];
scale *= rec;
vmax *= rec;
}
}
/* Divide by diagonal element of B. */
sladiv_(&xr, &xi, &b[i__ + i__ * b_dim1], &b[i__ + 1 +
i__ * b_dim1], &vr[i__], &vi[i__]);
/* Computing MAX */
r__3 = (r__1 = vr[i__], ABS(r__1)) + (r__2 = vi[i__],
ABS(r__2));
vmax = MAX(r__3,vmax);
vcrit = *bignum / vmax;
} else {
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
vr[j] = 0.f;
vi[j] = 0.f;
/* L240: */
}
vr[i__] = 1.f;
vi[i__] = 1.f;
scale = 0.f;
vmax = 1.f;
vcrit = *bignum;
}
/* L250: */
}
/* Test for sufficient growth in the norm of (VR,VI). */
vnorm = sasum_(n, &vr[1], &c__1) + sasum_(n, &vi[1], &c__1);
if (vnorm >= growto * scale) {
goto L280;
}
/* Choose a new orthogonal starting vector and try again. */
y = *eps3 / (rootn + 1.f);
vr[1] = *eps3;
vi[1] = 0.f;
i__3 = *n;
for (i__ = 2; i__ <= i__3; ++i__) {
vr[i__] = y;
vi[i__] = 0.f;
/* L260: */
}
vr[*n - its + 1] -= *eps3 * rootn;
/* L270: */
}
/* Failure to find eigenvector in N iterations */
*info = 1;
L280:
/* Normalize eigenvector. */
vnorm = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__3 = vnorm, r__4 = (r__1 = vr[i__], ABS(r__1)) + (r__2 = vi[
i__], ABS(r__2));
vnorm = MAX(r__3,r__4);
/* L290: */
}
r__1 = 1.f / vnorm;
sscal_(n, &r__1, &vr[1], &c__1);
r__1 = 1.f / vnorm;
sscal_(n, &r__1, &vi[1], &c__1);
}
return 0;
/* End of SLAEIN */
} /* slaein_ */
/*! \brief
* <pre>
* Purpose
* =======
* ilu_sdrop_row() - Drop some small rows from the previous
* supernode (L-part only).
* </pre>
*/
int ilu_sdrop_row(
superlu_options_t *options, /* options */
int first, /* index of the first column in the supernode */
int last, /* index of the last column in the supernode */
double drop_tol, /* dropping parameter */
int quota, /* maximum nonzero entries allowed */
int *nnzLj, /* in/out number of nonzeros in L(:, 1:last) */
double *fill_tol, /* in/out - on exit, fill_tol=-num_zero_pivots,
* does not change if options->ILU_MILU != SMILU1 */
GlobalLU_t *Glu, /* modified */
float swork[], /* working space
* the length of swork[] should be no less than
* the number of rows in the supernode */
float swork2[], /* working space with the same size as swork[],
* used only by the second dropping rule */
int lastc /* if lastc == 0, there is nothing after the
* working supernode [first:last];
* if lastc == 1, there is one more column after
* the working supernode. */ )
{
register int i, j, k, m1;
register int nzlc; /* number of nonzeros in column last+1 */
register int xlusup_first, xlsub_first;
int m, n; /* m x n is the size of the supernode */
int r = 0; /* number of dropped rows */
register float *temp;
register float *lusup = Glu->lusup;
register int *lsub = Glu->lsub;
register int *xlsub = Glu->xlsub;
register int *xlusup = Glu->xlusup;
register float d_max = 0.0, d_min = 1.0;
int drop_rule = options->ILU_DropRule;
milu_t milu = options->ILU_MILU;
norm_t nrm = options->ILU_Norm;
float zero = 0.0;
float one = 1.0;
float none = -1.0;
int i_1 = 1;
int inc_diag; /* inc_diag = m + 1 */
int nzp = 0; /* number of zero pivots */
float alpha = pow((double)(Glu->n), -1.0 / options->ILU_MILU_Dim);
xlusup_first = xlusup[first];
xlsub_first = xlsub[first];
m = xlusup[first + 1] - xlusup_first;
n = last - first + 1;
m1 = m - 1;
inc_diag = m + 1;
nzlc = lastc ? (xlusup[last + 2] - xlusup[last + 1]) : 0;
temp = swork - n;
/* Quick return if nothing to do. */
if (m == 0 || m == n || drop_rule == NODROP)
{
*nnzLj += m * n;
return 0;
}
/* basic dropping: ILU(tau) */
for (i = n; i <= m1; )
{
/* the average abs value of ith row */
switch (nrm)
{
case ONE_NORM:
temp[i] = sasum_(&n, &lusup[xlusup_first + i], &m) / (double)n;
break;
case TWO_NORM:
temp[i] = snrm2_(&n, &lusup[xlusup_first + i], &m)
/ sqrt((double)n);
break;
case INF_NORM:
default:
k = isamax_(&n, &lusup[xlusup_first + i], &m) - 1;
temp[i] = fabs(lusup[xlusup_first + i + m * k]);
break;
}
/* drop small entries due to drop_tol */
if (drop_rule & DROP_BASIC && temp[i] < drop_tol)
{
r++;
/* drop the current row and move the last undropped row here */
if (r > 1) /* add to last row */
{
/* accumulate the sum (for MILU) */
switch (milu)
{
case SMILU_1:
case SMILU_2:
saxpy_(&n, &one, &lusup[xlusup_first + i], &m,
&lusup[xlusup_first + m - 1], &m);
break;
case SMILU_3:
for (j = 0; j < n; j++)
lusup[xlusup_first + (m - 1) + j * m] +=
fabs(lusup[xlusup_first + i + j * m]);
break;
case SILU:
default:
break;
}
scopy_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
} /* if (r > 1) */
else /* move to last row */
{
sswap_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
if (milu == SMILU_3)
for (j = 0; j < n; j++) {
lusup[xlusup_first + m1 + j * m] =
fabs(lusup[xlusup_first + m1 + j * m]);
}
}
lsub[xlsub_first + i] = lsub[xlsub_first + m1];
m1--;
continue;
} /* if dropping */
else
{
if (temp[i] > d_max) d_max = temp[i];
if (temp[i] < d_min) d_min = temp[i];
}
i++;
} /* for */
/* Secondary dropping: drop more rows according to the quota. */
quota = ceil((double)quota / (double)n);
if (drop_rule & DROP_SECONDARY && m - r > quota)
{
register double tol = d_max;
/* Calculate the second dropping tolerance */
if (quota > n)
{
if (drop_rule & DROP_INTERP) /* by interpolation */
{
d_max = 1.0 / d_max; d_min = 1.0 / d_min;
tol = 1.0 / (d_max + (d_min - d_max) * quota / (m - n - r));
}
else /* by quick select */
{
int len = m1 - n + 1;
scopy_(&len, swork, &i_1, swork2, &i_1);
tol = sqselect(len, swork2, quota - n);
#if 0
register int *itemp = iwork - n;
A = temp;
for (i = n; i <= m1; i++) itemp[i] = i;
qsort(iwork, m1 - n + 1, sizeof(int), _compare_);
tol = temp[itemp[quota]];
#endif
}
}
for (i = n; i <= m1; )
{
if (temp[i] <= tol)
{
register int j;
r++;
/* drop the current row and move the last undropped row here */
if (r > 1) /* add to last row */
{
/* accumulate the sum (for MILU) */
switch (milu)
{
case SMILU_1:
case SMILU_2:
saxpy_(&n, &one, &lusup[xlusup_first + i], &m,
&lusup[xlusup_first + m - 1], &m);
break;
case SMILU_3:
for (j = 0; j < n; j++)
lusup[xlusup_first + (m - 1) + j * m] +=
fabs(lusup[xlusup_first + i + j * m]);
break;
case SILU:
default:
break;
}
scopy_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
} /* if (r > 1) */
else /* move to last row */
{
sswap_(&n, &lusup[xlusup_first + m1], &m,
&lusup[xlusup_first + i], &m);
if (milu == SMILU_3)
for (j = 0; j < n; j++) {
lusup[xlusup_first + m1 + j * m] =
fabs(lusup[xlusup_first + m1 + j * m]);
}
}
lsub[xlsub_first + i] = lsub[xlsub_first + m1];
m1--;
temp[i] = temp[m1];
continue;
}
i++;
} /* for */
} /* if secondary dropping */
for (i = n; i < m; i++) temp[i] = 0.0;
if (r == 0)
{
*nnzLj += m * n;
return 0;
}
/* add dropped entries to the diagnal */
if (milu != SILU)
{
register int j;
float t;
float omega;
for (j = 0; j < n; j++)
{
t = lusup[xlusup_first + (m - 1) + j * m];
if (t == zero) continue;
if (t > zero)
omega = SUPERLU_MIN(2.0 * (1.0 - alpha) / t, 1.0);
else
omega = SUPERLU_MAX(2.0 * (1.0 - alpha) / t, -1.0);
t *= omega;
switch (milu)
{
case SMILU_1:
if (t != none) {
lusup[xlusup_first + j * inc_diag] *= (one + t);
}
else
{
lusup[xlusup_first + j * inc_diag] *= *fill_tol;
#ifdef DEBUG
printf("[1] ZERO PIVOT: FILL col %d.\n", first + j);
fflush(stdout);
#endif
nzp++;
}
break;
case SMILU_2:
lusup[xlusup_first + j * inc_diag] *= (1.0 + fabs(t));
break;
case SMILU_3:
lusup[xlusup_first + j * inc_diag] *= (one + t);
break;
case SILU:
default:
break;
}
}
if (nzp > 0) *fill_tol = -nzp;
}
/* Remove dropped entries from the memory and fix the pointers. */
m1 = m - r;
for (j = 1; j < n; j++)
{
register int tmp1, tmp2;
tmp1 = xlusup_first + j * m1;
tmp2 = xlusup_first + j * m;
for (i = 0; i < m1; i++)
lusup[i + tmp1] = lusup[i + tmp2];
}
for (i = 0; i < nzlc; i++)
lusup[xlusup_first + i + n * m1] = lusup[xlusup_first + i + n * m];
for (i = 0; i < nzlc; i++)
lsub[xlsub[last + 1] - r + i] = lsub[xlsub[last + 1] + i];
for (i = first + 1; i <= last + 1; i++)
{
xlusup[i] -= r * (i - first);
xlsub[i] -= r;
}
if (lastc)
{
xlusup[last + 2] -= r * n;
xlsub[last + 2] -= r;
}
*nnzLj += (m - r) * n;
return r;
}
/* Subroutine */ int spbt02_(char *uplo, integer *n, integer *kd, integer *
nrhs, real *a, integer *lda, real *x, integer *ldx, real *b, integer *
ldb, real *rwork, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2;
/* Local variables */
static integer j;
static real anorm, bnorm;
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int ssbmv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *);
static real xnorm;
extern doublereal slamch_(char *), slansb_(char *, char *,
integer *, integer *, real *, integer *, real *);
static real 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
=======
SPBT02 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) REAL 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 SPBTRF for further details.
LDA (input) INTEGER.
The leading dimension of the array A. LDA >= max(1,KD+1).
X (input) REAL 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) REAL 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) REAL array, dimension (N)
RESID (output) REAL
The maximum over the number of right hand sides of
norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
=====================================================================
Quick exit if N = 0 or 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;
--rwork;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = slansb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute B - A*X */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ssbmv_(uplo, n, kd, &c_b5, &a[a_offset], lda, &x_ref(1, j), &c__1, &
c_b7, &b_ref(1, j), &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.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bnorm = sasum_(n, &b_ref(1, j), &c__1);
xnorm = sasum_(n, &x_ref(1, j), &c__1);
if (xnorm <= 0.f) {
*resid = 1.f / eps;
} else {
/* Computing MAX */
r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
*resid = dmax(r__1,r__2);
}
/* L20: */
}
return 0;
/* End of SPBT02 */
} /* spbt02_ */
/* DECK SGEIR */
/* Subroutine */ int sgeir_(real *a, integer *lda, integer *n, real *v,
integer *itask, integer *ind, real *work, integer *iwork)
{
/* System generated locals */
address a__1[4], a__2[3];
integer a_dim1, a_offset, work_dim1, work_offset, i__1[4], i__2[3], i__3;
real r__1, r__2, r__3;
char ch__1[40], ch__2[27], ch__3[31];
/* Local variables */
static integer j, info;
static char xern1[8], xern2[8];
extern /* Subroutine */ int sgefa_(real *, integer *, integer *, integer *
, integer *), sgesl_(real *, integer *, integer *, integer *,
real *, integer *);
static real dnorm;
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static real xnorm;
extern doublereal r1mach_(integer *), sdsdot_(integer *, real *, real *,
integer *, real *, integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___4 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___5 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___6 = { 0, xern1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE SGEIR */
/* ***PURPOSE Solve a general system of linear equations. Iterative */
/* refinement is used to obtain an error estimate. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY D2A1 */
/* ***TYPE SINGLE PRECISION (SGEIR-S, CGEIR-C) */
/* ***KEYWORDS COMPLEX LINEAR EQUATIONS, GENERAL MATRIX, */
/* GENERAL SYSTEM OF LINEAR EQUATIONS */
/* ***AUTHOR Voorhees, E. A., (LANL) */
/* ***DESCRIPTION */
/* Subroutine SGEIR solves a general NxN system of single */
/* precision linear equations using LINPACK subroutines SGEFA and */
/* SGESL. One pass of iterative refinement is used only to obtain */
/* an estimate of the accuracy. That is, if A is an NxN real */
/* matrix and if X and B are real N-vectors, then SGEIR solves */
/* the equation */
/* A*X=B. */
/* The matrix A is first factored into upper and lower tri- */
/* angular matrices U and L using partial pivoting. These */
/* factors and the pivoting information are used to calculate */
/* the solution, X. Then the residual vector is found and */
/* used to calculate an estimate of the relative error, IND. */
/* IND estimates the accuracy of the solution only when the */
/* input matrix and the right hand side are represented */
/* exactly in the computer and does not take into account */
/* any errors in the input data. */
/* If the equation A*X=B is to be solved for more than one vector */
/* B, the factoring of A does not need to be performed again and */
/* the option to solve only (ITASK .GT. 1) will be faster for */
/* the succeeding solutions. In this case, the contents of A, */
/* LDA, N, WORK, and IWORK must not have been altered by the */
/* user following factorization (ITASK=1). IND will not be */
/* changed by SGEIR in this case. */
/* Argument Description *** */
/* A REAL(LDA,N) */
/* the doubly subscripted array with dimension (LDA,N) */
/* which contains the coefficient matrix. A is not */
/* altered by the routine. */
/* LDA INTEGER */
/* the leading dimension of the array A. LDA must be great- */
/* er than or equal to N. (terminal error message IND=-1) */
/* N INTEGER */
/* the order of the matrix A. The first N elements of */
/* the array A are the elements of the first column of */
/* matrix A. N must be greater than or equal to 1. */
/* (terminal error message IND=-2) */
/* V REAL(N) */
/* on entry, the singly subscripted array(vector) of di- */
/* mension N which contains the right hand side B of a */
/* system of simultaneous linear equations A*X=B. */
/* on return, V contains the solution vector, X . */
/* ITASK INTEGER */
/* If ITASK=1, the matrix A is factored and then the */
/* linear equation is solved. */
/* If ITASK .GT. 1, the equation is solved using the existing */
/* factored matrix A (stored in WORK). */
/* If ITASK .LT. 1, then terminal error message IND=-3 is */
/* printed. */
/* IND INTEGER */
/* GT. 0 IND is a rough estimate of the number of digits */
/* of accuracy in the solution, X. IND=75 means */
/* that the solution vector X is zero. */
/* LT. 0 see error message corresponding to IND below. */
/* WORK REAL(N*(N+1)) */
/* a singly subscripted array of dimension at least N*(N+1). */
/* IWORK INTEGER(N) */
/* a singly subscripted array of dimension at least N. */
/* Error Messages Printed *** */
/* IND=-1 terminal N is greater than LDA. */
/* IND=-2 terminal N is less than one. */
/* IND=-3 terminal ITASK is less than one. */
/* IND=-4 terminal The matrix A is computationally singular. */
/* A solution has not been computed. */
/* IND=-10 warning The solution has no apparent significance. */
/* The solution may be inaccurate or the matrix */
/* A may be poorly scaled. */
/* Note- The above terminal(*fatal*) error messages are */
/* designed to be handled by XERMSG in which */
/* LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 */
/* for warning error messages from XERMSG. Unless */
/* the user provides otherwise, an error message */
/* will be printed followed by an abort. */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED R1MACH, SASUM, SCOPY, SDSDOT, SGEFA, SGESL, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800430 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) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE SGEIR */
/* ***FIRST EXECUTABLE STATEMENT SGEIR */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
work_dim1 = *n;
work_offset = 1 + work_dim1;
work -= work_offset;
--v;
--iwork;
/* Function Body */
if (*lda < *n) {
*ind = -1;
s_wsfi(&io___2);
do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___4);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 6, a__1[0] = "LDA = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " IS LESS THAN N = ";
i__1[3] = 8, a__1[3] = xern2;
s_cat(ch__1, a__1, i__1, &c__4, (ftnlen)40);
xermsg_("SLATEC", "SGEIR", ch__1, &c_n1, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)40);
return 0;
}
if (*n <= 0) {
*ind = -2;
s_wsfi(&io___5);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 4, a__2[0] = "N = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__2, a__2, i__2, &c__3, (ftnlen)27);
xermsg_("SLATEC", "SGEIR", ch__2, &c_n2, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)27);
return 0;
}
if (*itask < 1) {
*ind = -3;
s_wsfi(&io___6);
do_fio(&c__1, (char *)&(*itask), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 8, a__2[0] = "ITASK = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__3, a__2, i__2, &c__3, (ftnlen)31);
xermsg_("SLATEC", "SGEIR", ch__3, &c_n3, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)31);
return 0;
}
if (*itask == 1) {
/* MOVE MATRIX A TO WORK */
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
scopy_(n, &a[j * a_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &
c__1);
/* L10: */
}
/* FACTOR MATRIX A INTO LU */
sgefa_(&work[work_offset], n, n, &iwork[1], &info);
/* CHECK FOR COMPUTATIONALLY SINGULAR MATRIX */
if (info != 0) {
*ind = -4;
xermsg_("SLATEC", "SGEIR", "SINGULAR MATRIX A - NO SOLUTION", &
c_n4, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)31);
return 0;
}
}
/* SOLVE WHEN FACTORING COMPLETE */
/* MOVE VECTOR B TO WORK */
scopy_(n, &v[1], &c__1, &work[(*n + 1) * work_dim1 + 1], &c__1);
sgesl_(&work[work_offset], n, n, &iwork[1], &v[1], &c__0);
/* FORM NORM OF X0 */
xnorm = sasum_(n, &v[1], &c__1);
if (xnorm == 0.f) {
*ind = 75;
return 0;
}
/* COMPUTE RESIDUAL */
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
r__1 = -work[j + (*n + 1) * work_dim1];
work[j + (*n + 1) * work_dim1] = sdsdot_(n, &r__1, &a[j + a_dim1],
lda, &v[1], &c__1);
/* L40: */
}
/* SOLVE A*DELTA=R */
sgesl_(&work[work_offset], n, n, &iwork[1], &work[(*n + 1) * work_dim1 +
1], &c__0);
/* FORM NORM OF DELTA */
dnorm = sasum_(n, &work[(*n + 1) * work_dim1 + 1], &c__1);
/* COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) */
/* AND CHECK FOR IND GREATER THAN ZERO */
/* Computing MAX */
r__2 = r1mach_(&c__4), r__3 = dnorm / xnorm;
r__1 = dmax(r__2,r__3);
*ind = -r_lg10(&r__1);
if (*ind <= 0) {
*ind = -10;
xermsg_("SLATEC", "SGEIR", "SOLUTION MAY HAVE NO SIGNIFICANCE", &
c_n10, &c__0, (ftnlen)6, (ftnlen)5, (ftnlen)33);
}
return 0;
} /* sgeir_ */
/* Subroutine */ int slatbs_(char *uplo, char *trans, char *diag, char *
normin, integer *n, integer *kd, real *ab, integer *ldab, real *x,
real *scale, real *cnorm, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3;
/* Local variables */
integer i__, j;
real xj, rec, tjj;
integer jinc, jlen;
real xbnd;
integer imax;
real tmax, tjjs;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
real xmax, grow, sumj;
integer maind;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real tscal, uscal;
integer jlast;
extern doublereal sasum_(integer *, real *, integer *);
logical upper;
extern /* Subroutine */ int stbsv_(char *, char *, char *, integer *,
integer *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *,
integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
real bignum;
extern integer isamax_(integer *, real *, integer *);
logical notran;
integer jfirst;
real smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLATBS 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 band matrix. 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 STBSV 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. */
/* KD (input) INTEGER */
/* The number of subdiagonals or superdiagonals in the */
/* triangular matrix A. KD >= 0. */
/* AB (input) REAL 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/output) REAL 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) REAL */
/* 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) REAL 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, STBSV */
/* 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 STBSV 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 STBSV 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 */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_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 (*kd < 0) {
*info = -6;
} else if (*ldab < *kd + 1) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLATBS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = slamch_("Safe minimum") / slamch_("Precision");
bignum = 1.f / smlnum;
*scale = 1.f;
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) {
/* Computing MIN */
i__2 = *kd, i__3 = j - 1;
jlen = min(i__2,i__3);
cnorm[j] = sasum_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], &
c__1);
/* L10: */
}
} else {
/* A is lower triangular. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kd, i__3 = *n - j;
jlen = min(i__2,i__3);
if (jlen > 0) {
cnorm[j] = sasum_(&jlen, &ab[j * ab_dim1 + 2], &c__1);
} else {
cnorm[j] = 0.f;
}
/* L20: */
}
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM. */
imax = isamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum) {
tscal = 1.f;
} else {
tscal = 1.f / (smlnum * tmax);
sscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine STBSV can be used. */
j = isamax_(n, &x[1], &c__1);
xmax = (r__1 = x[j], dabs(r__1));
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
maind = *kd + 1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
maind = 1;
}
if (tscal != 1.f) {
grow = 0.f;
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.f / dmax(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 = (r__1 = ab[maind + j * ab_dim1], dabs(r__1));
/* Computing MIN */
r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
xbnd = dmin(r__1,r__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.f;
}
/* L30: */
}
grow = xbnd;
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
r__1 = 1.f, r__2 = 1.f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__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.f / (cnorm[j] + 1.f);
/* L40: */
}
}
L50:
;
} else {
/* Compute the growth in A' * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
maind = *kd + 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
maind = 1;
}
if (tscal != 1.f) {
grow = 0.f;
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.f / dmax(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.f;
/* Computing MIN */
r__1 = grow, r__2 = xbnd / xj;
grow = dmin(r__1,r__2);
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
tjj = (r__1 = ab[maind + j * ab_dim1], dabs(r__1));
if (xj > tjj) {
xbnd *= tjj / xj;
}
/* L60: */
}
grow = dmin(grow,xbnd);
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
r__1 = 1.f, r__2 = 1.f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__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.f;
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. */
stbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &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;
sscal_(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 = (r__1 = x[j], dabs(r__1));
if (nounit) {
tjjs = ab[maind + j * ab_dim1] * tscal;
} else {
tjjs = tscal;
if (tscal == 1.f) {
goto L95;
}
}
tjj = dabs(tjjs);
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1.f / xj;
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j] /= tjjs;
xj = (r__1 = x[j], dabs(r__1));
} else if (tjj > 0.f) {
/* 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.f) {
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
x[j] /= tjjs;
xj = (r__1 = x[j], dabs(r__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.f;
/* L90: */
}
x[j] = 1.f;
xj = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L95:
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.f) {
rec = 1.f / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5f;
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
sscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5f;
}
if (upper) {
if (j > 1) {
/* Compute the update */
/* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - */
/* x(j)* A(max(1,j-kd):j-1,j) */
/* Computing MIN */
i__3 = *kd, i__4 = j - 1;
jlen = min(i__3,i__4);
r__1 = -x[j] * tscal;
saxpy_(&jlen, &r__1, &ab[*kd + 1 - jlen + j * ab_dim1]
, &c__1, &x[j - jlen], &c__1);
i__3 = j - 1;
i__ = isamax_(&i__3, &x[1], &c__1);
xmax = (r__1 = x[i__], dabs(r__1));
}
} else if (j < *n) {
/* Compute the update */
/* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) - */
/* x(j) * A(j+1:min(j+kd,n),j) */
/* Computing MIN */
i__3 = *kd, i__4 = *n - j;
jlen = min(i__3,i__4);
if (jlen > 0) {
r__1 = -x[j] * tscal;
saxpy_(&jlen, &r__1, &ab[j * ab_dim1 + 2], &c__1, &x[
j + 1], &c__1);
}
i__3 = *n - j;
i__ = j + isamax_(&i__3, &x[j + 1], &c__1);
xmax = (r__1 = x[i__], dabs(r__1));
}
/* L100: */
}
} 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 = (r__1 = x[j], dabs(r__1));
uscal = tscal;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
tjjs = ab[maind + j * ab_dim1] * tscal;
} else {
tjjs = tscal;
}
tjj = dabs(tjjs);
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
uscal /= tjjs;
}
if (rec < 1.f) {
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
sumj = 0.f;
if (uscal == 1.f) {
/* If the scaling needed for A in the dot product is 1, */
/* call SDOT to perform the dot product. */
if (upper) {
/* Computing MIN */
i__3 = *kd, i__4 = j - 1;
jlen = min(i__3,i__4);
sumj = sdot_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1],
&c__1, &x[j - jlen], &c__1);
} else {
/* Computing MIN */
i__3 = *kd, i__4 = *n - j;
jlen = min(i__3,i__4);
if (jlen > 0) {
sumj = sdot_(&jlen, &ab[j * ab_dim1 + 2], &c__1, &
x[j + 1], &c__1);
}
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
/* Computing MIN */
i__3 = *kd, i__4 = j - 1;
jlen = min(i__3,i__4);
i__3 = jlen;
for (i__ = 1; i__ <= i__3; ++i__) {
sumj += ab[*kd + i__ - jlen + j * ab_dim1] *
uscal * x[j - jlen - 1 + i__];
/* L110: */
}
} else {
/* Computing MIN */
i__3 = *kd, i__4 = *n - j;
jlen = min(i__3,i__4);
i__3 = jlen;
for (i__ = 1; i__ <= i__3; ++i__) {
sumj += ab[i__ + 1 + j * ab_dim1] * uscal * x[j +
i__];
/* L120: */
}
}
}
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 = (r__1 = x[j], dabs(r__1));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjjs = ab[maind + j * ab_dim1] * tscal;
} else {
tjjs = tscal;
if (tscal == 1.f) {
goto L135;
}
}
tjj = dabs(tjjs);
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j] /= tjjs;
} else if (tjj > 0.f) {
/* 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;
sscal_(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.f;
/* L130: */
}
x[j] = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L135:
;
} 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 */
r__2 = xmax, r__3 = (r__1 = x[j], dabs(r__1));
xmax = dmax(r__2,r__3);
/* L140: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.f) {
r__1 = 1.f / tscal;
sscal_(n, &r__1, &cnorm[1], &c__1);
}
return 0;
/* End of SLATBS */
} /* slatbs_ */
/* Subroutine */ int check1_(real *sfac)
{
/* Initialized data */
static real sa[10] = { .3f,-1.f,0.f,1.f,.3f,.3f,.3f,.3f,.3f,.3f };
static real dv[80] /* was [8][5][2] */ = { .1f,2.f,2.f,2.f,2.f,2.f,2.f,
2.f,.3f,3.f,3.f,3.f,3.f,3.f,3.f,3.f,.3f,-.4f,4.f,4.f,4.f,4.f,4.f,
4.f,.2f,-.6f,.3f,5.f,5.f,5.f,5.f,5.f,.1f,-.3f,.5f,-.1f,6.f,6.f,
6.f,6.f,.1f,8.f,8.f,8.f,8.f,8.f,8.f,8.f,.3f,9.f,9.f,9.f,9.f,9.f,
9.f,9.f,.3f,2.f,-.4f,2.f,2.f,2.f,2.f,2.f,.2f,3.f,-.6f,5.f,.3f,2.f,
2.f,2.f,.1f,4.f,-.3f,6.f,-.5f,7.f,-.1f,3.f };
static real dtrue1[5] = { 0.f,.3f,.5f,.7f,.6f };
static real dtrue3[5] = { 0.f,.3f,.7f,1.1f,1.f };
static real dtrue5[80] /* was [8][5][2] */ = { .1f,2.f,2.f,2.f,2.f,
2.f,2.f,2.f,-.3f,3.f,3.f,3.f,3.f,3.f,3.f,3.f,0.f,0.f,4.f,4.f,4.f,
4.f,4.f,4.f,.2f,-.6f,.3f,5.f,5.f,5.f,5.f,5.f,.03f,-.09f,.15f,
-.03f,6.f,6.f,6.f,6.f,.1f,8.f,8.f,8.f,8.f,8.f,8.f,8.f,.09f,9.f,
9.f,9.f,9.f,9.f,9.f,9.f,.09f,2.f,-.12f,2.f,2.f,2.f,2.f,2.f,.06f,
3.f,-.18f,5.f,.09f,2.f,2.f,2.f,.03f,4.f,-.09f,6.f,-.15f,7.f,-.03f,
3.f };
static integer itrue2[5] = { 0,1,2,2,3 };
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
integer i__;
real sx[8];
integer np1, len;
extern doublereal snrm2_(integer *, real *, integer *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real stemp[1];
extern doublereal sasum_(integer *, real *, integer *);
real strue[8];
extern /* Subroutine */ int stest_(integer *, real *, real *, real *,
real *), itest1_(integer *, integer *), stest1_(real *, real *,
real *, real *);
extern integer isamax_(integer *, real *, integer *);
/* Fortran I/O blocks */
static cilist io___32 = { 0, 6, 0, 0, 0 };
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Scalars in Common .. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. Common blocks .. */
/* .. Data statements .. */
/* .. Executable Statements .. */
for (combla_1.incx = 1; combla_1.incx <= 2; ++combla_1.incx) {
for (np1 = 1; np1 <= 5; ++np1) {
combla_1.n = np1 - 1;
len = max(combla_1.n,1) << 1;
/* .. Set vector arguments .. */
i__1 = len;
for (i__ = 1; i__ <= i__1; ++i__) {
sx[i__ - 1] = dv[i__ + (np1 + combla_1.incx * 5 << 3) - 49];
/* L20: */
}
if (combla_1.icase == 7) {
/* .. SNRM2 .. */
stemp[0] = dtrue1[np1 - 1];
r__1 = snrm2_(&combla_1.n, sx, &combla_1.incx);
stest1_(&r__1, stemp, stemp, sfac);
} else if (combla_1.icase == 8) {
/* .. SASUM .. */
stemp[0] = dtrue3[np1 - 1];
r__1 = sasum_(&combla_1.n, sx, &combla_1.incx);
stest1_(&r__1, stemp, stemp, sfac);
} else if (combla_1.icase == 9) {
/* .. SSCAL .. */
sscal_(&combla_1.n, &sa[(combla_1.incx - 1) * 5 + np1 - 1],
sx, &combla_1.incx);
i__1 = len;
for (i__ = 1; i__ <= i__1; ++i__) {
strue[i__ - 1] = dtrue5[i__ + (np1 + combla_1.incx * 5 <<
3) - 49];
/* L40: */
}
stest_(&len, sx, strue, strue, sfac);
} else if (combla_1.icase == 10) {
/* .. ISAMAX .. */
i__1 = isamax_(&combla_1.n, sx, &combla_1.incx);
itest1_(&i__1, &itrue2[np1 - 1]);
} else {
s_wsle(&io___32);
do_lio(&c__9, &c__1, " Shouldn't be here in CHECK1", (ftnlen)
28);
e_wsle();
s_stop("", (ftnlen)0);
}
/* L60: */
}
/* L80: */
}
return 0;
} /* check1_ */
/* Subroutine */
int slatrs_(char *uplo, char *trans, char *diag, char * normin, integer *n, real *a, integer *lda, real *x, real *scale, real *cnorm, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1, r__2, r__3;
/* Local variables */
integer i__, j;
real xj, rec, tjj;
integer jinc;
real xbnd;
integer imax;
real tmax, tjjs;
extern real sdot_(integer *, real *, integer *, real *, integer *);
real xmax, grow, sumj;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int sscal_(integer *, real *, real *, integer *);
real tscal, uscal;
integer jlast;
extern real sasum_(integer *, real *, integer *);
logical upper;
extern /* Subroutine */
int saxpy_(integer *, real *, real *, integer *, real *, integer *), strsv_(char *, char *, char *, integer *, real *, integer *, real *, integer *);
extern real slamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
real bignum;
extern integer isamax_(integer *, real *, integer *);
logical notran;
integer jfirst;
real smlnum;
logical nounit;
/* -- 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 */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
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_("SLATRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = slamch_("Safe minimum") / slamch_("Precision");
bignum = 1.f / smlnum;
*scale = 1.f;
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] = sasum_(&i__2, &a[j * a_dim1 + 1], &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] = sasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
/* L20: */
}
cnorm[*n] = 0.f;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM. */
imax = isamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum)
{
tscal = 1.f;
}
else
{
tscal = 1.f / (smlnum * tmax);
sscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine STRSV can be used. */
j = isamax_(n, &x[1], &c__1);
xmax = (r__1 = x[j], f2c_abs(r__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.f)
{
grow = 0.f;
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.f / 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) / f2c_abs(A(j,j)) */
tjj = (r__1 = a[j + j * a_dim1], f2c_abs(r__1));
/* Computing MIN */
r__1 = xbnd;
r__2 = min(1.f,tjj) * grow; // , expr subst
xbnd = min(r__1,r__2);
if (tjj + cnorm[j] >= smlnum)
{
/* G(j) = G(j-1)*( 1 + CNORM(j) / f2c_abs(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
}
else
{
/* G(j) could overflow, set GROW to 0. */
grow = 0.f;
}
/* L30: */
}
grow = xbnd;
}
else
{
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{
x(i), i=1,...,n}
. */
/* Computing MIN */
r__1 = 1.f;
r__2 = 1.f / max(xbnd,smlnum); // , expr subst
grow = min(r__1,r__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.f / (cnorm[j] + 1.f);
/* L40: */
}
}
L50:
;
}
else
{
/* Compute the growth in A**T * x = b. */
if (upper)
{
jfirst = 1;
jlast = *n;
jinc = 1;
}
else
{
jfirst = *n;
jlast = 1;
jinc = -1;
}
if (tscal != 1.f)
{
grow = 0.f;
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.f / 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.f;
/* Computing MIN */
r__1 = grow;
r__2 = xbnd / xj; // , expr subst
grow = min(r__1,r__2);
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / f2c_abs(A(j,j)) */
tjj = (r__1 = a[j + j * a_dim1], f2c_abs(r__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 */
r__1 = 1.f;
r__2 = 1.f / max(xbnd,smlnum); // , expr subst
grow = min(r__1,r__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.f;
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. */
strsv_(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;
sscal_(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 = (r__1 = x[j], f2c_abs(r__1));
if (nounit)
{
tjjs = a[j + j * a_dim1] * tscal;
}
else
{
tjjs = tscal;
if (tscal == 1.f)
{
goto L95;
}
}
tjj = f2c_abs(tjjs);
if (tjj > smlnum)
{
/* f2c_abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f)
{
if (xj > tjj * bignum)
{
/* Scale x by 1/b(j). */
rec = 1.f / xj;
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j] /= tjjs;
xj = (r__1 = x[j], f2c_abs(r__1));
}
else if (tjj > 0.f)
{
/* 0 < f2c_abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum)
{
/* Scale x by (1/f2c_abs(x(j)))*f2c_abs(A(j,j))*BIGNUM */
/* to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.f)
{
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
x[j] /= tjjs;
xj = (r__1 = x[j], f2c_abs(r__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.f;
/* L90: */
}
x[j] = 1.f;
xj = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L95: /* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.f)
{
rec = 1.f / xj;
if (cnorm[j] > (bignum - xmax) * rec)
{
/* Scale x by 1/(2*f2c_abs(x(j))). */
rec *= .5f;
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
}
else if (xj * cnorm[j] > bignum - xmax)
{
/* Scale x by 1/2. */
sscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5f;
}
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;
r__1 = -x[j] * tscal;
saxpy_(&i__3, &r__1, &a[j * a_dim1 + 1], &c__1, &x[1], &c__1);
i__3 = j - 1;
i__ = isamax_(&i__3, &x[1], &c__1);
xmax = (r__1 = x[i__], f2c_abs(r__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;
r__1 = -x[j] * tscal;
saxpy_(&i__3, &r__1, &a[j + 1 + j * a_dim1], &c__1, & x[j + 1], &c__1);
i__3 = *n - j;
i__ = j + isamax_(&i__3, &x[j + 1], &c__1);
xmax = (r__1 = x[i__], f2c_abs(r__1));
}
}
/* L100: */
}
}
else
{
/* Solve A**T * 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 = (r__1 = x[j], f2c_abs(r__1));
uscal = tscal;
rec = 1.f / max(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec)
{
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit)
{
tjjs = a[j + j * a_dim1] * tscal;
}
else
{
tjjs = tscal;
}
tjj = f2c_abs(tjjs);
if (tjj > 1.f)
{
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f;
r__2 = rec * tjj; // , expr subst
rec = min(r__1,r__2);
uscal /= tjjs;
}
if (rec < 1.f)
{
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
sumj = 0.f;
if (uscal == 1.f)
{
/* If the scaling needed for A in the dot product is 1, */
/* call SDOT to perform the dot product. */
if (upper)
{
i__3 = j - 1;
sumj = sdot_(&i__3, &a[j * a_dim1 + 1], &c__1, &x[1], &c__1);
}
else if (j < *n)
{
i__3 = *n - j;
sumj = sdot_(&i__3, &a[j + 1 + j * a_dim1], &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[i__ + j * a_dim1] * uscal * x[i__];
/* L110: */
}
}
else if (j < *n)
{
i__3 = *n;
for (i__ = j + 1;
i__ <= i__3;
++i__)
{
sumj += a[i__ + j * a_dim1] * uscal * x[i__];
/* L120: */
}
}
}
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 = (r__1 = x[j], f2c_abs(r__1));
if (nounit)
{
tjjs = a[j + j * a_dim1] * tscal;
}
else
{
tjjs = tscal;
if (tscal == 1.f)
{
goto L135;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = f2c_abs(tjjs);
if (tjj > smlnum)
{
/* f2c_abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f)
{
if (xj > tjj * bignum)
{
/* Scale X by 1/f2c_abs(x(j)). */
rec = 1.f / xj;
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j] /= tjjs;
}
else if (tjj > 0.f)
{
/* 0 < f2c_abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum)
{
/* Scale x by (1/f2c_abs(x(j)))*f2c_abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
sscal_(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**T*x = 0. */
i__3 = *n;
for (i__ = 1;
i__ <= i__3;
++i__)
{
x[i__] = 0.f;
/* L130: */
}
x[j] = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L135:
;
}
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 */
r__2 = xmax;
r__3 = (r__1 = x[j], f2c_abs(r__1)); // , expr subst
xmax = max(r__2,r__3);
/* L140: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.f)
{
r__1 = 1.f / tscal;
sscal_(n, &r__1, &cnorm[1], &c__1);
}
return 0;
/* End of SLATRS */
}
void test03 ( void )
/******************************************************************************/
/*
Purpose:
TEST03 tests SASUM.
Modified:
29 March 2007
Author:
John Burkardt
*/
{
float *a;
int i;
int inc;
int j;
int lda = 6;
int ma = 5;
int na = 4;
int nx = 10;
int ncopy;
float *x;
a = malloc ( lda * na * sizeof ( float ) );
x = malloc ( nx * sizeof ( float ) );
for ( i = 0; i < nx; i++ )
{
x[i] = pow ( -1.0, i + 1 ) * ( float ) ( 2 * ( i + 1 ) );
}
printf ( "\n" );
printf ( "TEST03\n" );
printf ( " SASUM adds the absolute values of elements of a vector.\n" );
printf ( "\n" );
printf ( " X = \n" );
printf ( "\n" );
for ( i = 0; i < nx; i++ )
{
printf ( " %6d %14f\n", i + 1, x[i] );
}
printf ( "\n" );
ncopy = nx;
inc = 1;
printf ( " SASUM ( NX, X, 1 ) = %f\n", sasum_ ( &ncopy, x, &inc ) );
ncopy = nx / 2;
inc = 2;
printf ( " SASUM ( NX/2, X, 2 ) = %f\n", sasum_ ( &ncopy, x, &inc ) );
ncopy = 2;
inc = nx / 2;
printf ( " SASUM ( 2, X, NX/2 ) = %f\n", sasum_ ( &ncopy, x, &inc ) );
for ( i = 0; i < ma; i++ )
{
for ( j = 0; j < na; j++ )
{
a[i+j*lda] = pow ( -1.0, i + 1 + j + 1)
* ( float ) ( 10 * ( i + 1 ) + j + 1 );
}
}
printf ( "\n" );
printf ( " Demonstrate with a matrix A:\n" );
printf ( "\n" );
for ( i = 0; i < ma; i++ )
{
for ( j = 0; j < na; j++ )
{
printf ( " %14f", a[i+j*lda] );
}
printf ( "\n" );
}
printf ( "\n" );
ncopy = ma;
inc = 1;
printf ( " SASUM(MA,A(1,2),1) = %f\n", sasum_ ( &ncopy, a+0+1*lda, &inc ) );
ncopy = na;
inc = lda;
printf ( " SASUM(NA,A(2,1),LDA) = %f\n", sasum_ ( &ncopy, a+1+0*lda, &inc ) );
free ( a );
free ( x );
return;
}
/* Subroutine */ int schkgt_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, real *thresh, logical *tsterr, real *a,
real *af, real *b, real *x, real *xact, real *work, real *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;
real r__1, r__2;
/* Local variables */
integer i__, j, k, m, n;
real z__[3];
integer in, kl, ku, ix, lda;
real 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];
real rcond;
integer nimat;
real anorm;
integer itran;
char trans[1];
integer izero, nerrs;
logical zerot;
real rcondc, rcondi, rcondo;
real ainvnm;
logical trfcon;
real 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 */
/* ======= */
/* SCHKGT tests SGTTRF, -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) REAL */
/* 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) REAL array, dimension (NMAX*4) */
/* AF (workspace) REAL array, dimension (NMAX*4) */
/* B (workspace) REAL array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) REAL array, dimension (NMAX*NSMAX) */
/* XACT (workspace) REAL array, dimension (NMAX*NSMAX) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) REAL 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, "Single 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) {
serrge_(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 SLATB4. */
slatb4_(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, "SLATMS", (ftnlen)32, (ftnlen)6);
slatms_(&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 SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
izero = 0;
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &af[4], &c__3, &a[1], &c__1);
i__3 = n - 1;
scopy_(&i__3, &af[3], &c__3, &a[n + m + 1], &c__1);
}
scopy_(&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);
slarnv_(&c__2, iseed, &i__3, &a[1]);
if (anorm != 1.f) {
i__3 = n + (m << 1);
sscal_(&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.f;
if (n > 1) {
z__[2] = a[1];
a[1] = 0.f;
}
} else if (imat == 9) {
izero = n;
z__[0] = a[n * 3 - 2];
z__[1] = a[(n << 1) - 1];
a[n * 3 - 2] = 0.f;
a[(n << 1) - 1] = 0.f;
} else {
izero = (n + 1) / 2;
i__3 = n - 1;
for (i__ = izero; i__ <= i__3; ++i__) {
a[(n << 1) - 2 + i__] = 0.f;
a[n - 1 + i__] = 0.f;
a[i__] = 0.f;
/* L20: */
}
a[n * 3 - 2] = 0.f;
a[(n << 1) - 1] = 0.f;
}
}
/* + TEST 1 */
/* Factor A as L*U and compute the ratio */
/* norm(L*U - A) / (n * norm(A) * EPS ) */
i__3 = n + (m << 1);
scopy_(&i__3, &a[1], &c__1, &af[1], &c__1);
s_copy(srnamc_1.srnamt, "SGTTRF", (ftnlen)32, (ftnlen)6);
sgttrf_(&n, &af[1], &af[m + 1], &af[n + m + 1], &af[n + (m << 1)
+ 1], &iwork[1], &info);
/* Check error code from SGTTRF. */
if (info != izero) {
alaerh_(path, "SGTTRF", &info, &izero, " ", &n, &n, &c__1, &
c__1, &c_n1, &imat, &nfail, &nerrs, nout);
}
trfcon = info != 0;
sgtt01_(&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(real));
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 = slangt_(norm, &n, &a[1], &a[m + 1], &a[n + m + 1]);
if (! trfcon) {
/* Use SGTTRS 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.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
x[j] = 0.f;
/* L30: */
}
x[i__] = 1.f;
sgttrs_(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 */
r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L40: */
}
/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
if (itran == 1) {
rcondo = rcondc;
} else {
rcondi = rcondc;
}
} else {
rcondc = 0.f;
}
/* + TEST 7 */
/* Estimate the reciprocal of the condition number of the */
/* matrix. */
s_copy(srnamc_1.srnamt, "SGTCON", (ftnlen)32, (ftnlen)6);
sgtcon_(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 SGTCON. */
if (info != 0) {
alaerh_(path, "SGTCON", &info, &c__0, norm, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[6] = sget06_(&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(real));
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) {
slarnv_(&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. */
slagtm_(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. */
slacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "SGTTRS", (ftnlen)32, (ftnlen)6);
sgttrs_(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 SGTTRS. */
if (info != 0) {
alaerh_(path, "SGTTRS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
slacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
sgtt02_(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. */
sget04_(&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, "SGTRFS", (ftnlen)32, (ftnlen)6);
sgtrfs_(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 SGTRFS. */
if (info != 0) {
alaerh_(path, "SGTRFS", &info, &c__0, trans, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
sget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
sgtt05_(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(real));
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 SCHKGT */
} /* schkgt_ */
/* Subroutine */ int sqrt15_(integer *scale, integer *rksel, integer *m,
integer *n, integer *nrhs, real *a, integer *lda, real *b, integer *
ldb, real *s, integer *rank, real *norma, real *normb, integer *iseed,
real *work, integer *lwork)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
real r__1;
/* Local variables */
static integer info;
static real temp;
extern doublereal snrm2_(integer *, real *, integer *);
static integer j;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
slarf_(char *, integer *, integer *, real *, integer *, real *,
real *, integer *, real *), sgemm_(char *, char *,
integer *, integer *, integer *, real *, real *, integer *, real *
, integer *, real *, real *, integer *);
extern doublereal sasum_(integer *, real *, integer *);
static real dummy[1];
static integer mn;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
extern doublereal slarnd_(integer *, integer *);
extern /* Subroutine */ int slaord_(char *, integer *, real *, integer *), slaset_(char *, integer *, integer *, real *, real *,
real *, integer *), slaror_(char *, char *, integer *,
integer *, real *, integer *, integer *, real *, integer *), slarnv_(integer *, integer *, integer *, real *);
static real 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
=======
SQRT15 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) REAL array, dimension (LDA,N)
The M-by-N matrix A.
LDA (input) INTEGER
The leading dimension of the array A.
B (output) REAL 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) REAL array, dimension MIN(M,N)
Singular values of A.
RANK (output) INTEGER
number of nonzero singular values of A.
NORMA (output) REAL
one-norm of A.
NORMB (output) REAL
one-norm of B.
ISEED (input/output) integer array, dimension (4)
seed for random number generator.
WORK (workspace) REAL 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_("SQRT15", &c__16);
return 0;
}
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
eps = slamch_("Epsilon");
smlnum = smlnum / eps / eps;
bignum = 1.f / 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.f;
/* L10: */
}
} else {
xerbla_("SQRT15", &c__2);
}
if (*rank > 0) {
/* Nontrivial case */
s[1] = 1.f;
i__1 = *rank;
for (j = 2; j <= i__1; ++j) {
L20:
temp = slarnd_(&c__1, &iseed[1]);
if (temp > .1f) {
s[j] = dabs(temp);
} else {
goto L20;
}
/* L30: */
}
slaord_("Decreasing", rank, &s[1], &c__1);
/* Generate 'rank' columns of a random orthogonal matrix in A */
slarnv_(&c__2, &iseed[1], m, &work[1]);
r__1 = 1.f / snrm2_(m, &work[1], &c__1);
sscal_(m, &r__1, &work[1], &c__1);
slaset_("Full", m, rank, &c_b18, &c_b19, &a[a_offset], lda)
;
slarf_("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;
slarnv_(&c__2, &iseed[1], &i__1, &work[1]);
sgemm_("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) {
sscal_(m, &s[j], &a_ref(1, j), &c__1);
/* L40: */
}
if (*rank < *n) {
i__1 = *n - *rank;
slaset_("Full", m, &i__1, &c_b18, &c_b18, &a_ref(1, *rank + 1),
lda);
}
slaror_("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.f;
/* L50: */
}
slaset_("Full", m, n, &c_b18, &c_b18, &a[a_offset], lda);
slaset_("Full", m, nrhs, &c_b18, &c_b18, &b[b_offset], ldb)
;
}
/* Scale the matrix */
if (*scale != 1) {
*norma = slange_("Max", m, n, &a[a_offset], lda, dummy);
if (*norma != 0.f) {
if (*scale == 2) {
/* matrix scaled up */
slascl_("General", &c__0, &c__0, norma, &bignum, m, n, &a[
a_offset], lda, &info);
slascl_("General", &c__0, &c__0, norma, &bignum, &mn, &c__1, &
s[1], &mn, &info);
slascl_("General", &c__0, &c__0, norma, &bignum, m, nrhs, &b[
b_offset], ldb, &info);
} else if (*scale == 3) {
/* matrix scaled down */
slascl_("General", &c__0, &c__0, norma, &smlnum, m, n, &a[
a_offset], lda, &info);
slascl_("General", &c__0, &c__0, norma, &smlnum, &mn, &c__1, &
s[1], &mn, &info);
slascl_("General", &c__0, &c__0, norma, &smlnum, m, nrhs, &b[
b_offset], ldb, &info);
} else {
xerbla_("SQRT15", &c__1);
return 0;
}
}
}
*norma = sasum_(&mn, &s[1], &c__1);
*normb = slange_("One-norm", m, nrhs, &b[b_offset], ldb, dummy)
;
return 0;
/* End of SQRT15 */
} /* sqrt15_ */
/* Subroutine */ int sgbt02_(char *trans, integer *m, integer *n, integer *kl,
integer *ku, integer *nrhs, real *a, integer *lda, real *x, integer *
ldx, real *b, integer *ldb, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
i__3;
real r__1, r__2;
/* Local variables */
integer j, i1, i2, n1, kd;
real eps;
real anorm, bnorm;
real xnorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGBT02 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) REAL 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) REAL 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) REAL 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) REAL */
/* 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 return if N = 0 pr 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;
/* Function Body */
if (*m <= 0 || *n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
kd = *ku + 1;
anorm = 0.f;
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;
r__1 = anorm, r__2 = sasum_(&i__2, &a[i1 + j * a_dim1], &c__1);
anorm = dmax(r__1,r__2);
/* L10: */
}
if (anorm <= 0.f) {
*resid = 1.f / 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) {
sgbmv_(trans, m, n, kl, ku, &c_b8, &a[a_offset], lda, &x[j * x_dim1 +
1], &c__1, &c_b10, &b[j * b_dim1 + 1], &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.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bnorm = sasum_(&n1, &b[j * b_dim1 + 1], &c__1);
xnorm = sasum_(&n1, &x[j * x_dim1 + 1], &c__1);
if (xnorm <= 0.f) {
*resid = 1.f / eps;
} else {
/* Computing MAX */
r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
*resid = dmax(r__1,r__2);
}
/* L30: */
}
return 0;
/* End of SGBT02 */
} /* sgbt02_ */
/* Subroutine */ int sgbt01_(integer *m, integer *n, integer *kl, integer *ku,
real *a, integer *lda, real *afac, integer *ldafac, integer *ipiv,
real *work, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4;
real r__1, r__2;
/* Local variables */
static integer lenj, i__, j;
static real t, anorm;
extern doublereal sasum_(integer *, real *, integer *);
static integer i1, i2;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), saxpy_(integer *, real *, real *, integer *, real *,
integer *);
static integer kd, il, jl, ip, ju, iw;
extern doublereal slamch_(char *);
static integer jua;
static real eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define afac_ref(a_1,a_2) afac[(a_2)*afac_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
=======
SGBT01 reconstructs a band matrix A from its L*U factorization and
computes the residual:
norm(L*U - A) / ( N * norm(A) * EPS ),
where EPS is the machine epsilon.
The expression L*U - A is computed one column at a time, so A and
AFAC are not modified.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
N (input) INTEGER
The number of columns of the matrix A. N >= 0.
KL (input) INTEGER
The number of subdiagonals within the band of A. KL >= 0.
KU (input) INTEGER
The number of superdiagonals within the band of A. KU >= 0.
A (input/output) REAL 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).
AFAC (input) REAL array, dimension (LDAFAC,N)
The factored form of the matrix A. AFAC contains the banded
factors L and U from the L*U factorization, as computed by
SGBTRF. U is stored as an upper triangular band matrix with
KL+KU superdiagonals in rows 1 to KL+KU+1, and the
multipliers used during the factorization are stored in rows
KL+KU+2 to 2*KL+KU+1. See SGBTRF for further details.
LDAFAC (input) INTEGER
The leading dimension of the array AFAC.
LDAFAC >= max(1,2*KL*KU+1).
IPIV (input) INTEGER array, dimension (min(M,N))
The pivot indices from SGBTRF.
WORK (workspace) REAL array, dimension (2*KL+KU+1)
RESID (output) REAL
norm(L*U - A) / ( N * norm(A) * EPS )
=====================================================================
Quick exit if M = 0 or N = 0.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1 * 1;
afac -= afac_offset;
--ipiv;
--work;
/* Function Body */
*resid = 0.f;
if (*m <= 0 || *n <= 0) {
return 0;
}
/* Determine EPS and the norm of A. */
eps = slamch_("Epsilon");
kd = *ku + 1;
anorm = 0.f;
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);
if (i2 >= i1) {
/* Computing MAX */
i__2 = i2 - i1 + 1;
r__1 = anorm, r__2 = sasum_(&i__2, &a_ref(i1, j), &c__1);
anorm = dmax(r__1,r__2);
}
/* L10: */
}
/* Compute one column at a time of L*U - A. */
kd = *kl + *ku + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Copy the J-th column of U to WORK.
Computing MIN */
i__2 = *kl + *ku, i__3 = j - 1;
ju = min(i__2,i__3);
/* Computing MIN */
i__2 = *kl, i__3 = *m - j;
jl = min(i__2,i__3);
lenj = min(*m,j) - j + ju + 1;
if (lenj > 0) {
scopy_(&lenj, &afac_ref(kd - ju, j), &c__1, &work[1], &c__1);
i__2 = ju + jl + 1;
for (i__ = lenj + 1; i__ <= i__2; ++i__) {
work[i__] = 0.f;
/* L20: */
}
/* Multiply by the unit lower triangular matrix L. Note that L
is stored as a product of transformations and permutations.
Computing MIN */
i__2 = *m - 1;
i__3 = j - ju;
for (i__ = min(i__2,j); i__ >= i__3; --i__) {
/* Computing MIN */
i__2 = *kl, i__4 = *m - i__;
il = min(i__2,i__4);
if (il > 0) {
iw = i__ - j + ju + 1;
t = work[iw];
saxpy_(&il, &t, &afac_ref(kd + 1, i__), &c__1, &work[iw +
1], &c__1);
ip = ipiv[i__];
if (i__ != ip) {
ip = ip - j + ju + 1;
work[iw] = work[ip];
work[ip] = t;
}
}
/* L30: */
}
/* Subtract the corresponding column of A. */
jua = min(ju,*ku);
if (jua + jl + 1 > 0) {
i__3 = jua + jl + 1;
saxpy_(&i__3, &c_b12, &a_ref(*ku + 1 - jua, j), &c__1, &work[
ju + 1 - jua], &c__1);
}
/* Compute the 1-norm of the column.
Computing MAX */
i__3 = ju + jl + 1;
r__1 = *resid, r__2 = sasum_(&i__3, &work[1], &c__1);
*resid = dmax(r__1,r__2);
}
/* L40: */
}
/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
if (anorm <= 0.f) {
if (*resid != 0.f) {
*resid = 1.f / eps;
}
} else {
*resid = *resid / (real) (*n) / anorm / eps;
}
return 0;
/* End of SGBT01 */
} /* sgbt01_ */
/* Subroutine */ int slaqtr_(logical *ltran, logical *lreal, integer *n, real
*t, integer *ldt, real *b, real *w, real *scale, real *x, real *work,
integer *info)
{
/* System generated locals */
integer t_dim1, t_offset, i__1, i__2;
real r__1, r__2, r__3, r__4, r__5, r__6;
/* Local variables */
real d__[4] /* was [2][2] */;
integer i__, j, k;
real v[4] /* was [2][2] */, z__;
integer j1, j2, n1, n2;
real si, xj, sr, rec, eps, tjj, tmp;
integer ierr;
real smin;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
real xmax;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
integer jnext;
extern doublereal sasum_(integer *, real *, integer *);
real sminw, xnorm;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *), slaln2_(logical *, integer *, integer *, real
*, real *, real *, integer *, real *, real *, real *, integer *,
real *, real *, real *, integer *, real *, real *, integer *);
real scaloc;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
real bignum;
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int sladiv_(real *, real *, real *, real *, real *
, real *);
logical notran;
real smlnum;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAQTR 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 STRSNA. */
/* 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) REAL array, dimension (LDT,N) */
/* On entry, T contains a matrix in Schur canonical form. */
/* If LREAL = .FALSE., then the first diagonal block of T must */
/* be 1 by 1. */
/* LDT (input) INTEGER */
/* The leading dimension of the matrix T. LDT >= max(1,N). */
/* B (input) REAL 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) REAL */
/* On entry, W is the diagonal element of the matrix B. */
/* If LREAL = .TRUE., W is not referenced. */
/* SCALE (output) REAL */
/* On exit, SCALE is the scale factor. */
/* X (input/output) REAL 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) REAL 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 SLALN2 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 = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
xnorm = slange_("M", n, n, &t[t_offset], ldt, d__);
if (! (*lreal)) {
/* Computing MAX */
r__1 = xnorm, r__2 = dabs(*w), r__1 = max(r__1,r__2), r__2 = slange_(
"M", n, &c__1, &b[1], n, d__);
xnorm = dmax(r__1,r__2);
}
/* Computing MAX */
r__1 = smlnum, r__2 = eps * xnorm;
smin = dmax(r__1,r__2);
/* Compute 1-norm of each column of strictly upper triangular */
/* part of T to control overflow in triangular solver. */
work[1] = 0.f;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = j - 1;
work[j] = sasum_(&i__2, &t[j * t_dim1 + 1], &c__1);
/* L10: */
}
if (! (*lreal)) {
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
work[i__] += (r__1 = b[i__], dabs(r__1));
/* L20: */
}
}
n2 = *n << 1;
n1 = *n;
if (! (*lreal)) {
n1 = n2;
}
k = isamax_(&n1, &x[1], &c__1);
xmax = (r__1 = x[k], dabs(r__1));
*scale = 1.f;
if (xmax > bignum) {
*scale = bignum / xmax;
sscal_(&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.f) {
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 = (r__1 = x[j1], dabs(r__1));
tjj = (r__1 = t[j1 + j1 * t_dim1], dabs(r__1));
tmp = t[j1 + j1 * t_dim1];
if (tjj < smin) {
tmp = smin;
tjj = smin;
*info = 1;
}
if (xj == 0.f) {
goto L30;
}
if (tjj < 1.f) {
if (xj > bignum * tjj) {
rec = 1.f / xj;
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j1] /= tmp;
xj = (r__1 = x[j1], dabs(r__1));
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j1 of T. */
if (xj > 1.f) {
rec = 1.f / xj;
if (work[j1] > (bignum - xmax) * rec) {
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
}
if (j1 > 1) {
i__1 = j1 - 1;
r__1 = -x[j1];
saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
k = isamax_(&i__1, &x[1], &c__1);
xmax = (r__1 = x[k], dabs(r__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];
slaln2_(&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.f) {
sscal_(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 */
r__1 = dabs(v[0]), r__2 = dabs(v[1]);
xj = dmax(r__1,r__2);
if (xj > 1.f) {
rec = 1.f / xj;
/* Computing MAX */
r__1 = work[j1], r__2 = work[j2];
if (dmax(r__1,r__2) > (bignum - xmax) * rec) {
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
}
/* Update right-hand side */
if (j1 > 1) {
i__1 = j1 - 1;
r__1 = -x[j1];
saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
r__1 = -x[j2];
saxpy_(&i__1, &r__1, &t[j2 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
k = isamax_(&i__1, &x[1], &c__1);
xmax = (r__1 = x[k], dabs(r__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.f) {
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 = (r__1 = x[j1], dabs(r__1));
if (xmax > 1.f) {
rec = 1.f / xmax;
if (work[j1] > (bignum - xj) * rec) {
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
x[j1] -= sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &
c__1);
xj = (r__1 = x[j1], dabs(r__1));
tjj = (r__1 = t[j1 + j1 * t_dim1], dabs(r__1));
tmp = t[j1 + j1 * t_dim1];
if (tjj < smin) {
tmp = smin;
tjj = smin;
*info = 1;
}
if (tjj < 1.f) {
if (xj > bignum * tjj) {
rec = 1.f / xj;
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j1] /= tmp;
/* Computing MAX */
r__2 = xmax, r__3 = (r__1 = x[j1], dabs(r__1));
xmax = dmax(r__2,r__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 */
r__3 = (r__1 = x[j1], dabs(r__1)), r__4 = (r__2 = x[j2],
dabs(r__2));
xj = dmax(r__3,r__4);
if (xmax > 1.f) {
rec = 1.f / xmax;
/* Computing MAX */
r__1 = work[j2], r__2 = work[j1];
if (dmax(r__1,r__2) > (bignum - xj) * rec) {
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
d__[0] = x[j1] - sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1,
&x[1], &c__1);
i__2 = j1 - 1;
d__[1] = x[j2] - sdot_(&i__2, &t[j2 * t_dim1 + 1], &c__1,
&x[1], &c__1);
slaln2_(&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.f) {
sscal_(n, &scaloc, &x[1], &c__1);
*scale *= scaloc;
}
x[j1] = v[0];
x[j2] = v[1];
/* Computing MAX */
r__3 = (r__1 = x[j1], dabs(r__1)), r__4 = (r__2 = x[j2],
dabs(r__2)), r__3 = max(r__3,r__4);
xmax = dmax(r__3,xmax);
}
L40:
;
}
}
} else {
/* Computing MAX */
r__1 = eps * dabs(*w);
sminw = dmax(r__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.f) {
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 = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[*n + j1],
dabs(r__2));
tjj = (r__1 = t[j1 + j1 * t_dim1], dabs(r__1)) + dabs(z__)
;
tmp = t[j1 + j1 * t_dim1];
if (tjj < sminw) {
tmp = sminw;
tjj = sminw;
*info = 1;
}
if (xj == 0.f) {
goto L70;
}
if (tjj < 1.f) {
if (xj > bignum * tjj) {
rec = 1.f / xj;
sscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
sladiv_(&x[j1], &x[*n + j1], &tmp, &z__, &sr, &si);
x[j1] = sr;
x[*n + j1] = si;
xj = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[*n + j1],
dabs(r__2));
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j1 of T. */
if (xj > 1.f) {
rec = 1.f / xj;
if (work[j1] > (bignum - xmax) * rec) {
sscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
}
}
if (j1 > 1) {
i__1 = j1 - 1;
r__1 = -x[j1];
saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
r__1 = -x[*n + j1];
saxpy_(&i__1, &r__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.f;
i__1 = j1 - 1;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
r__3 = xmax, r__4 = (r__1 = x[k], dabs(r__1)) + (
r__2 = x[k + *n], dabs(r__2));
xmax = dmax(r__3,r__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];
r__1 = -(*w);
slaln2_(&c_false, &c__2, &c__2, &sminw, &c_b21, &t[j1 +
j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &
c_b25, &r__1, v, &c__2, &scaloc, &xnorm, &ierr);
if (ierr != 0) {
*info = 2;
}
if (scaloc != 1.f) {
i__1 = *n << 1;
sscal_(&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 */
r__1 = dabs(v[0]) + dabs(v[2]), r__2 = dabs(v[1]) + dabs(
v[3]);
xj = dmax(r__1,r__2);
if (xj > 1.f) {
rec = 1.f / xj;
/* Computing MAX */
r__1 = work[j1], r__2 = work[j2];
if (dmax(r__1,r__2) > (bignum - xmax) * rec) {
sscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
}
}
/* Update the right-hand side. */
if (j1 > 1) {
i__1 = j1 - 1;
r__1 = -x[j1];
saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
r__1 = -x[j2];
saxpy_(&i__1, &r__1, &t[j2 * t_dim1 + 1], &c__1, &x[1]
, &c__1);
i__1 = j1 - 1;
r__1 = -x[*n + j1];
saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[*
n + 1], &c__1);
i__1 = j1 - 1;
r__1 = -x[*n + j2];
saxpy_(&i__1, &r__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.f;
i__1 = j1 - 1;
for (k = 1; k <= i__1; ++k) {
/* Computing MAX */
r__3 = (r__1 = x[k], dabs(r__1)) + (r__2 = x[k + *
n], dabs(r__2));
xmax = dmax(r__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.f) {
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 = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[j1 + *n],
dabs(r__2));
if (xmax > 1.f) {
rec = 1.f / xmax;
if (work[j1] > (bignum - xj) * rec) {
sscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
x[j1] -= sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], &
c__1);
i__2 = j1 - 1;
x[*n + j1] -= sdot_(&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 = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[j1 + *n],
dabs(r__2));
z__ = *w;
if (j1 == 1) {
z__ = b[1];
}
/* Scale if necessary to avoid overflow in */
/* complex division */
tjj = (r__1 = t[j1 + j1 * t_dim1], dabs(r__1)) + dabs(z__)
;
tmp = t[j1 + j1 * t_dim1];
if (tjj < sminw) {
tmp = sminw;
tjj = sminw;
*info = 1;
}
if (tjj < 1.f) {
if (xj > bignum * tjj) {
rec = 1.f / xj;
sscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
r__1 = -z__;
sladiv_(&x[j1], &x[*n + j1], &tmp, &r__1, &sr, &si);
x[j1] = sr;
x[j1 + *n] = si;
/* Computing MAX */
r__3 = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[j1 + *n],
dabs(r__2));
xmax = dmax(r__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 */
r__5 = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[*n + j1],
dabs(r__2)), r__6 = (r__3 = x[j2], dabs(r__3)) + (
r__4 = x[*n + j2], dabs(r__4));
xj = dmax(r__5,r__6);
if (xmax > 1.f) {
rec = 1.f / xmax;
/* Computing MAX */
r__1 = work[j1], r__2 = work[j2];
if (dmax(r__1,r__2) > (bignum - xj) / xmax) {
sscal_(&n2, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__2 = j1 - 1;
d__[0] = x[j1] - sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1,
&x[1], &c__1);
i__2 = j1 - 1;
d__[1] = x[j2] - sdot_(&i__2, &t[j2 * t_dim1 + 1], &c__1,
&x[1], &c__1);
i__2 = j1 - 1;
d__[2] = x[*n + j1] - sdot_(&i__2, &t[j1 * t_dim1 + 1], &
c__1, &x[*n + 1], &c__1);
i__2 = j1 - 1;
d__[3] = x[*n + j2] - sdot_(&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];
slaln2_(&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.f) {
sscal_(&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 */
r__5 = (r__1 = x[j1], dabs(r__1)) + (r__2 = x[*n + j1],
dabs(r__2)), r__6 = (r__3 = x[j2], dabs(r__3)) + (
r__4 = x[*n + j2], dabs(r__4)), r__5 = max(r__5,
r__6);
xmax = dmax(r__5,xmax);
}
L80:
;
}
}
}
return 0;
/* End of SLAQTR */
} /* slaqtr_ */
int
slacon_(int *n, float *v, float *x, int *isgn, float *est, int *kase)
{
/* Table of constant values */
int c__1 = 1;
float zero = 0.0;
float one = 1.0;
/* Local variables */
static int iter;
static int jump, jlast;
static float altsgn, estold;
static int i, j;
float temp;
#ifdef _CRAY
extern int ISAMAX(int *, float *, int *);
extern float SASUM(int *, float *, int *);
extern int SCOPY(int *, float *, int *, float *, int *);
#else
extern int isamax_(int *, float *, int *);
extern float sasum_(int *, float *, int *);
extern int scopy_(int *, float *, int *, float *, int *);
#endif
#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. / (float) (*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;
}
#ifdef _CRAY
*est = SASUM(n, x, &c__1);
#else
*est = sasum_(n, x, &c__1);
#endif
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:
#ifdef _CRAY
j = ISAMAX(n, &x[0], &c__1);
#else
j = isamax_(n, &x[0], &c__1);
#endif
--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:
#ifdef _CRAY
SCOPY(n, x, &c__1, v, &c__1);
#else
scopy_(n, x, &c__1, v, &c__1);
#endif
estold = *est;
#ifdef _CRAY
*est = SASUM(n, v, &c__1);
#else
*est = sasum_(n, v, &c__1);
#endif
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;
#ifdef _CRAY
j = ISAMAX(n, &x[0], &c__1);
#else
j = isamax_(n, &x[0], &c__1);
#endif
--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 * ((float)(i - 1) / (float)(*n - 1) + 1.);
altsgn = -altsgn;
}
*kase = 1;
jump = 5;
return 0;
/* ................ ENTRY (JUMP = 5)
X HAS BEEN OVERWRITTEN BY A*X. */
L140:
#ifdef _CRAY
temp = SASUM(n, x, &c__1) / (float)(*n * 3) * 2.;
#else
temp = sasum_(n, x, &c__1) / (float)(*n * 3) * 2.;
#endif
if (temp > *est) {
#ifdef _CRAY
SCOPY(n, &x[0], &c__1, &v[0], &c__1);
#else
scopy_(n, &x[0], &c__1, &v[0], &c__1);
#endif
*est = temp;
}
L150:
*kase = 0;
return 0;
} /* slacon_ */
/* Subroutine */ int sdrvpt_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, real *a, real *d__,
real *e, real *b, real *x, real *xact, real *work, real *rwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, N =\002,i5,\002, type \002,i2,\002"
", test \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', N =\002,i5"
",\002, type \002,i2,\002, test \002,i2,\002, ratio = \002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2, r__3;
/* Local variables */
integer i__, j, k, n;
real z__[3];
integer k1, ia, in, kl, ku, ix, nt, lda;
char fact[1];
real cond;
integer mode;
real dmax__;
integer imat, info;
char path[3], dist[1], type__[1];
integer nrun, ifact, nfail, iseed[4];
real rcond;
integer nimat;
real anorm;
integer izero, nerrs;
logical zerot;
real rcondc;
real ainvnm;
real result[6];
/* Fortran I/O blocks */
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 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 */
/* ======= */
/* SDRVPT tests SPTSV and -SVX. */
/* 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. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) REAL */
/* 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) REAL array, dimension (NMAX*2) */
/* D (workspace) REAL array, dimension (NMAX*2) */
/* E (workspace) REAL array, dimension (NMAX*2) */
/* B (workspace) REAL array, dimension (NMAX*NRHS) */
/* X (workspace) REAL array, dimension (NMAX*NRHS) */
/* XACT (workspace) REAL array, dimension (NMAX*NRHS) */
/* WORK (workspace) REAL array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NRHS)) */
/* 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 */
--rwork;
--work;
--xact;
--x;
--b;
--e;
--d__;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "PT", (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) {
serrvx_(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];
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 (n > 0 && ! dotype[imat]) {
goto L110;
}
/* Set up parameters with SLATB4. */
slatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Type 1-6: generate a symmetric tridiagonal matrix of */
/* known condition number in lower triangular band storage. */
s_copy(srnamc_1.srnamt, "SLATMS", (ftnlen)32, (ftnlen)6);
slatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &cond,
&anorm, &kl, &ku, "B", &a[1], &c__2, &work[1], &info);
/* Check the error code from SLATMS. */
if (info != 0) {
alaerh_(path, "SLATMS", &info, &c__0, " ", &n, &n, &kl, &
ku, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
izero = 0;
/* Copy the matrix to D and E. */
ia = 1;
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d__[i__] = a[ia];
e[i__] = a[ia + 1];
ia += 2;
/* L20: */
}
if (n > 0) {
d__[n] = a[ia];
}
} else {
/* Type 7-12: generate a diagonally dominant matrix with */
/* unknown condition number in the vectors D and E. */
if (! zerot || ! dotype[7]) {
/* Let D and E have values from [-1,1]. */
slarnv_(&c__2, iseed, &n, &d__[1]);
i__3 = n - 1;
slarnv_(&c__2, iseed, &i__3, &e[1]);
/* Make the tridiagonal matrix diagonally dominant. */
if (n == 1) {
d__[1] = dabs(d__[1]);
} else {
d__[1] = dabs(d__[1]) + dabs(e[1]);
d__[n] = (r__1 = d__[n], dabs(r__1)) + (r__2 = e[n -
1], dabs(r__2));
i__3 = n - 1;
for (i__ = 2; i__ <= i__3; ++i__) {
d__[i__] = (r__1 = d__[i__], dabs(r__1)) + (r__2 =
e[i__], dabs(r__2)) + (r__3 = e[i__ - 1],
dabs(r__3));
/* L30: */
}
}
/* Scale D and E so the maximum element is ANORM. */
ix = isamax_(&n, &d__[1], &c__1);
dmax__ = d__[ix];
r__1 = anorm / dmax__;
sscal_(&n, &r__1, &d__[1], &c__1);
if (n > 1) {
i__3 = n - 1;
r__1 = anorm / dmax__;
sscal_(&i__3, &r__1, &e[1], &c__1);
}
} else if (izero > 0) {
/* Reuse the last matrix by copying back the zeroed out */
/* elements. */
if (izero == 1) {
d__[1] = z__[1];
if (n > 1) {
e[1] = z__[2];
}
} else if (izero == n) {
e[n - 1] = z__[0];
d__[n] = z__[1];
} else {
e[izero - 1] = z__[0];
d__[izero] = z__[1];
e[izero] = z__[2];
}
}
/* For types 8-10, set one row and column of the matrix to */
/* zero. */
izero = 0;
if (imat == 8) {
izero = 1;
z__[1] = d__[1];
d__[1] = 0.f;
if (n > 1) {
z__[2] = e[1];
e[1] = 0.f;
}
} else if (imat == 9) {
izero = n;
if (n > 1) {
z__[0] = e[n - 1];
e[n - 1] = 0.f;
}
z__[1] = d__[n];
d__[n] = 0.f;
} else if (imat == 10) {
izero = (n + 1) / 2;
if (izero > 1) {
z__[0] = e[izero - 1];
z__[2] = e[izero];
e[izero - 1] = 0.f;
e[izero] = 0.f;
}
z__[1] = d__[izero];
d__[izero] = 0.f;
}
}
/* Generate NRHS random solution vectors. */
ix = 1;
i__3 = *nrhs;
for (j = 1; j <= i__3; ++j) {
slarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L40: */
}
/* Set the right hand side. */
slaptm_(&n, nrhs, &c_b23, &d__[1], &e[1], &xact[1], &lda, &c_b24,
&b[1], &lda);
for (ifact = 1; ifact <= 2; ++ifact) {
if (ifact == 1) {
*(unsigned char *)fact = 'F';
} else {
*(unsigned char *)fact = 'N';
}
/* Compute the condition number for comparison with */
/* the value returned by SPTSVX. */
if (zerot) {
if (ifact == 1) {
goto L100;
}
rcondc = 0.f;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = slanst_("1", &n, &d__[1], &e[1]);
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
/* Factor the matrix A. */
spttrf_(&n, &d__[n + 1], &e[n + 1], &info);
/* Use SPTTRS to solve for one column at a time of */
/* inv(A), computing the maximum column sum as we go. */
ainvnm = 0.f;
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = n;
for (j = 1; j <= i__4; ++j) {
x[j] = 0.f;
/* L50: */
}
x[i__] = 1.f;
spttrs_(&n, &c__1, &d__[n + 1], &e[n + 1], &x[1], &
lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = sasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L60: */
}
/* Compute the 1-norm condition number of A. */
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
}
if (ifact == 2) {
/* --- Test SPTSV -- */
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
scopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
slacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor A as L*D*L' and solve the system A*X = B. */
s_copy(srnamc_1.srnamt, "SPTSV ", (ftnlen)32, (ftnlen)6);
sptsv_(&n, nrhs, &d__[n + 1], &e[n + 1], &x[1], &lda, &
info);
/* Check error code from SPTSV . */
if (info != izero) {
alaerh_(path, "SPTSV ", &info, &izero, " ", &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs,
nout);
}
nt = 0;
if (izero == 0) {
/* Check the factorization by computing the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
sptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
/* Compute the residual in the solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
sptt02_(&n, nrhs, &d__[1], &e[1], &x[1], &lda, &work[
1], &lda, &result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__3 = nt;
for (k = 1; k <= i__3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "SPTSV ", (ftnlen)6);
do_fio(&c__1, (char *)&n, (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(real));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += nt;
}
/* --- Test SPTSVX --- */
if (ifact > 1) {
/* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero. */
i__3 = n - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
d__[n + i__] = 0.f;
e[n + i__] = 0.f;
/* L80: */
}
if (n > 0) {
d__[n + n] = 0.f;
}
}
slaset_("Full", &n, nrhs, &c_b24, &c_b24, &x[1], &lda);
/* Solve the system and compute the condition number and */
/* error bounds using SPTSVX. */
s_copy(srnamc_1.srnamt, "SPTSVX", (ftnlen)32, (ftnlen)6);
sptsvx_(fact, &n, nrhs, &d__[1], &e[1], &d__[n + 1], &e[n + 1]
, &b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &rwork[
*nrhs + 1], &work[1], &info);
/* Check the error code from SPTSVX. */
if (info != izero) {
alaerh_(path, "SPTSVX", &info, &izero, fact, &n, &n, &
c__1, &c__1, nrhs, &imat, &nfail, &nerrs, nout);
}
if (izero == 0) {
if (ifact == 2) {
/* Check the factorization by computing the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
k1 = 1;
sptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &
work[1], result);
} else {
k1 = 2;
}
/* Compute the residual in the solution. */
slacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
sptt02_(&n, nrhs, &d__[1], &e[1], &x[1], &lda, &work[1], &
lda, &result[1]);
/* Check solution from generated exact solution. */
sget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[2]);
/* Check error bounds from iterative refinement. */
sptt05_(&n, nrhs, &d__[1], &e[1], &b[1], &lda, &x[1], &
lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs + 1],
&result[3]);
} else {
k1 = 6;
}
/* Check the reciprocal of the condition number. */
result[5] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = k1; k <= 6; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, "SPTSVX", (ftnlen)6);
do_fio(&c__1, fact, (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 *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
real));
e_wsfe();
++nfail;
}
/* L90: */
}
nrun = nrun + 7 - k1;
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of SDRVPT */
} /* sdrvpt_ */
/* Subroutine */ int cstein_(integer *n, real *d__, real *e, integer *m, real
*w, integer *iblock, integer *isplit, complex *z__, integer *ldz,
real *work, integer *iwork, integer *ifail, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4, r__5;
complex q__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, b1, j1, bn, jr;
real xj, scl, eps, ctr, sep, nrm, tol;
integer its;
real xjm, eps1;
integer jblk, nblk, jmax;
extern doublereal snrm2_(integer *, real *, integer *);
integer iseed[4], gpind, iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
real ortol;
integer indrv1, indrv2, indrv3, indrv4, indrv5;
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *), slagtf_(
integer *, real *, real *, real *, real *, real *, real *,
integer *, integer *);
integer nrmchk;
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slagts_(integer *, integer *, real *, real *,
real *, real *, integer *, real *, real *, integer *);
integer blksiz;
real onenrm, pertol;
extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real
*);
real stpcrt;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CSTEIN 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). */
/* Although the eigenvectors are real, they are stored in a complex */
/* array, which may be passed to CUNMTR or CUPMTR for back */
/* transformation to the eigenvectors of a complex Hermitian matrix */
/* which was reduced to tridiagonal form. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input) REAL array, dimension (N) */
/* The n diagonal elements of the tridiagonal matrix T. */
/* E (input) REAL array, dimension (N-1) */
/* The (n-1) subdiagonal elements of the tridiagonal matrix */
/* T, stored in elements 1 to N-1. */
/* M (input) INTEGER */
/* The number of eigenvectors to be found. 0 <= M <= N. */
/* W (input) REAL 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 SSTEBZ 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 SSTEBZ 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 SSTEBZ is expected here. ) */
/* Z (output) COMPLEX 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. */
/* The imaginary parts of the eigenvectors are set to zero. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= max(1,N). */
/* WORK (workspace) REAL 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
--w;
--iblock;
--isplit;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
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_("CSTEIN", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *m == 0) {
return 0;
} else if (*n == 1) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1.f, z__[i__1].i = 0.f;
return 0;
}
/* Get machine constants. */
eps = slamch_("Precision");
/* Initialize seed for random number generator SLARNV. */
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 = (r__1 = d__[b1], dabs(r__1)) + (r__2 = e[b1], dabs(r__2));
/* Computing MAX */
r__3 = onenrm, r__4 = (r__1 = d__[bn], dabs(r__1)) + (r__2 = e[bn - 1]
, dabs(r__2));
onenrm = dmax(r__3,r__4);
i__2 = bn - 1;
for (i__ = b1 + 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__4 = onenrm, r__5 = (r__1 = d__[i__], dabs(r__1)) + (r__2 = e[
i__ - 1], dabs(r__2)) + (r__3 = e[i__], dabs(r__3));
onenrm = dmax(r__4,r__5);
/* L50: */
}
ortol = onenrm * .001f;
stpcrt = sqrt(.1f / blksiz);
/* 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 L180;
}
++jblk;
xj = w[j];
/* Skip all the work if the block size is one. */
if (blksiz == 1) {
work[indrv1 + 1] = 1.f;
goto L140;
}
/* If eigenvalues j and j-1 are too close, add a relatively */
/* small perturbation. */
if (jblk > 1) {
eps1 = (r__1 = eps * xj, dabs(r__1));
pertol = eps1 * 10.f;
sep = xj - xjm;
if (sep < pertol) {
xj = xjm + pertol;
}
}
its = 0;
nrmchk = 0;
/* Get random starting vector. */
slarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]);
/* Copy the matrix T so it won't be destroyed in factorization. */
scopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1);
i__3 = blksiz - 1;
scopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1);
i__3 = blksiz - 1;
scopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1);
/* Compute LU factors with partial pivoting ( PT = LU ) */
tol = 0.f;
slagtf_(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[
indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo);
/* Update iteration count. */
L70:
++its;
if (its > 5) {
goto L120;
}
/* Normalize and scale the righthand side vector Pb. */
/* Computing MAX */
r__2 = eps, r__3 = (r__1 = work[indrv4 + blksiz], dabs(r__1));
scl = blksiz * onenrm * dmax(r__2,r__3) / sasum_(&blksiz, &work[
indrv1 + 1], &c__1);
sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
/* Solve the system LU = Pb. */
slagts_(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], &
work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[
indrv1 + 1], &tol, &iinfo);
/* Reorthogonalize by modified Gram-Schmidt if eigenvalues are */
/* close enough. */
if (jblk == 1) {
goto L110;
}
if ((r__1 = xj - xjm, dabs(r__1)) > ortol) {
gpind = j;
}
if (gpind != j) {
i__3 = j - 1;
for (i__ = gpind; i__ <= i__3; ++i__) {
ctr = 0.f;
i__4 = blksiz;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = b1 - 1 + jr + i__ * z_dim1;
ctr += work[indrv1 + jr] * z__[i__5].r;
/* L80: */
}
i__4 = blksiz;
for (jr = 1; jr <= i__4; ++jr) {
i__5 = b1 - 1 + jr + i__ * z_dim1;
work[indrv1 + jr] -= ctr * z__[i__5].r;
/* L90: */
}
/* L100: */
}
}
/* Check the infinity norm of the iterate. */
L110:
jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1);
nrm = (r__1 = work[indrv1 + jmax], dabs(r__1));
/* Continue for additional iterations after norm reaches */
/* stopping criterion. */
if (nrm < stpcrt) {
goto L70;
}
++nrmchk;
if (nrmchk < 3) {
goto L70;
}
goto L130;
/* If stopping criterion was not satisfied, update info and */
/* store eigenvector number in array ifail. */
L120:
++(*info);
ifail[*info] = j;
/* Accept iterate as jth eigenvector. */
L130:
scl = 1.f / snrm2_(&blksiz, &work[indrv1 + 1], &c__1);
jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1);
if (work[indrv1 + jmax] < 0.f) {
scl = -scl;
}
sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
L140:
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * z_dim1;
z__[i__4].r = 0.f, z__[i__4].i = 0.f;
/* L150: */
}
i__3 = blksiz;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = b1 + i__ - 1 + j * z_dim1;
i__5 = indrv1 + i__;
q__1.r = work[i__5], q__1.i = 0.f;
z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
/* L160: */
}
/* Save the shift to check eigenvalue spacing at next */
/* iteration. */
xjm = xj;
/* L170: */
}
L180:
;
}
return 0;
/* End of CSTEIN */
} /* cstein_ */
/* Subroutine */ int slacn2_(integer *n, real *v, real *x, integer *isgn,
real *est, integer *kase, integer *isave)
{
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
double r_sign(real *, real *);
integer i_nint(real *);
/* Local variables */
integer i__;
real temp;
integer jlast;
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
extern integer isamax_(integer *, real *, integer *);
real altsgn, estold;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLACN2 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) REAL array, dimension (N) */
/* On the final return, V = A*W, where EST = norm(V)/norm(W) */
/* (W is not returned). */
/* X (input/output) REAL array, dimension (N) */
/* On an intermediate return, X should be overwritten by */
/* A * X, if KASE=1, */
/* A' * X, if KASE=2, */
/* and SLACN2 must be re-called with all the other parameters */
/* unchanged. */
/* ISGN (workspace) INTEGER array, dimension (N) */
/* EST (input/output) REAL */
/* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be */
/* unchanged from the previous call to SLACN2. */
/* On exit, EST is an estimate (a lower bound) for norm(A). */
/* KASE (input/output) INTEGER */
/* On the initial call to SLACN2, 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 SLACN2, KASE will again be 0. */
/* ISAVE (input/output) INTEGER array, dimension (3) */
/* ISAVE is used to save variables between calls to SLACN2 */
/* 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 SLACON, which uses the array ISAVE */
/* in place of a SAVE statement, as follows: */
/* SLACON SLACN2 */
/* JUMP ISAVE(1) */
/* J ISAVE(2) */
/* ITER ISAVE(3) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--isave;
--isgn;
--x;
--v;
/* Function Body */
if (*kase == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = 1.f / (real) (*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 = dabs(v[1]);
/* ... QUIT */
goto L150;
}
*est = sasum_(n, &x[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = r_sign(&c_b11, &x[i__]);
isgn[i__] = i_nint(&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] = isamax_(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.f;
/* L60: */
}
x[isave[2]] = 1.f;
*kase = 1;
isave[1] = 3;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 3) */
/* X HAS BEEN OVERWRITTEN BY A*X. */
L70:
scopy_(n, &x[1], &c__1, &v[1], &c__1);
estold = *est;
*est = sasum_(n, &v[1], &c__1);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
r__1 = r_sign(&c_b11, &x[i__]);
if (i_nint(&r__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__] = r_sign(&c_b11, &x[i__]);
isgn[i__] = i_nint(&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] = isamax_(n, &x[1], &c__1);
if (x[jlast] != (r__1 = x[isave[2]], dabs(r__1)) && isave[3] < 5) {
++isave[3];
goto L50;
}
/* ITERATION COMPLETE. FINAL STAGE. */
L120:
altsgn = 1.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
x[i__] = altsgn * ((real) (i__ - 1) / (real) (*n - 1) + 1.f);
altsgn = -altsgn;
/* L130: */
}
*kase = 1;
isave[1] = 5;
return 0;
/* ................ ENTRY (ISAVE( 1 ) = 5) */
/* X HAS BEEN OVERWRITTEN BY A*X. */
L140:
temp = sasum_(n, &x[1], &c__1) / (real) (*n * 3) * 2.f;
if (temp > *est) {
scopy_(n, &x[1], &c__1, &v[1], &c__1);
*est = temp;
}
L150:
*kase = 0;
return 0;
/* End of SLACN2 */
} /* slacn2_ */
float sasum( int n, float *x, int incx)
{
return sasum_(&n, x, &incx);
}
