inline size_t amax(size_t N, const float* x)
{
lapack_int num = (lapack_int)(N);
lapack_int incx = 1;
return isamax_(&num, (float*)(x), &incx);
}
void test01 ( void )
/******************************************************************************/
/*
Purpose:
TEST01 demonstrates ISAMAX.
Modified:
29 March 2007
Author:
John Burkardt
*/
{
int i;
int i1;
int incx;
int n = 11;
float *x;
x = malloc ( n * sizeof ( float ) );
printf ( "\n" );
printf ( "TEST01\n" );
printf ( " ISAMAX returns the index of maximum magnitude;\n" );
for ( i = 1; i <= n; i++ )
{
x[i-1] = ( float ) ( ( 7 * i ) % 11 ) - ( float ) ( n / 2 );
}
printf ( "\n" );
printf ( " The vector X:\n" );
printf ( "\n" );
for ( i = 1; i <= n; i++ )
{
printf ( " %6d %8f\n", i, x[i-1] );
}
incx = 1;
i1 = isamax_ ( &n, x, &incx );
printf ( "\n" );
printf ( " The index of maximum magnitude = %d\n", i1 );
free ( x );
return;
}
/* 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_ */
int cgeev_(char *jobvl, char *jobvr, int *n, complex *a,
int *lda, complex *w, complex *vl, int *ldvl, complex *vr,
int *ldvr, complex *work, int *lwork, float *rwork, int *
info)
{
/* System generated locals */
int a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
float r__1, r__2;
complex q__1, q__2;
/* Builtin functions */
double sqrt(double), r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
int i__, k, ihi;
float scl;
int ilo;
float dum[1], eps;
complex tmp;
int ibal;
char side[1];
float anrm;
int ierr, itau, iwrk, nout;
extern int cscal_(int *, complex *, complex *,
int *);
extern int lsame_(char *, char *);
extern double scnrm2_(int *, complex *, int *);
extern int cgebak_(char *, char *, int *, int *,
int *, float *, int *, complex *, int *, int *), cgebal_(char *, int *, complex *, int *,
int *, int *, float *, int *), slabad_(float *,
float *);
int scalea;
extern double clange_(char *, int *, int *, complex *,
int *, float *);
float cscale;
extern int cgehrd_(int *, int *, int *,
complex *, int *, complex *, complex *, int *, int *),
clascl_(char *, int *, int *, float *, float *, int *,
int *, complex *, int *, int *);
extern double slamch_(char *);
extern int csscal_(int *, float *, complex *, int
*), clacpy_(char *, int *, int *, complex *, int *,
complex *, int *), xerbla_(char *, int *);
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
int select[1];
float bignum;
extern int isamax_(int *, float *, int *);
extern int chseqr_(char *, char *, int *, int *,
int *, complex *, int *, complex *, complex *, int *,
complex *, int *, int *), ctrevc_(char *,
char *, int *, int *, complex *, int *, complex *,
int *, complex *, int *, int *, int *, complex *,
float *, int *), cunghr_(int *, int *,
int *, complex *, int *, complex *, complex *, int *,
int *);
int minwrk, maxwrk;
int wantvl;
float smlnum;
int hswork, irwork;
int lquery, wantvr;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGEEV computes for an N-by-N complex nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component float. */
/* Arguments */
/* ========= */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of are computed. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* W (output) COMPLEX array, dimension (N) */
/* W contains the computed eigenvalues. */
/* VL (output) COMPLEX array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order */
/* as their eigenvalues. */
/* If JOBVL = 'N', VL is not referenced. */
/* u(j) = VL(:,j), the j-th column of VL. */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; if */
/* JOBVL = 'V', LDVL >= N. */
/* VR (output) COMPLEX array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order */
/* as their eigenvalues. */
/* If JOBVR = 'N', VR is not referenced. */
/* v(j) = VR(:,j), the j-th column of VR. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1; if */
/* JOBVR = 'V', LDVR >= N. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= MAX(1,2*N). */
/* For good performance, LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) REAL array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the QR algorithm failed to compute all the */
/* eigenvalues, and no eigenvectors have been computed; */
/* elements and i+1:N of W contain eigenvalues which have */
/* converged. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -1;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < MAX(1,*n)) {
*info = -5;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -10;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* CWorkspace refers to complex workspace, and RWorkspace to float */
/* workspace. NB refers to the optimal block size for the */
/* immediately following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by CHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = *n + *n * ilaenv_(&c__1, "CGEHRD", " ", n, &c__1, n, &
c__0);
minwrk = *n << 1;
if (wantvl) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = MAX(i__1,i__2);
chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[1], &c_n1, info);
} else if (wantvr) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = MAX(i__1,i__2);
chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[1], &c_n1, info);
} else {
chseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[1], &c_n1, info);
}
hswork = work[1].r;
/* Computing MAX */
i__1 = MAX(maxwrk,hswork);
maxwrk = MAX(i__1,minwrk);
}
work[1].r = (float) maxwrk, work[1].i = 0.f;
if (*lwork < minwrk && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEEV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = clange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE;
cscale = bignum;
}
if (scalea) {
clascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
ibal = 1;
cgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr);
/* Reduce to upper Hessenberg form */
/* (CWorkspace: need 2*N, prefer N+N*NB) */
/* (RWorkspace: none) */
itau = 1;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
cgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
&ierr);
if (wantvl) {
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
clacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate unitary matrix in VL */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
cunghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
clacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
clacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate unitary matrix in VR */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
cunghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from CHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (CWorkspace: need 2*N) */
/* (RWorkspace: need 2*N) */
irwork = ibal + *n;
ctrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[irwork],
&ierr);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
cgebak_("B", "L", n, &ilo, &ihi, &rwork[ibal], n, &vl[vl_offset],
ldvl, &ierr);
/* Normalize left eigenvectors and make largest component float */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1.f / scnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
csscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + i__ * vl_dim1;
/* Computing 2nd power */
r__1 = vl[i__3].r;
/* Computing 2nd power */
r__2 = r_imag(&vl[k + i__ * vl_dim1]);
rwork[irwork + k - 1] = r__1 * r__1 + r__2 * r__2;
/* L10: */
}
k = isamax_(n, &rwork[irwork], &c__1);
r_cnjg(&q__2, &vl[k + i__ * vl_dim1]);
r__1 = sqrt(rwork[irwork + k - 1]);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
tmp.r = q__1.r, tmp.i = q__1.i;
cscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = k + i__ * vl_dim1;
i__3 = k + i__ * vl_dim1;
r__1 = vl[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
vl[i__2].r = q__1.r, vl[i__2].i = q__1.i;
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
cgebak_("B", "R", n, &ilo, &ihi, &rwork[ibal], n, &vr[vr_offset],
ldvr, &ierr);
/* Normalize right eigenvectors and make largest component float */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1.f / scnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
csscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + i__ * vr_dim1;
/* Computing 2nd power */
r__1 = vr[i__3].r;
/* Computing 2nd power */
r__2 = r_imag(&vr[k + i__ * vr_dim1]);
rwork[irwork + k - 1] = r__1 * r__1 + r__2 * r__2;
/* L30: */
}
k = isamax_(n, &rwork[irwork], &c__1);
r_cnjg(&q__2, &vr[k + i__ * vr_dim1]);
r__1 = sqrt(rwork[irwork + k - 1]);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
tmp.r = q__1.r, tmp.i = q__1.i;
cscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = k + i__ * vr_dim1;
i__3 = k + i__ * vr_dim1;
r__1 = vr[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
vr[i__2].r = q__1.r, vr[i__2].i = q__1.i;
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = MAX(i__3,1);
clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1]
, &i__2, &ierr);
if (*info > 0) {
i__1 = ilo - 1;
clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n,
&ierr);
}
}
work[1].r = (float) maxwrk, work[1].i = 0.f;
return 0;
/* End of CGEEV */
} /* cgeev_ */
/* Subroutine */ int sppcon_(char *uplo, integer *n, real *ap, real *anorm,
real *rcond, real *work, integer *iwork, integer *info, ftnlen
uplo_len)
{
/* System generated locals */
integer i__1;
real r__1;
/* Local variables */
static integer ix, kase;
static real scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
static logical upper;
static real scalel;
extern doublereal slamch_(char *, ftnlen);
static real scaleu;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slacon_(
integer *, real *, real *, integer *, real *, integer *);
extern integer isamax_(integer *, real *, integer *);
static real ainvnm;
static char normin[1];
extern /* Subroutine */ int slatps_(char *, char *, char *, char *,
integer *, real *, real *, real *, real *, integer *, ftnlen,
ftnlen, ftnlen, ftnlen);
static real smlnum;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPPCON estimates the reciprocal of the condition number (in the */
/* 1-norm) of a real symmetric positive definite packed matrix using */
/* the Cholesky factorization A = U**T*U or A = L*L**T computed by */
/* SPPTRF. */
/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */
/* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input) REAL array, dimension (N*(N+1)/2) */
/* The triangular factor U or L from the Cholesky factorization */
/* A = U**T*U or A = L*L**T, packed columnwise in a linear */
/* array. The j-th column of U or L is stored in the array AP */
/* as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
/* ANORM (input) REAL */
/* The 1-norm (or infinity-norm) of the symmetric matrix A. */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */
/* estimate of the 1-norm of inv(A) computed in this routine. */
/* WORK (workspace) REAL array, dimension (3*N) */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--iwork;
--work;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*anorm < 0.f) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPPCON", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
smlnum = slamch_("Safe minimum", (ftnlen)12);
/* Estimate the 1-norm of the inverse. */
kase = 0;
*(unsigned char *)normin = 'N';
L10:
slacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
slatps_("Upper", "Transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scalel, &work[(*n << 1) + 1], info, (ftnlen)5, (
ftnlen)9, (ftnlen)8, (ftnlen)1);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
slatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scaleu, &work[(*n << 1) + 1], info, (ftnlen)5, (
ftnlen)12, (ftnlen)8, (ftnlen)1);
} else {
/* Multiply by inv(L). */
slatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scalel, &work[(*n << 1) + 1], info, (ftnlen)5, (
ftnlen)12, (ftnlen)8, (ftnlen)1);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
slatps_("Lower", "Transpose", "Non-unit", normin, n, &ap[1], &
work[1], &scaleu, &work[(*n << 1) + 1], info, (ftnlen)5, (
ftnlen)9, (ftnlen)8, (ftnlen)1);
}
/* Multiply by 1/SCALE if doing so will not cause overflow. */
scale = scalel * scaleu;
if (scale != 1.f) {
ix = isamax_(n, &work[1], &c__1);
if (scale < (r__1 = work[ix], dabs(r__1)) * smlnum || scale ==
0.f) {
goto L20;
}
srscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / ainvnm / *anorm;
}
L20:
return 0;
/* End of SPPCON */
} /* sppcon_ */
int slasyf_(char *uplo, int *n, int *nb, int *kb,
float *a, int *lda, int *ipiv, float *w, int *ldw, int
*info)
{
/* System generated locals */
int a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5;
float r__1, r__2, r__3;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int j, k;
float t, r1, d11, d21, d22;
int jb, jj, kk, jp, kp, kw, kkw, imax, jmax;
float alpha;
extern int lsame_(char *, char *);
extern int sscal_(int *, float *, float *, int *),
sgemm_(char *, char *, int *, int *, int *, float *,
float *, int *, float *, int *, float *, float *, int *), sgemv_(char *, int *, int *, float *,
float *, int *, float *, int *, float *, float *, int *);
int kstep;
extern int scopy_(int *, float *, int *, float *,
int *), sswap_(int *, float *, int *, float *, int *
);
float absakk;
extern int isamax_(int *, float *, int *);
float colmax, rowmax;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLASYF computes a partial factorization of a float symmetric matrix A */
/* using the Bunch-Kaufman diagonal pivoting method. The partial */
/* factorization has the form: */
/* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: */
/* ( 0 U22 ) ( 0 D ) ( U12' U22' ) */
/* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L' */
/* ( L21 I ) ( 0 A22 ) ( 0 I ) */
/* where the order of D is at most NB. The actual order is returned in */
/* the argument KB, and is either NB or NB-1, or N if N <= NB. */
/* SLASYF is an auxiliary routine called by SSYTRF. It uses blocked code */
/* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or */
/* A22 (if UPLO = 'L'). */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NB (input) INTEGER */
/* The maximum number of columns of the matrix A that should be */
/* factored. NB should be at least 2 to allow for 2-by-2 pivot */
/* blocks. */
/* KB (output) INTEGER */
/* The number of columns of A that were actually factored. */
/* KB is either NB-1 or NB, or N if N <= NB. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */
/* n-by-n upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n-by-n lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, A contains details of the partial factorization. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* IPIV (output) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D. */
/* If UPLO = 'U', only the last KB elements of IPIV are set; */
/* if UPLO = 'L', only the first KB elements are set. */
/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
/* W (workspace) REAL array, dimension (LDW,NB) */
/* LDW (input) INTEGER */
/* The leading dimension of the array W. LDW >= MAX(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* > 0: if INFO = k, D(k,k) is exactly zero. The factorization */
/* has been completed, but the block diagonal matrix D is */
/* exactly singular. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
*info = 0;
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.f) + 1.f) / 8.f;
if (lsame_(uplo, "U")) {
/* Factorize the trailing columns of A using the upper triangle */
/* of A and working backwards, and compute the matrix W = U12*D */
/* for use in updating A11 */
/* K is the main loop index, decreasing from N in steps of 1 or 2 */
/* KW is the column of W which corresponds to column K of A */
k = *n;
L10:
kw = *nb + k - *n;
/* Exit from loop */
if (k <= *n - *nb + 1 && *nb < *n || k < 1) {
goto L30;
}
/* Copy column K of A to column KW of W and update it */
scopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1);
if (k < *n) {
i__1 = *n - k;
sgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) * a_dim1 + 1],
lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b9, &w[kw *
w_dim1 + 1], &c__1);
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
absakk = (r__1 = w[k + kw * w_dim1], ABS(r__1));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
if (k > 1) {
i__1 = k - 1;
imax = isamax_(&i__1, &w[kw * w_dim1 + 1], &c__1);
colmax = (r__1 = w[imax + kw * w_dim1], ABS(r__1));
} else {
colmax = 0.f;
}
if (MAX(absakk,colmax) == 0.f) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* Copy column IMAX to column KW-1 of W and update it */
scopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) *
w_dim1 + 1], &c__1);
i__1 = k - imax;
scopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax +
1 + (kw - 1) * w_dim1], &c__1);
if (k < *n) {
i__1 = *n - k;
sgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) *
a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1],
ldw, &c_b9, &w[(kw - 1) * w_dim1 + 1], &c__1);
}
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
i__1 = k - imax;
jmax = imax + isamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1],
&c__1);
rowmax = (r__1 = w[jmax + (kw - 1) * w_dim1], ABS(r__1));
if (imax > 1) {
i__1 = imax - 1;
jmax = isamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1);
/* Computing MAX */
r__2 = rowmax, r__3 = (r__1 = w[jmax + (kw - 1) * w_dim1],
ABS(r__1));
rowmax = MAX(r__2,r__3);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else if ((r__1 = w[imax + (kw - 1) * w_dim1], ABS(r__1)) >=
alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
/* copy column KW-1 of W to column KW */
scopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw *
w_dim1 + 1], &c__1);
} else {
/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
kk = k - kstep + 1;
kkw = *nb + kk - *n;
/* Updated column KP is already stored in column KKW of W */
if (kp != kk) {
/* Copy non-updated column KK to column KP */
a[kp + k * a_dim1] = a[kk + k * a_dim1];
i__1 = k - 1 - kp;
scopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp +
1) * a_dim1], lda);
scopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &
c__1);
/* Interchange rows KK and KP in last KK columns of A and W */
i__1 = *n - kk + 1;
sswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1],
lda);
i__1 = *n - kk + 1;
sswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw *
w_dim1], ldw);
}
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column KW of W now holds */
/* W(k) = U(k)*D(k) */
/* where U(k) is the k-th column of U */
/* Store U(k) in column k of A */
scopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &
c__1);
r1 = 1.f / a[k + k * a_dim1];
i__1 = k - 1;
sscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1);
} else {
/* 2-by-2 pivot block D(k): columns KW and KW-1 of W now */
/* hold */
/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */
/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */
/* of U */
if (k > 2) {
/* Store U(k) and U(k-1) in columns k and k-1 of A */
d21 = w[k - 1 + kw * w_dim1];
d11 = w[k + kw * w_dim1] / d21;
d22 = w[k - 1 + (kw - 1) * w_dim1] / d21;
t = 1.f / (d11 * d22 - 1.f);
d21 = t / d21;
i__1 = k - 2;
for (j = 1; j <= i__1; ++j) {
a[j + (k - 1) * a_dim1] = d21 * (d11 * w[j + (kw - 1)
* w_dim1] - w[j + kw * w_dim1]);
a[j + k * a_dim1] = d21 * (d22 * w[j + kw * w_dim1] -
w[j + (kw - 1) * w_dim1]);
/* L20: */
}
}
/* Copy D(k) to A */
a[k - 1 + (k - 1) * a_dim1] = w[k - 1 + (kw - 1) * w_dim1];
a[k - 1 + k * a_dim1] = w[k - 1 + kw * w_dim1];
a[k + k * a_dim1] = w[k + kw * w_dim1];
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
/* Decrease K and return to the start of the main loop */
k -= kstep;
goto L10;
L30:
/* Update the upper triangle of A11 (= A(1:k,1:k)) as */
/* A11 := A11 - U12*D*U12' = A11 - U12*W' */
/* computing blocks of NB columns at a time */
i__1 = -(*nb);
for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j +=
i__1) {
/* Computing MIN */
i__2 = *nb, i__3 = k - j + 1;
jb = MIN(i__2,i__3);
/* Update the upper triangle of the diagonal block */
i__2 = j + jb - 1;
for (jj = j; jj <= i__2; ++jj) {
i__3 = jj - j + 1;
i__4 = *n - k;
sgemv_("No transpose", &i__3, &i__4, &c_b8, &a[j + (k + 1) *
a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b9,
&a[j + jj * a_dim1], &c__1);
/* L40: */
}
/* Update the rectangular superdiagonal block */
i__2 = j - 1;
i__3 = *n - k;
sgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &c_b8, &a[(
k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw,
&c_b9, &a[j * a_dim1 + 1], lda);
/* L50: */
}
/* Put U12 in standard form by partially undoing the interchanges */
/* in columns k+1:n */
j = k + 1;
L60:
jj = j;
jp = ipiv[j];
if (jp < 0) {
jp = -jp;
++j;
}
++j;
if (jp != jj && j <= *n) {
i__1 = *n - j + 1;
sswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda);
}
if (j <= *n) {
goto L60;
}
/* Set KB to the number of columns factorized */
*kb = *n - k;
} else {
/* Factorize the leading columns of A using the lower triangle */
/* of A and working forwards, and compute the matrix W = L21*D */
/* for use in updating A22 */
/* K is the main loop index, increasing from 1 in steps of 1 or 2 */
k = 1;
L70:
/* Exit from loop */
if (k >= *nb && *nb < *n || k > *n) {
goto L90;
}
/* Copy column K of A to column K of W and update it */
i__1 = *n - k + 1;
scopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1);
i__1 = *n - k + 1;
i__2 = k - 1;
sgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], lda, &w[k
+ w_dim1], ldw, &c_b9, &w[k + k * w_dim1], &c__1);
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
absakk = (r__1 = w[k + k * w_dim1], ABS(r__1));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
if (k < *n) {
i__1 = *n - k;
imax = k + isamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1);
colmax = (r__1 = w[imax + k * w_dim1], ABS(r__1));
} else {
colmax = 0.f;
}
if (MAX(absakk,colmax) == 0.f) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* Copy column IMAX to column K+1 of W and update it */
i__1 = imax - k;
scopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) *
w_dim1], &c__1);
i__1 = *n - imax + 1;
scopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k +
1) * w_dim1], &c__1);
i__1 = *n - k + 1;
i__2 = k - 1;
sgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1],
lda, &w[imax + w_dim1], ldw, &c_b9, &w[k + (k + 1) *
w_dim1], &c__1);
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
i__1 = imax - k;
jmax = k - 1 + isamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1)
;
rowmax = (r__1 = w[jmax + (k + 1) * w_dim1], ABS(r__1));
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + isamax_(&i__1, &w[imax + 1 + (k + 1) *
w_dim1], &c__1);
/* Computing MAX */
r__2 = rowmax, r__3 = (r__1 = w[jmax + (k + 1) * w_dim1],
ABS(r__1));
rowmax = MAX(r__2,r__3);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else if ((r__1 = w[imax + (k + 1) * w_dim1], ABS(r__1)) >=
alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
/* copy column K+1 of W to column K */
i__1 = *n - k + 1;
scopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k *
w_dim1], &c__1);
} else {
/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
kk = k + kstep - 1;
/* Updated column KP is already stored in column KK of W */
if (kp != kk) {
/* Copy non-updated column KK to column KP */
a[kp + k * a_dim1] = a[kk + k * a_dim1];
i__1 = kp - k - 1;
scopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1)
* a_dim1], lda);
i__1 = *n - kp + 1;
scopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp *
a_dim1], &c__1);
/* Interchange rows KK and KP in first KK columns of A and W */
sswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda);
sswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw);
}
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k of W now holds */
/* W(k) = L(k)*D(k) */
/* where L(k) is the k-th column of L */
/* Store L(k) in column k of A */
i__1 = *n - k + 1;
scopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], &
c__1);
if (k < *n) {
r1 = 1.f / a[k + k * a_dim1];
i__1 = *n - k;
sscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1);
}
} else {
/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */
/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */
/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */
/* of L */
if (k < *n - 1) {
/* Store L(k) and L(k+1) in columns k and k+1 of A */
d21 = w[k + 1 + k * w_dim1];
d11 = w[k + 1 + (k + 1) * w_dim1] / d21;
d22 = w[k + k * w_dim1] / d21;
t = 1.f / (d11 * d22 - 1.f);
d21 = t / d21;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
a[j + k * a_dim1] = d21 * (d11 * w[j + k * w_dim1] -
w[j + (k + 1) * w_dim1]);
a[j + (k + 1) * a_dim1] = d21 * (d22 * w[j + (k + 1) *
w_dim1] - w[j + k * w_dim1]);
/* L80: */
}
}
/* Copy D(k) to A */
a[k + k * a_dim1] = w[k + k * w_dim1];
a[k + 1 + k * a_dim1] = w[k + 1 + k * w_dim1];
a[k + 1 + (k + 1) * a_dim1] = w[k + 1 + (k + 1) * w_dim1];
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
/* Increase K and return to the start of the main loop */
k += kstep;
goto L70;
L90:
/* Update the lower triangle of A22 (= A(k:n,k:n)) as */
/* A22 := A22 - L21*D*L21' = A22 - L21*W' */
/* computing blocks of NB columns at a time */
i__1 = *n;
i__2 = *nb;
for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__3 = *nb, i__4 = *n - j + 1;
jb = MIN(i__3,i__4);
/* Update the lower triangle of the diagonal block */
i__3 = j + jb - 1;
for (jj = j; jj <= i__3; ++jj) {
i__4 = j + jb - jj;
i__5 = k - 1;
sgemv_("No transpose", &i__4, &i__5, &c_b8, &a[jj + a_dim1],
lda, &w[jj + w_dim1], ldw, &c_b9, &a[jj + jj * a_dim1]
, &c__1);
/* L100: */
}
/* Update the rectangular subdiagonal block */
if (j + jb <= *n) {
i__3 = *n - j - jb + 1;
i__4 = k - 1;
sgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &c_b8,
&a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b9,
&a[j + jb + j * a_dim1], lda);
}
/* L110: */
}
/* Put L21 in standard form by partially undoing the interchanges */
/* in columns 1:k-1 */
j = k - 1;
L120:
jj = j;
jp = ipiv[j];
if (jp < 0) {
jp = -jp;
--j;
}
--j;
if (jp != jj && j >= 1) {
sswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda);
}
if (j >= 1) {
goto L120;
}
/* Set KB to the number of columns factorized */
*kb = k - 1;
}
return 0;
/* End of SLASYF */
} /* slasyf_ */
/* 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_ */
int sgesc2_(int *n, float *a, int *lda, float *rhs,
int *ipiv, int *jpiv, float *scale)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2;
float r__1, r__2;
/* Local variables */
int i__, j;
float eps, temp;
extern int sscal_(int *, float *, float *, int *),
slabad_(float *, float *);
extern double slamch_(char *);
float bignum;
extern int isamax_(int *, float *, int *);
extern int slaswp_(int *, float *, int *, int
*, int *, int *, int *);
float smlnum;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGESC2 solves a system of linear equations */
/* A * X = scale* RHS */
/* with a general N-by-N matrix A using the LU factorization with */
/* complete pivoting computed by SGETC2. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* A (input) REAL array, dimension (LDA,N) */
/* On entry, the LU part of the factorization of the n-by-n */
/* matrix A computed by SGETC2: A = P * L * U * Q */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1, N). */
/* RHS (input/output) REAL array, dimension (N). */
/* On entry, the right hand side vector b. */
/* On exit, the solution vector X. */
/* IPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= i <= N, row i of the */
/* matrix has been interchanged with row IPIV(i). */
/* JPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= j <= N, column j of the */
/* matrix has been interchanged with column JPIV(j). */
/* SCALE (output) REAL */
/* On exit, SCALE contains the scale factor. SCALE is chosen */
/* 0 <= SCALE <= 1 to prevent owerflow in the solution. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Set constant to control owerflow */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--rhs;
--ipiv;
--jpiv;
/* Function Body */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Apply permutations IPIV to RHS */
i__1 = *n - 1;
slaswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &ipiv[1], &c__1);
/* Solve for L part */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
rhs[j] -= a[j + i__ * a_dim1] * rhs[i__];
/* L10: */
}
/* L20: */
}
/* Solve for U part */
*scale = 1.f;
/* Check for scaling */
i__ = isamax_(n, &rhs[1], &c__1);
if (smlnum * 2.f * (r__1 = rhs[i__], ABS(r__1)) > (r__2 = a[*n + *n *
a_dim1], ABS(r__2))) {
temp = .5f / (r__1 = rhs[i__], ABS(r__1));
sscal_(n, &temp, &rhs[1], &c__1);
*scale *= temp;
}
for (i__ = *n; i__ >= 1; --i__) {
temp = 1.f / a[i__ + i__ * a_dim1];
rhs[i__] *= temp;
i__1 = *n;
for (j = i__ + 1; j <= i__1; ++j) {
rhs[i__] -= rhs[j] * (a[i__ + j * a_dim1] * temp);
/* L30: */
}
/* L40: */
}
/* Apply permutations JPIV to the solution (RHS) */
i__1 = *n - 1;
slaswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &jpiv[1], &c_n1);
return 0;
/* End of SGESC2 */
} /* sgesc2_ */
/* Subroutine */ int sptrfs_(integer *n, integer *nrhs, real *d__, real *e,
real *df, real *ef, real *b, integer *ldb, real *x, integer *ldx,
real *ferr, real *berr, real *work, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
real r__1, r__2, r__3;
/* Local variables */
integer i__, j;
real s, bi, cx, dx, ex;
integer ix, nz;
real eps, safe1, safe2;
integer count;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *);
extern doublereal slamch_(char *);
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
real lstres;
extern /* Subroutine */ int spttrs_(integer *, integer *, real *, real *,
real *, integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPTRFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is symmetric positive definite */
/* and tridiagonal, and provides error bounds and backward error */
/* estimates for the solution. */
/* Arguments */
/* ========= */
/* 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 matrix B. NRHS >= 0. */
/* D (input) REAL array, dimension (N) */
/* The n diagonal elements of the tridiagonal matrix A. */
/* E (input) REAL array, dimension (N-1) */
/* The (n-1) subdiagonal elements of the tridiagonal matrix A. */
/* DF (input) REAL array, dimension (N) */
/* The n diagonal elements of the diagonal matrix D from the */
/* factorization computed by SPTTRF. */
/* EF (input) REAL array, dimension (N-1) */
/* The (n-1) subdiagonal elements of the unit bidiagonal factor */
/* L from the factorization computed by SPTTRF. */
/* B (input) REAL array, dimension (LDB,NRHS) */
/* The right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input/output) REAL array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by SPTTRS. */
/* On exit, the improved solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* FERR (output) REAL array, dimension (NRHS) */
/* The forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). */
/* BERR (output) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) REAL array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Internal Parameters */
/* =================== */
/* ITMAX is the maximum number of steps of iterative refinement. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
--df;
--ef;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*nrhs < 0) {
*info = -2;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldx < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPTRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = 4;
eps = slamch_("Epsilon");
safmin = slamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
count = 1;
lstres = 3.f;
L20:
/* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - A * X. Also compute */
/* abs(A)*abs(x) + abs(b) for use in the backward error bound. */
if (*n == 1) {
bi = b[j * b_dim1 + 1];
dx = d__[1] * x[j * x_dim1 + 1];
work[*n + 1] = bi - dx;
work[1] = dabs(bi) + dabs(dx);
} else {
bi = b[j * b_dim1 + 1];
dx = d__[1] * x[j * x_dim1 + 1];
ex = e[1] * x[j * x_dim1 + 2];
work[*n + 1] = bi - dx - ex;
work[1] = dabs(bi) + dabs(dx) + dabs(ex);
i__2 = *n - 1;
for (i__ = 2; i__ <= i__2; ++i__) {
bi = b[i__ + j * b_dim1];
cx = e[i__ - 1] * x[i__ - 1 + j * x_dim1];
dx = d__[i__] * x[i__ + j * x_dim1];
ex = e[i__] * x[i__ + 1 + j * x_dim1];
work[*n + i__] = bi - cx - dx - ex;
work[i__] = dabs(bi) + dabs(cx) + dabs(dx) + dabs(ex);
/* L30: */
}
bi = b[*n + j * b_dim1];
cx = e[*n - 1] * x[*n - 1 + j * x_dim1];
dx = d__[*n] * x[*n + j * x_dim1];
work[*n + *n] = bi - cx - dx;
work[*n] = dabs(bi) + dabs(cx) + dabs(dx);
}
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
/* where abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
s = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
/* Computing MAX */
r__2 = s, r__3 = (r__1 = work[*n + i__], dabs(r__1)) / work[
i__];
s = dmax(r__2,r__3);
} else {
/* Computing MAX */
r__2 = s, r__3 = ((r__1 = work[*n + i__], dabs(r__1)) + safe1)
/ (work[i__] + safe1);
s = dmax(r__2,r__3);
}
/* L40: */
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if */
/* 1) The residual BERR(J) is larger than machine epsilon, and */
/* 2) BERR(J) decreased by at least a factor of 2 during the */
/* last iteration, and */
/* 3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
/* Update solution and try again. */
spttrs_(n, &c__1, &df[1], &ef[1], &work[*n + 1], n, info);
saxpy_(n, &c_b11, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
;
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( abs(inv(A))* */
/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(A) is the inverse of A */
/* abs(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (work[i__] > safe2) {
work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
work[i__];
} else {
work[i__] = (r__1 = work[*n + i__], dabs(r__1)) + nz * eps *
work[i__] + safe1;
}
/* L50: */
}
ix = isamax_(n, &work[1], &c__1);
ferr[j] = work[ix];
/* Estimate the norm of inv(A). */
/* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by */
/* m(i,j) = abs(A(i,j)), i = j, */
/* m(i,j) = -abs(A(i,j)), i .ne. j, */
/* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. */
/* Solve M(L) * x = e. */
work[1] = 1.f;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
work[i__] = work[i__ - 1] * (r__1 = ef[i__ - 1], dabs(r__1)) +
1.f;
/* L60: */
}
/* Solve D * M(L)' * x = b. */
work[*n] /= df[*n];
for (i__ = *n - 1; i__ >= 1; --i__) {
work[i__] = work[i__] / df[i__] + work[i__ + 1] * (r__1 = ef[i__],
dabs(r__1));
/* L70: */
}
/* Compute norm(inv(A)) = max(x(i)), 1<=i<=n. */
ix = isamax_(n, &work[1], &c__1);
ferr[j] *= (r__1 = work[ix], dabs(r__1));
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], dabs(r__1));
lstres = dmax(r__2,r__3);
/* L80: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L90: */
}
return 0;
/* End of SPTRFS */
} /* sptrfs_ */
/* Subroutine */ int cchkpt_(logical *dotype, integer *nn, integer *nval,
integer *nns, integer *nsval, real *thresh, logical *tsterr, complex *
a, real *d__, complex *e, complex *b, complex *x, complex *xact,
complex *work, real *rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 0,0,0,1 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 N =\002,i5,\002, type \002,i2,\002, te"
"st \002,i2,\002, ratio = \002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS =\002,i3,\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, i__5;
real r__1, r__2;
/* Local variables */
integer i__, j, k, n;
complex z__[3];
integer ia, in, kl, ku, ix, lda;
real cond;
integer mode;
real dmax__;
integer imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
integer nfail, iseed[4];
real rcond;
integer nimat;
real anorm;
integer iuplo, izero, nerrs;
logical zerot;
real rcondc;
real ainvnm;
real result[7];
/* Fortran I/O blocks */
static cilist io___30 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKPT tests CPTTRF, -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) COMPLEX array, dimension (NMAX*2) */
/* D (workspace) REAL array, dimension (NMAX*2) */
/* E (workspace) COMPLEX array, dimension (NMAX*2) */
/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* WORK (workspace) COMPLEX array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) REAL array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* 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;
--nsval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
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) {
cerrgt_(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 CLATB4. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode, &
cond, dist);
zerot = imat >= 8 && imat <= 10;
if (imat <= 6) {
/* Type 1-6: generate a Hermitian tridiagonal matrix of */
/* known condition number in lower triangular band storage. */
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
clatms_(&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 CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &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__) {
i__4 = ia;
d__[i__] = a[i__4].r;
i__4 = i__;
i__5 = ia + 1;
e[i__4].r = a[i__5].r, e[i__4].i = a[i__5].i;
ia += 2;
/* L20: */
}
if (n > 0) {
i__3 = ia;
d__[n] = a[i__3].r;
}
} else {
/* Type 7-12: generate a diagonally dominant matrix with */
/* unknown condition number in the vectors D and E. */
if (! zerot || ! dotype[7]) {
/* Let E be complex, D real, with values from [-1,1]. */
slarnv_(&c__2, iseed, &n, &d__[1]);
i__3 = n - 1;
clarnv_(&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]) + c_abs(&e[1]);
d__[n] = (r__1 = d__[n], dabs(r__1)) + c_abs(&e[n - 1]
);
i__3 = n - 1;
for (i__ = 2; i__ <= i__3; ++i__) {
d__[i__] = (r__1 = d__[i__], dabs(r__1)) + c_abs(&
e[i__]) + c_abs(&e[i__ - 1]);
/* 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);
i__3 = n - 1;
r__1 = anorm / dmax__;
csscal_(&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].r;
if (n > 1) {
e[1].r = z__[2].r, e[1].i = z__[2].i;
}
} else if (izero == n) {
i__3 = n - 1;
e[i__3].r = z__[0].r, e[i__3].i = z__[0].i;
i__3 = n;
d__[i__3] = z__[1].r;
} else {
i__3 = izero - 1;
e[i__3].r = z__[0].r, e[i__3].i = z__[0].i;
i__3 = izero;
d__[i__3] = z__[1].r;
i__3 = izero;
e[i__3].r = z__[2].r, e[i__3].i = z__[2].i;
}
}
/* For types 8-10, set one row and column of the matrix to */
/* zero. */
izero = 0;
if (imat == 8) {
izero = 1;
z__[1].r = d__[1], z__[1].i = 0.f;
d__[1] = 0.f;
if (n > 1) {
z__[2].r = e[1].r, z__[2].i = e[1].i;
e[1].r = 0.f, e[1].i = 0.f;
}
} else if (imat == 9) {
izero = n;
if (n > 1) {
i__3 = n - 1;
z__[0].r = e[i__3].r, z__[0].i = e[i__3].i;
i__3 = n - 1;
e[i__3].r = 0.f, e[i__3].i = 0.f;
}
i__3 = n;
z__[1].r = d__[i__3], z__[1].i = 0.f;
d__[n] = 0.f;
} else if (imat == 10) {
izero = (n + 1) / 2;
if (izero > 1) {
i__3 = izero - 1;
z__[0].r = e[i__3].r, z__[0].i = e[i__3].i;
i__3 = izero;
z__[2].r = e[i__3].r, z__[2].i = e[i__3].i;
i__3 = izero - 1;
e[i__3].r = 0.f, e[i__3].i = 0.f;
i__3 = izero;
e[i__3].r = 0.f, e[i__3].i = 0.f;
}
i__3 = izero;
z__[1].r = d__[i__3], z__[1].i = 0.f;
d__[izero] = 0.f;
}
}
scopy_(&n, &d__[1], &c__1, &d__[n + 1], &c__1);
if (n > 1) {
i__3 = n - 1;
ccopy_(&i__3, &e[1], &c__1, &e[n + 1], &c__1);
}
/* + TEST 1 */
/* Factor A as L*D*L' and compute the ratio */
/* norm(L*D*L' - A) / (n * norm(A) * EPS ) */
cpttrf_(&n, &d__[n + 1], &e[n + 1], &info);
/* Check error code from CPTTRF. */
if (info != izero) {
alaerh_(path, "CPTTRF", &info, &izero, " ", &n, &n, &c_n1, &
c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
if (info > 0) {
rcondc = 0.f;
goto L100;
}
cptt01_(&n, &d__[1], &e[1], &d__[n + 1], &e[n + 1], &work[1],
result);
/* Print the test ratio if greater than or equal to THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___30.ciunit = *nout;
s_wsfe(&io___30);
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;
/* Compute RCONDC = 1 / (norm(A) * norm(inv(A)) */
/* Compute norm(A). */
anorm = clanht_("1", &n, &d__[1], &e[1]);
/* Use CPTTRS 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) {
i__5 = j;
x[i__5].r = 0.f, x[i__5].i = 0.f;
/* L40: */
}
i__4 = i__;
x[i__4].r = 1.f, x[i__4].i = 0.f;
cpttrs_("Lower", &n, &c__1, &d__[n + 1], &e[n + 1], &x[1], &
lda, &info);
/* Computing MAX */
r__1 = ainvnm, r__2 = scasum_(&n, &x[1], &c__1);
ainvnm = dmax(r__1,r__2);
/* L50: */
}
/* Computing MAX */
r__1 = 1.f, r__2 = anorm * ainvnm;
rcondc = 1.f / dmax(r__1,r__2);
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) {
clarnv_(&c__2, iseed, &n, &xact[ix]);
ix += lda;
/* L60: */
}
for (iuplo = 1; iuplo <= 2; ++iuplo) {
/* Do first for UPLO = 'U', then for UPLO = 'L'. */
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
1];
/* Set the right hand side. */
claptm_(uplo, &n, &nrhs, &c_b48, &d__[1], &e[1], &xact[1],
&lda, &c_b49, &b[1], &lda);
/* + TEST 2 */
/* Solve A*x = b and compute the residual. */
clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
cpttrs_(uplo, &n, &nrhs, &d__[n + 1], &e[n + 1], &x[1], &
lda, &info);
/* Check error code from CPTTRS. */
if (info != 0) {
alaerh_(path, "CPTTRS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
clacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &lda);
cptt02_(uplo, &n, &nrhs, &d__[1], &e[1], &x[1], &lda, &
work[1], &lda, &result[1]);
/* + TEST 3 */
/* Check solution from generated exact solution. */
cget04_(&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, "CPTRFS", (ftnlen)32, (ftnlen)6);
cptrfs_(uplo, &n, &nrhs, &d__[1], &e[1], &d__[n + 1], &e[
n + 1], &b[1], &lda, &x[1], &lda, &rwork[1], &
rwork[nrhs + 1], &work[1], &rwork[(nrhs << 1) + 1]
, &info);
/* Check error code from CPTRFS. */
if (info != 0) {
alaerh_(path, "CPTRFS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &nrhs, &imat, &nfail, &nerrs,
nout);
}
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &rcondc, &
result[3]);
cptt05_(&n, &nrhs, &d__[1], &e[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___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, uplo, (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: */
}
/* + TEST 7 */
/* Estimate the reciprocal of the condition number of the */
/* matrix. */
L100:
s_copy(srnamc_1.srnamt, "CPTCON", (ftnlen)32, (ftnlen)6);
cptcon_(&n, &d__[n + 1], &e[n + 1], &anorm, &rcond, &rwork[1], &
info);
/* Check error code from CPTCON. */
if (info != 0) {
alaerh_(path, "CPTCON", &info, &c__0, " ", &n, &n, &c_n1, &
c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[6] = sget06_(&rcond, &rcondc);
/* Print the test ratio if greater than or equal to THRESH. */
if (result[6] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___40.ciunit = *nout;
s_wsfe(&io___40);
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;
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CCHKPT */
} /* cchkpt_ */
int sgst07(trans_t trans, int n, int nrhs, SuperMatrix *A, float *b,
int ldb, float *x, int ldx, float *xact,
int ldxact, float *ferr, float *berr, float *reslts)
{
/*
Purpose
=======
SGST07 tests the error bounds from iterative refinement for the
computed solution to a system of equations op(A)*X = B, where A is a
general n by n matrix and op(A) = A or A**T, depending on TRANS.
RESLTS(1) = test of the error bound
= norm(X - XACT) / ( norm(X) * FERR )
A large value is returned if this ratio is not less than one.
RESLTS(2) = residual from the iterative refinement routine
= the maximum of BERR / ( (n+1)*EPS + (*) ), where
(*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
Arguments
=========
TRANS (input) trans_t
Specifies the form of the system of equations.
= NOTRANS: A *x = b
= TRANS : A'*x = b, where A' is the transpose of A
= CONJ : A'*x = b, where A' is the transpose of A
N (input) INT
The number of rows of the matrices X and XACT. N >= 0.
NRHS (input) INT
The number of columns of the matrices X and XACT. NRHS >= 0.
A (input) SuperMatrix *, dimension (A->nrow, A->ncol)
The original n by n matrix A.
B (input) FLOAT PRECISION array, dimension (LDB,NRHS)
The right hand side vectors for the system of linear
equations.
LDB (input) INT
The leading dimension of the array B. LDB >= max(1,N).
X (input) FLOAT PRECISION array, dimension (LDX,NRHS)
The computed solution vectors. Each vector is stored as a
column of the matrix X.
LDX (input) INT
The leading dimension of the array X. LDX >= max(1,N).
XACT (input) FLOAT PRECISION array, dimension (LDX,NRHS)
The exact solution vectors. Each vector is stored as a
column of the matrix XACT.
LDXACT (input) INT
The leading dimension of the array XACT. LDXACT >= max(1,N).
FERR (input) FLOAT PRECISION array, dimension (NRHS)
The estimated forward error bounds for each solution vector
X. If XTRUE is the true solution, FERR bounds the magnitude
of the largest entry in (X - XTRUE) divided by the magnitude
of the largest entry in X.
BERR (input) FLOAT PRECISION array, dimension (NRHS)
The componentwise relative backward error of each solution
vector (i.e., the smallest relative change in any entry of A
or B that makes X an exact solution).
RESLTS (output) FLOAT PRECISION array, dimension (2)
The maximum over the NRHS solution vectors of the ratios:
RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
=====================================================================
*/
/* Table of constant values */
int c__1 = 1;
/* System generated locals */
float d__1, d__2;
/* Local variables */
float diff, axbi;
int imax, irow, n__1;
int i, j, k;
float unfl, ovfl;
float xnorm;
float errbnd;
int notran;
float eps, tmp;
float *rwork;
float *Aval;
NCformat *Astore;
/* Function prototypes */
extern int lsame_(char *, char *);
extern int isamax_(int *, float *, int *);
/* Quick exit if N = 0 or NRHS = 0. */
if ( n <= 0 || nrhs <= 0 ) {
reslts[0] = 0.;
reslts[1] = 0.;
return 0;
}
eps = slamch_("Epsilon");
unfl = slamch_("Safe minimum");
ovfl = 1. / unfl;
notran = (trans == NOTRANS);
rwork = (float *) SUPERLU_MALLOC(n*sizeof(float));
if ( !rwork ) ABORT("SUPERLU_MALLOC fails for rwork");
Astore = A->Store;
Aval = (float *) Astore->nzval;
/* Test 1: Compute the maximum of
norm(X - XACT) / ( norm(X) * FERR )
over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.;
for (j = 0; j < nrhs; ++j) {
n__1 = n;
imax = isamax_(&n__1, &x[j*ldx], &c__1);
d__1 = fabs(x[imax-1 + j*ldx]);
xnorm = SUPERLU_MAX(d__1,unfl);
diff = 0.;
for (i = 0; i < n; ++i) {
d__1 = fabs(x[i+j*ldx] - xact[i+j*ldxact]);
diff = SUPERLU_MAX(diff, d__1);
}
if (xnorm > 1.) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1. / eps;
goto L30;
}
L20:
#if 0
if (diff / xnorm <= ferr[j]) {
d__1 = diff / xnorm / ferr[j];
errbnd = SUPERLU_MAX(errbnd,d__1);
} else {
errbnd = 1. / eps;
}
#endif
d__1 = diff / xnorm / ferr[j];
errbnd = SUPERLU_MAX(errbnd,d__1);
/*printf("Ferr: %f\n", errbnd);*/
L30:
;
}
reslts[0] = errbnd;
/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
(*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) + abs(b))_i ) */
for (k = 0; k < nrhs; ++k) {
for (i = 0; i < n; ++i)
rwork[i] = fabs( b[i + k*ldb] );
if ( notran ) {
for (j = 0; j < n; ++j) {
tmp = fabs( x[j + k*ldx] );
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
rwork[Astore->rowind[i]] += fabs(Aval[i]) * tmp;
}
}
} else {
for (j = 0; j < n; ++j) {
tmp = 0.;
for (i = Astore->colptr[j]; i < Astore->colptr[j+1]; ++i) {
irow = Astore->rowind[i];
d__1 = fabs( x[irow + k*ldx] );
tmp += fabs(Aval[i]) * d__1;
}
rwork[j] += tmp;
}
}
axbi = rwork[0];
for (i = 1; i < n; ++i) axbi = SUPERLU_MIN(axbi, rwork[i]);
/* Computing MAX */
d__1 = axbi, d__2 = (n + 1) * unfl;
tmp = berr[k] / ((n + 1) * eps + (n + 1) * unfl / SUPERLU_MAX(d__1,d__2));
if (k == 0) {
reslts[1] = tmp;
} else {
reslts[1] = SUPERLU_MAX(reslts[1],tmp);
}
}
SUPERLU_FREE(rwork);
return 0;
} /* sgst07 */
/* Subroutine */ int slaed2_(integer *k, integer *n, integer *n1, real *d__,
real *q, integer *ldq, integer *indxq, real *rho, real *z__, real *
dlamda, real *w, real *q2, integer *indx, integer *indxc, integer *
indxp, integer *coltyp, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, i__1, i__2;
real r__1, r__2, r__3, r__4;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real c__;
integer i__, j;
real s, t;
integer k2, n2, ct, nj, pj, js, iq1, iq2, n1p1;
real eps, tau, tol;
integer psm[4], imax, jmax, ctot[4];
extern /* Subroutine */ int srot_(integer *, real *, integer *, real *,
integer *, real *, real *), sscal_(integer *, real *, real *,
integer *), scopy_(integer *, real *, integer *, real *, integer *
);
extern doublereal slapy2_(real *, real *), slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slamrg_(integer *, integer *, real *, integer
*, integer *, integer *), slacpy_(char *, integer *, integer *,
real *, integer *, real *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAED2 merges the two sets of eigenvalues together into a single */
/* sorted set. Then it tries to deflate the size of the problem. */
/* There are two ways in which deflation can occur: when two or more */
/* eigenvalues are close together or if there is a tiny entry in the */
/* Z vector. For each such occurrence the order of the related secular */
/* equation problem is reduced by one. */
/* Arguments */
/* ========= */
/* K (output) INTEGER */
/* The number of non-deflated eigenvalues, and the order of the */
/* related secular equation. 0 <= K <=N. */
/* N (input) INTEGER */
/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
/* N1 (input) INTEGER */
/* The location of the last eigenvalue in the leading sub-matrix. */
/* min(1,N) <= N1 <= N/2. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, D contains the eigenvalues of the two submatrices to */
/* be combined. */
/* On exit, D contains the trailing (N-K) updated eigenvalues */
/* (those which were deflated) sorted into increasing order. */
/* Q (input/output) REAL array, dimension (LDQ, N) */
/* On entry, Q contains the eigenvectors of two submatrices in */
/* the two square blocks with corners at (1,1), (N1,N1) */
/* and (N1+1, N1+1), (N,N). */
/* On exit, Q contains the trailing (N-K) updated eigenvectors */
/* (those which were deflated) in its last N-K columns. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max(1,N). */
/* INDXQ (input/output) INTEGER array, dimension (N) */
/* The permutation which separately sorts the two sub-problems */
/* in D into ascending order. Note that elements in the second */
/* half of this permutation must first have N1 added to their */
/* values. Destroyed on exit. */
/* RHO (input/output) REAL */
/* On entry, the off-diagonal element associated with the rank-1 */
/* cut which originally split the two submatrices which are now */
/* being recombined. */
/* On exit, RHO has been modified to the value required by */
/* SLAED3. */
/* Z (input) REAL array, dimension (N) */
/* On entry, Z contains the updating vector (the last */
/* row of the first sub-eigenvector matrix and the first row of */
/* the second sub-eigenvector matrix). */
/* On exit, the contents of Z have been destroyed by the updating */
/* process. */
/* DLAMDA (output) REAL array, dimension (N) */
/* A copy of the first K eigenvalues which will be used by */
/* SLAED3 to form the secular equation. */
/* W (output) REAL array, dimension (N) */
/* The first k values of the final deflation-altered z-vector */
/* which will be passed to SLAED3. */
/* Q2 (output) REAL array, dimension (N1**2+(N-N1)**2) */
/* A copy of the first K eigenvectors which will be used by */
/* SLAED3 in a matrix multiply (SGEMM) to solve for the new */
/* eigenvectors. */
/* INDX (workspace) INTEGER array, dimension (N) */
/* The permutation used to sort the contents of DLAMDA into */
/* ascending order. */
/* INDXC (output) INTEGER array, dimension (N) */
/* The permutation used to arrange the columns of the deflated */
/* Q matrix into three groups: the first group contains non-zero */
/* elements only at and above N1, the second contains */
/* non-zero elements only below N1, and the third is dense. */
/* INDXP (workspace) INTEGER array, dimension (N) */
/* The permutation used to place deflated values of D at the end */
/* of the array. INDXP(1:K) points to the nondeflated D-values */
/* and INDXP(K+1:N) points to the deflated eigenvalues. */
/* COLTYP (workspace/output) INTEGER array, dimension (N) */
/* During execution, a label which will indicate which of the */
/* following types a column in the Q2 matrix is: */
/* 1 : non-zero in the upper half only; */
/* 2 : dense; */
/* 3 : non-zero in the lower half only; */
/* 4 : deflated. */
/* On exit, COLTYP(i) is the number of columns of type i, */
/* for i=1 to 4 only. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Jeff Rutter, Computer Science Division, University of California */
/* at Berkeley, USA */
/* Modified by Francoise Tisseur, University of Tennessee. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--indxq;
--z__;
--dlamda;
--w;
--q2;
--indx;
--indxc;
--indxp;
--coltyp;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -2;
} else if (*ldq < max(1,*n)) {
*info = -6;
} else { /* if(complicated condition) */
/* Computing MIN */
i__1 = 1, i__2 = *n / 2;
if (min(i__1,i__2) > *n1 || *n / 2 < *n1) {
*info = -3;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLAED2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
n2 = *n - *n1;
n1p1 = *n1 + 1;
if (*rho < 0.f) {
sscal_(&n2, &c_b3, &z__[n1p1], &c__1);
}
/* Normalize z so that norm(z) = 1. Since z is the concatenation of */
/* two normalized vectors, norm2(z) = sqrt(2). */
t = 1.f / sqrt(2.f);
sscal_(n, &t, &z__[1], &c__1);
/* RHO = ABS( norm(z)**2 * RHO ) */
*rho = (r__1 = *rho * 2.f, dabs(r__1));
/* Sort the eigenvalues into increasing order */
i__1 = *n;
for (i__ = n1p1; i__ <= i__1; ++i__) {
indxq[i__] += *n1;
/* L10: */
}
/* re-integrate the deflated parts from the last pass */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = d__[indxq[i__]];
/* L20: */
}
slamrg_(n1, &n2, &dlamda[1], &c__1, &c__1, &indxc[1]);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
indx[i__] = indxq[indxc[i__]];
/* L30: */
}
/* Calculate the allowable deflation tolerance */
imax = isamax_(n, &z__[1], &c__1);
jmax = isamax_(n, &d__[1], &c__1);
eps = slamch_("Epsilon");
/* Computing MAX */
r__3 = (r__1 = d__[jmax], dabs(r__1)), r__4 = (r__2 = z__[imax], dabs(
r__2));
tol = eps * 8.f * dmax(r__3,r__4);
/* If the rank-1 modifier is small enough, no more needs to be done */
/* except to reorganize Q so that its columns correspond with the */
/* elements in D. */
if (*rho * (r__1 = z__[imax], dabs(r__1)) <= tol) {
*k = 0;
iq2 = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__ = indx[j];
scopy_(n, &q[i__ * q_dim1 + 1], &c__1, &q2[iq2], &c__1);
dlamda[j] = d__[i__];
iq2 += *n;
/* L40: */
}
slacpy_("A", n, n, &q2[1], n, &q[q_offset], ldq);
scopy_(n, &dlamda[1], &c__1, &d__[1], &c__1);
goto L190;
}
/* If there are multiple eigenvalues then the problem deflates. Here */
/* the number of equal eigenvalues are found. As each equal */
/* eigenvalue is found, an elementary reflector is computed to rotate */
/* the corresponding eigensubspace so that the corresponding */
/* components of Z are zero in this new basis. */
i__1 = *n1;
for (i__ = 1; i__ <= i__1; ++i__) {
coltyp[i__] = 1;
/* L50: */
}
i__1 = *n;
for (i__ = n1p1; i__ <= i__1; ++i__) {
coltyp[i__] = 3;
/* L60: */
}
*k = 0;
k2 = *n + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
nj = indx[j];
if (*rho * (r__1 = z__[nj], dabs(r__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
coltyp[nj] = 4;
indxp[k2] = nj;
if (j == *n) {
goto L100;
}
} else {
pj = nj;
goto L80;
}
/* L70: */
}
L80:
++j;
nj = indx[j];
if (j > *n) {
goto L100;
}
if (*rho * (r__1 = z__[nj], dabs(r__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
coltyp[nj] = 4;
indxp[k2] = nj;
} else {
/* Check if eigenvalues are close enough to allow deflation. */
s = z__[pj];
c__ = z__[nj];
/* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */
tau = slapy2_(&c__, &s);
t = d__[nj] - d__[pj];
c__ /= tau;
s = -s / tau;
if ((r__1 = t * c__ * s, dabs(r__1)) <= tol) {
/* Deflation is possible. */
z__[nj] = tau;
z__[pj] = 0.f;
if (coltyp[nj] != coltyp[pj]) {
coltyp[nj] = 2;
}
coltyp[pj] = 4;
srot_(n, &q[pj * q_dim1 + 1], &c__1, &q[nj * q_dim1 + 1], &c__1, &
c__, &s);
/* Computing 2nd power */
r__1 = c__;
/* Computing 2nd power */
r__2 = s;
t = d__[pj] * (r__1 * r__1) + d__[nj] * (r__2 * r__2);
/* Computing 2nd power */
r__1 = s;
/* Computing 2nd power */
r__2 = c__;
d__[nj] = d__[pj] * (r__1 * r__1) + d__[nj] * (r__2 * r__2);
d__[pj] = t;
--k2;
i__ = 1;
L90:
if (k2 + i__ <= *n) {
if (d__[pj] < d__[indxp[k2 + i__]]) {
indxp[k2 + i__ - 1] = indxp[k2 + i__];
indxp[k2 + i__] = pj;
++i__;
goto L90;
} else {
indxp[k2 + i__ - 1] = pj;
}
} else {
indxp[k2 + i__ - 1] = pj;
}
pj = nj;
} else {
++(*k);
dlamda[*k] = d__[pj];
w[*k] = z__[pj];
indxp[*k] = pj;
pj = nj;
}
}
goto L80;
L100:
/* Record the last eigenvalue. */
++(*k);
dlamda[*k] = d__[pj];
w[*k] = z__[pj];
indxp[*k] = pj;
/* Count up the total number of the various types of columns, then */
/* form a permutation which positions the four column types into */
/* four uniform groups (although one or more of these groups may be */
/* empty). */
for (j = 1; j <= 4; ++j) {
ctot[j - 1] = 0;
/* L110: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
ct = coltyp[j];
++ctot[ct - 1];
/* L120: */
}
/* PSM(*) = Position in SubMatrix (of types 1 through 4) */
psm[0] = 1;
psm[1] = ctot[0] + 1;
psm[2] = psm[1] + ctot[1];
psm[3] = psm[2] + ctot[2];
*k = *n - ctot[3];
/* Fill out the INDXC array so that the permutation which it induces */
/* will place all type-1 columns first, all type-2 columns next, */
/* then all type-3's, and finally all type-4's. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
js = indxp[j];
ct = coltyp[js];
indx[psm[ct - 1]] = js;
indxc[psm[ct - 1]] = j;
++psm[ct - 1];
/* L130: */
}
/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */
/* and Q2 respectively. The eigenvalues/vectors which were not */
/* deflated go into the first K slots of DLAMDA and Q2 respectively, */
/* while those which were deflated go into the last N - K slots. */
i__ = 1;
iq1 = 1;
iq2 = (ctot[0] + ctot[1]) * *n1 + 1;
i__1 = ctot[0];
for (j = 1; j <= i__1; ++j) {
js = indx[i__];
scopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1);
z__[i__] = d__[js];
++i__;
iq1 += *n1;
/* L140: */
}
i__1 = ctot[1];
for (j = 1; j <= i__1; ++j) {
js = indx[i__];
scopy_(n1, &q[js * q_dim1 + 1], &c__1, &q2[iq1], &c__1);
scopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1);
z__[i__] = d__[js];
++i__;
iq1 += *n1;
iq2 += n2;
/* L150: */
}
i__1 = ctot[2];
for (j = 1; j <= i__1; ++j) {
js = indx[i__];
scopy_(&n2, &q[*n1 + 1 + js * q_dim1], &c__1, &q2[iq2], &c__1);
z__[i__] = d__[js];
++i__;
iq2 += n2;
/* L160: */
}
iq1 = iq2;
i__1 = ctot[3];
for (j = 1; j <= i__1; ++j) {
js = indx[i__];
scopy_(n, &q[js * q_dim1 + 1], &c__1, &q2[iq2], &c__1);
iq2 += *n;
z__[i__] = d__[js];
++i__;
/* L170: */
}
/* The deflated eigenvalues and their corresponding vectors go back */
/* into the last N - K slots of D and Q respectively. */
slacpy_("A", n, &ctot[3], &q2[iq1], n, &q[(*k + 1) * q_dim1 + 1], ldq);
i__1 = *n - *k;
scopy_(&i__1, &z__[*k + 1], &c__1, &d__[*k + 1], &c__1);
/* Copy CTOT into COLTYP for referencing in SLAED3. */
for (j = 1; j <= 4; ++j) {
coltyp[j] = ctot[j - 1];
/* L180: */
}
L190:
return 0;
/* End of SLAED2 */
} /* slaed2_ */
/* Subroutine */ int stpt03_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, real *ap, real *scale, real *cnorm, real *tscal, real *
x, integer *ldx, real *b, integer *ldb, real *work, real *resid)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2, r__3;
/* Local variables */
integer j, jj, ix;
real eps, err;
real xscal;
real tnorm, xnorm;
real bignum;
real smlnum;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STPT03 computes the residual for the solution to a scaled triangular */
/* system of equations A*x = s*b or A'*x = s*b when the triangular */
/* matrix A is stored in packed format. Here A' is the transpose of A, */
/* s is a scalar, and x and b are N by NRHS matrices. The test ratio is */
/* the maximum over the number of right hand sides of */
/* norm(s*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 = s*b (No transpose) */
/* = 'T': A'*x = s*b (Transpose) */
/* = 'C': 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 */
/* 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. */
/* 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((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', */
/* AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
/* SCALE (input) REAL */
/* The scaling factor s used in solving the triangular system. */
/* CNORM (input) REAL array, dimension (N) */
/* The 1-norms of the columns of A, not counting the diagonal. */
/* TSCAL (input) REAL */
/* The scaling factor used in computing the 1-norms in CNORM. */
/* CNORM actually contains the column norms of TSCAL*A. */
/* 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 - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
--ap;
--cnorm;
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;
}
eps = slamch_("Epsilon");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Compute the norm of the triangular matrix A using the column */
/* norms already computed by SLATPS. */
tnorm = 0.f;
if (lsame_(diag, "N")) {
if (lsame_(uplo, "U")) {
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__2 = tnorm, r__3 = *tscal * (r__1 = ap[jj], dabs(r__1)) +
cnorm[j];
tnorm = dmax(r__2,r__3);
jj = jj + j + 1;
/* L10: */
}
} else {
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__2 = tnorm, r__3 = *tscal * (r__1 = ap[jj], dabs(r__1)) +
cnorm[j];
tnorm = dmax(r__2,r__3);
jj = jj + *n - j + 1;
/* L20: */
}
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = tnorm, r__2 = *tscal + cnorm[j];
tnorm = dmax(r__1,r__2);
/* L30: */
}
}
/* Compute the maximum over the number of right hand sides of */
/* norm(op(A)*x - s*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);
ix = isamax_(n, &work[1], &c__1);
/* Computing MAX */
r__2 = 1.f, r__3 = (r__1 = x[ix + j * x_dim1], dabs(r__1));
xnorm = dmax(r__2,r__3);
xscal = 1.f / xnorm / (real) (*n);
sscal_(n, &xscal, &work[1], &c__1);
stpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
r__1 = -(*scale) * xscal;
saxpy_(n, &r__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
ix = isamax_(n, &work[1], &c__1);
err = *tscal * (r__1 = work[ix], dabs(r__1));
ix = isamax_(n, &x[j * x_dim1 + 1], &c__1);
xnorm = (r__1 = x[ix + j * x_dim1], dabs(r__1));
if (err * smlnum <= xnorm) {
if (xnorm > 0.f) {
err /= xnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
if (err * smlnum <= tnorm) {
if (tnorm > 0.f) {
err /= tnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
*resid = dmax(*resid,err);
/* L40: */
}
return 0;
/* End of STPT03 */
} /* stpt03_ */
/* Subroutine */ int sgecon_(char *norm, integer *n, real *a, integer *lda,
real *anorm, real *rcond, real *work, integer *iwork, integer *info)
{
/* -- LAPACK 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
=======
SGECON estimates the reciprocal of the condition number of a general
real matrix A, in either the 1-norm or the infinity-norm, using
the LU factorization computed by SGETRF.
An estimate is obtained for norm(inv(A)), and the reciprocal of the
condition number is computed as
RCOND = 1 / ( norm(A) * norm(inv(A)) ).
Arguments
=========
NORM (input) CHARACTER*1
Specifies whether the 1-norm condition number or the
infinity-norm condition number is required:
= '1' or 'O': 1-norm;
= 'I': Infinity-norm.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input) REAL array, dimension (LDA,N)
The factors L and U from the factorization A = P*L*U
as computed by SGETRF.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
ANORM (input) REAL
If NORM = '1' or 'O', the 1-norm of the original matrix A.
If NORM = 'I', the infinity-norm of the original matrix A.
RCOND (output) REAL
The reciprocal of the condition number of the matrix A,
computed as RCOND = 1/(norm(A) * norm(inv(A))).
WORK (workspace) REAL array, dimension (4*N)
IWORK (workspace) INTEGER array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1;
/* Local variables */
static integer kase, kase1;
static real scale;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
static real sl;
static integer ix;
extern doublereal slamch_(char *);
static real su;
extern /* Subroutine */ int xerbla_(char *, integer *), slacon_(
integer *, real *, real *, integer *, real *, integer *);
extern integer isamax_(integer *, real *, integer *);
static real ainvnm;
static logical onenrm;
static char normin[1];
extern /* Subroutine */ int slatrs_(char *, char *, char *, char *,
integer *, real *, integer *, real *, real *, real *, integer *);
static real smlnum;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*anorm < 0.f) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SGECON", &i__1);
return 0;
}
/* Quick return if possible */
*rcond = 0.f;
if (*n == 0) {
*rcond = 1.f;
return 0;
} else if (*anorm == 0.f) {
return 0;
}
smlnum = slamch_("Safe minimum");
/* Estimate the norm of inv(A). */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
slacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(L). */
slatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset],
lda, &work[1], &sl, &work[(*n << 1) + 1], info);
/* Multiply by inv(U). */
slatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info);
} else {
/* Multiply by inv(U'). */
slatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset],
lda, &work[1], &su, &work[*n * 3 + 1], info);
/* Multiply by inv(L'). */
slatrs_("Lower", "Transpose", "Unit", normin, n, &a[a_offset],
lda, &work[1], &sl, &work[(*n << 1) + 1], info);
}
/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */
scale = sl * su;
*(unsigned char *)normin = 'Y';
if (scale != 1.f) {
ix = isamax_(n, &work[1], &c__1);
if (scale < (r__1 = work[ix], dabs(r__1)) * smlnum || scale ==
0.f) {
goto L20;
}
srscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / ainvnm / *anorm;
}
L20:
return 0;
/* End of SGECON */
} /* sgecon_ */
/* Subroutine */ int claed8_(integer *k, integer *n, integer *qsiz, complex *
q, integer *ldq, real *d__, real *rho, integer *cutpnt, real *z__,
real *dlamda, complex *q2, integer *ldq2, real *w, integer *indxp,
integer *indx, integer *indxq, integer *perm, integer *givptr,
integer *givcol, real *givnum, integer *info)
{
/* System generated locals */
integer q_dim1, q_offset, q2_dim1, q2_offset, i__1;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real c__;
integer i__, j;
real s, t;
integer k2, n1, n2, jp, n1p1;
real eps, tau, tol;
integer jlam, imax, jmax;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *),
ccopy_(integer *, complex *, integer *, complex *, integer *),
csrot_(integer *, complex *, integer *, complex *, integer *,
real *, real *), scopy_(integer *, real *, integer *, real *,
integer *);
extern doublereal slapy2_(real *, real *), slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), xerbla_(char *,
integer *);
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int slamrg_(integer *, integer *, real *, integer
*, integer *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAED8 merges the two sets of eigenvalues together into a single */
/* sorted set. Then it tries to deflate the size of the problem. */
/* There are two ways in which deflation can occur: when two or more */
/* eigenvalues are close together or if there is a tiny element in the */
/* Z vector. For each such occurrence the order of the related secular */
/* equation problem is reduced by one. */
/* Arguments */
/* ========= */
/* K (output) INTEGER */
/* Contains the number of non-deflated eigenvalues. */
/* This is the order of the related secular equation. */
/* N (input) INTEGER */
/* The dimension of the symmetric tridiagonal matrix. N >= 0. */
/* QSIZ (input) INTEGER */
/* The dimension of the unitary matrix used to reduce */
/* the dense or band matrix to tridiagonal form. */
/* QSIZ >= N if ICOMPQ = 1. */
/* Q (input/output) COMPLEX array, dimension (LDQ,N) */
/* On entry, Q contains the eigenvectors of the partially solved */
/* system which has been previously updated in matrix */
/* multiplies with other partially solved eigensystems. */
/* On exit, Q contains the trailing (N-K) updated eigenvectors */
/* (those which were deflated) in its last N-K columns. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. LDQ >= max( 1, N ). */
/* D (input/output) REAL array, dimension (N) */
/* On entry, D contains the eigenvalues of the two submatrices to */
/* be combined. On exit, D contains the trailing (N-K) updated */
/* eigenvalues (those which were deflated) sorted into increasing */
/* order. */
/* RHO (input/output) REAL */
/* Contains the off diagonal element associated with the rank-1 */
/* cut which originally split the two submatrices which are now */
/* being recombined. RHO is modified during the computation to */
/* the value required by SLAED3. */
/* CUTPNT (input) INTEGER */
/* Contains the location of the last eigenvalue in the leading */
/* sub-matrix. MIN(1,N) <= CUTPNT <= N. */
/* Z (input) REAL array, dimension (N) */
/* On input this vector contains the updating vector (the last */
/* row of the first sub-eigenvector matrix and the first row of */
/* the second sub-eigenvector matrix). The contents of Z are */
/* destroyed during the updating process. */
/* DLAMDA (output) REAL array, dimension (N) */
/* Contains a copy of the first K eigenvalues which will be used */
/* by SLAED3 to form the secular equation. */
/* Q2 (output) COMPLEX array, dimension (LDQ2,N) */
/* If ICOMPQ = 0, Q2 is not referenced. Otherwise, */
/* Contains a copy of the first K eigenvectors which will be used */
/* by SLAED7 in a matrix multiply (SGEMM) to update the new */
/* eigenvectors. */
/* LDQ2 (input) INTEGER */
/* The leading dimension of the array Q2. LDQ2 >= max( 1, N ). */
/* W (output) REAL array, dimension (N) */
/* This will hold the first k values of the final */
/* deflation-altered z-vector and will be passed to SLAED3. */
/* INDXP (workspace) INTEGER array, dimension (N) */
/* This will contain the permutation used to place deflated */
/* values of D at the end of the array. On output INDXP(1:K) */
/* points to the nondeflated D-values and INDXP(K+1:N) */
/* points to the deflated eigenvalues. */
/* INDX (workspace) INTEGER array, dimension (N) */
/* This will contain the permutation used to sort the contents of */
/* D into ascending order. */
/* INDXQ (input) INTEGER array, dimension (N) */
/* This contains the permutation which separately sorts the two */
/* sub-problems in D into ascending order. Note that elements in */
/* the second half of this permutation must first have CUTPNT */
/* added to their values in order to be accurate. */
/* PERM (output) INTEGER array, dimension (N) */
/* Contains the permutations (from deflation and sorting) to be */
/* applied to each eigenblock. */
/* GIVPTR (output) INTEGER */
/* Contains the number of Givens rotations which took place in */
/* this subproblem. */
/* GIVCOL (output) INTEGER array, dimension (2, N) */
/* Each pair of numbers indicates a pair of columns to take place */
/* in a Givens rotation. */
/* GIVNUM (output) REAL array, dimension (2, N) */
/* Each number indicates the S value to be used in the */
/* corresponding Givens rotation. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--d__;
--z__;
--dlamda;
q2_dim1 = *ldq2;
q2_offset = 1 + q2_dim1;
q2 -= q2_offset;
--w;
--indxp;
--indx;
--indxq;
--perm;
givcol -= 3;
givnum -= 3;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -2;
} else if (*qsiz < *n) {
*info = -3;
} else if (*ldq < max(1,*n)) {
*info = -5;
} else if (*cutpnt < min(1,*n) || *cutpnt > *n) {
*info = -8;
} else if (*ldq2 < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLAED8", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
n1 = *cutpnt;
n2 = *n - n1;
n1p1 = n1 + 1;
if (*rho < 0.f) {
sscal_(&n2, &c_b3, &z__[n1p1], &c__1);
}
/* Normalize z so that norm(z) = 1 */
t = 1.f / sqrt(2.f);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
indx[j] = j;
/* L10: */
}
sscal_(n, &t, &z__[1], &c__1);
*rho = (r__1 = *rho * 2.f, dabs(r__1));
/* Sort the eigenvalues into increasing order */
i__1 = *n;
for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) {
indxq[i__] += *cutpnt;
/* L20: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
dlamda[i__] = d__[indxq[i__]];
w[i__] = z__[indxq[i__]];
/* L30: */
}
i__ = 1;
j = *cutpnt + 1;
slamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = dlamda[indx[i__]];
z__[i__] = w[indx[i__]];
/* L40: */
}
/* Calculate the allowable deflation tolerance */
imax = isamax_(n, &z__[1], &c__1);
jmax = isamax_(n, &d__[1], &c__1);
eps = slamch_("Epsilon");
tol = eps * 8.f * (r__1 = d__[jmax], dabs(r__1));
/* If the rank-1 modifier is small enough, no more needs to be done */
/* -- except to reorganize Q so that its columns correspond with the */
/* elements in D. */
if (*rho * (r__1 = z__[imax], dabs(r__1)) <= tol) {
*k = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
perm[j] = indxq[indx[j]];
ccopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1]
, &c__1);
/* L50: */
}
clacpy_("A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq);
return 0;
}
/* If there are multiple eigenvalues then the problem deflates. Here */
/* the number of equal eigenvalues are found. As each equal */
/* eigenvalue is found, an elementary reflector is computed to rotate */
/* the corresponding eigensubspace so that the corresponding */
/* components of Z are zero in this new basis. */
*k = 0;
*givptr = 0;
k2 = *n + 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (*rho * (r__1 = z__[j], dabs(r__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
indxp[k2] = j;
if (j == *n) {
goto L100;
}
} else {
jlam = j;
goto L70;
}
/* L60: */
}
L70:
++j;
if (j > *n) {
goto L90;
}
if (*rho * (r__1 = z__[j], dabs(r__1)) <= tol) {
/* Deflate due to small z component. */
--k2;
indxp[k2] = j;
} else {
/* Check if eigenvalues are close enough to allow deflation. */
s = z__[jlam];
c__ = z__[j];
/* Find sqrt(a**2+b**2) without overflow or */
/* destructive underflow. */
tau = slapy2_(&c__, &s);
t = d__[j] - d__[jlam];
c__ /= tau;
s = -s / tau;
if ((r__1 = t * c__ * s, dabs(r__1)) <= tol) {
/* Deflation is possible. */
z__[j] = tau;
z__[jlam] = 0.f;
/* Record the appropriate Givens rotation */
++(*givptr);
givcol[(*givptr << 1) + 1] = indxq[indx[jlam]];
givcol[(*givptr << 1) + 2] = indxq[indx[j]];
givnum[(*givptr << 1) + 1] = c__;
givnum[(*givptr << 1) + 2] = s;
csrot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[indxq[
indx[j]] * q_dim1 + 1], &c__1, &c__, &s);
t = d__[jlam] * c__ * c__ + d__[j] * s * s;
d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__;
d__[jlam] = t;
--k2;
i__ = 1;
L80:
if (k2 + i__ <= *n) {
if (d__[jlam] < d__[indxp[k2 + i__]]) {
indxp[k2 + i__ - 1] = indxp[k2 + i__];
indxp[k2 + i__] = jlam;
++i__;
goto L80;
} else {
indxp[k2 + i__ - 1] = jlam;
}
} else {
indxp[k2 + i__ - 1] = jlam;
}
jlam = j;
} else {
++(*k);
w[*k] = z__[jlam];
dlamda[*k] = d__[jlam];
indxp[*k] = jlam;
jlam = j;
}
}
goto L70;
L90:
/* Record the last eigenvalue. */
++(*k);
w[*k] = z__[jlam];
dlamda[*k] = d__[jlam];
indxp[*k] = jlam;
L100:
/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */
/* and Q2 respectively. The eigenvalues/vectors which were not */
/* deflated go into the first K slots of DLAMDA and Q2 respectively, */
/* while those which were deflated go into the last N - K slots. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jp = indxp[j];
dlamda[j] = d__[jp];
perm[j] = indxq[indx[jp]];
ccopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1], &
c__1);
/* L110: */
}
/* The deflated eigenvalues and their corresponding vectors go back */
/* into the last N - K slots of D and Q respectively. */
if (*k < *n) {
i__1 = *n - *k;
scopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1);
i__1 = *n - *k;
clacpy_("A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*k +
1) * q_dim1 + 1], ldq);
}
return 0;
/* End of CLAED8 */
} /* claed8_ */
/* 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 */
}
/* 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 isamax( int n, float *x, int incx)
{
return isamax_(&n, x, &incx);
}
/* Subroutine */ int stbt03_(char *uplo, char *trans, char *diag, integer *n,
integer *kd, integer *nrhs, real *ab, integer *ldab, real *scale,
real *cnorm, real *tscal, real *x, integer *ldx, real *b, integer *
ldb, real *work, real *resid)
{
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2, r__3;
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real xscal;
extern /* Subroutine */ int stbmv_(char *, char *, char *, integer *,
integer *, real *, integer *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *);
static real tnorm, xnorm;
extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *,
real *, integer *), slabad_(real *, real *);
static integer ix;
extern doublereal slamch_(char *);
static real bignum;
extern integer isamax_(integer *, real *, integer *);
static real smlnum, eps, err;
#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]
#define ab_ref(a_1,a_2) ab[(a_2)*ab_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
=======
STBT03 computes the residual for the solution to a scaled triangular
system of equations A*x = s*b or A'*x = s*b when A is a
triangular band matrix. Here A' is the transpose of A, s is a scalar,
and x and b are N by NRHS matrices. The test ratio is the maximum
over the number of right hand sides of
norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
where op(A) denotes A or A' and EPS is the machine epsilon.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
TRANS (input) CHARACTER*1
Specifies the operation applied to A.
= 'N': A *x = b (No transpose)
= 'T': A'*x = b (Transpose)
= 'C': A'*x = b (Conjugate transpose = Transpose)
DIAG (input) CHARACTER*1
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
KD (input) INTEGER
The number of superdiagonals or subdiagonals of the
triangular band matrix A. KD >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices X and B. NRHS >= 0.
AB (input) 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.
SCALE (input) REAL
The scaling factor s used in solving the triangular system.
CNORM (input) REAL array, dimension (N)
The 1-norms of the columns of A, not counting the diagonal.
TSCAL (input) REAL
The scaling factor used in computing the 1-norms in CNORM.
CNORM actually contains the column norms of TSCAL*A.
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 - s*b) / ( norm(op(A)) * norm(x) * EPS ).
=====================================================================
Quick exit if N = 0
Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--cnorm;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--work;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
eps = slamch_("Epsilon");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Compute the norm of the triangular matrix A using the column
norms already computed by SLATBS. */
tnorm = 0.f;
if (lsame_(diag, "N")) {
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__2 = tnorm, r__3 = *tscal * (r__1 = ab_ref(*kd + 1, j),
dabs(r__1)) + cnorm[j];
tnorm = dmax(r__2,r__3);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__2 = tnorm, r__3 = *tscal * (r__1 = ab_ref(1, j), dabs(r__1)
) + cnorm[j];
tnorm = dmax(r__2,r__3);
/* L20: */
}
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = tnorm, r__2 = *tscal + cnorm[j];
tnorm = dmax(r__1,r__2);
/* L30: */
}
}
/* Compute the maximum over the number of right hand sides of
norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
scopy_(n, &x_ref(1, j), &c__1, &work[1], &c__1);
ix = isamax_(n, &work[1], &c__1);
/* Computing MAX */
r__2 = 1.f, r__3 = (r__1 = x_ref(ix, j), dabs(r__1));
xnorm = dmax(r__2,r__3);
xscal = 1.f / xnorm / (real) (*kd + 1);
sscal_(n, &xscal, &work[1], &c__1);
stbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[1], &
c__1);
r__1 = -(*scale) * xscal;
saxpy_(n, &r__1, &b_ref(1, j), &c__1, &work[1], &c__1);
ix = isamax_(n, &work[1], &c__1);
err = *tscal * (r__1 = work[ix], dabs(r__1));
ix = isamax_(n, &x_ref(1, j), &c__1);
xnorm = (r__1 = x_ref(ix, j), dabs(r__1));
if (err * smlnum <= xnorm) {
if (xnorm > 0.f) {
err /= xnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
if (err * smlnum <= tnorm) {
if (tnorm > 0.f) {
err /= tnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
*resid = dmax(*resid,err);
/* L40: */
}
return 0;
/* End of STBT03 */
} /* stbt03_ */
/* Subroutine */ int slasy2_(logical *ltranl, logical *ltranr, integer *isgn,
integer *n1, integer *n2, real *tl, integer *ldtl, real *tr, integer *
ldtr, real *b, integer *ldb, real *scale, real *x, integer *ldx, real
*xnorm, integer *info)
{
/* Initialized data */
static integer locu12[4] = { 3,4,1,2 };
static integer locl21[4] = { 2,1,4,3 };
static integer locu22[4] = { 4,3,2,1 };
static logical xswpiv[4] = { FALSE_,FALSE_,TRUE_,TRUE_ };
static logical bswpiv[4] = { FALSE_,TRUE_,FALSE_,TRUE_ };
/* System generated locals */
integer b_dim1, b_offset, tl_dim1, tl_offset, tr_dim1, tr_offset, x_dim1,
x_offset;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8;
/* Local variables */
integer i__, j, k;
real x2[2], l21, u11, u12;
integer ip, jp;
real u22, t16[16] /* was [4][4] */, gam, bet, eps, sgn, tmp[4], tau1,
btmp[4], smin;
integer ipiv;
real temp;
integer jpiv[4];
real xmax;
integer ipsv, jpsv;
logical bswap;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), sswap_(integer *, real *, integer *, real *, integer *
);
logical xswap;
extern doublereal slamch_(char *);
extern integer isamax_(integer *, real *, integer *);
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 */
/* ======= */
/* SLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in */
/* op(TL)*X + ISGN*X*op(TR) = SCALE*B, */
/* where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or */
/* -1. op(T) = T or T', where T' denotes the transpose of T. */
/* Arguments */
/* ========= */
/* LTRANL (input) LOGICAL */
/* On entry, LTRANL specifies the op(TL): */
/* = .FALSE., op(TL) = TL, */
/* = .TRUE., op(TL) = TL'. */
/* LTRANR (input) LOGICAL */
/* On entry, LTRANR specifies the op(TR): */
/* = .FALSE., op(TR) = TR, */
/* = .TRUE., op(TR) = TR'. */
/* ISGN (input) INTEGER */
/* On entry, ISGN specifies the sign of the equation */
/* as described before. ISGN may only be 1 or -1. */
/* N1 (input) INTEGER */
/* On entry, N1 specifies the order of matrix TL. */
/* N1 may only be 0, 1 or 2. */
/* N2 (input) INTEGER */
/* On entry, N2 specifies the order of matrix TR. */
/* N2 may only be 0, 1 or 2. */
/* TL (input) REAL array, dimension (LDTL,2) */
/* On entry, TL contains an N1 by N1 matrix. */
/* LDTL (input) INTEGER */
/* The leading dimension of the matrix TL. LDTL >= max(1,N1). */
/* TR (input) REAL array, dimension (LDTR,2) */
/* On entry, TR contains an N2 by N2 matrix. */
/* LDTR (input) INTEGER */
/* The leading dimension of the matrix TR. LDTR >= max(1,N2). */
/* B (input) REAL array, dimension (LDB,2) */
/* On entry, the N1 by N2 matrix B contains the right-hand */
/* side of the equation. */
/* LDB (input) INTEGER */
/* The leading dimension of the matrix B. LDB >= max(1,N1). */
/* SCALE (output) REAL */
/* On exit, SCALE contains the scale factor. SCALE is chosen */
/* less than or equal to 1 to prevent the solution overflowing. */
/* X (output) REAL array, dimension (LDX,2) */
/* On exit, X contains the N1 by N2 solution. */
/* LDX (input) INTEGER */
/* The leading dimension of the matrix X. LDX >= max(1,N1). */
/* XNORM (output) REAL */
/* On exit, XNORM is the infinity-norm of the solution. */
/* INFO (output) INTEGER */
/* On exit, INFO is set to */
/* 0: successful exit. */
/* 1: TL and TR have too close eigenvalues, so TL or */
/* TR is perturbed to get a nonsingular equation. */
/* 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 .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
tl_dim1 = *ldtl;
tl_offset = 1 + tl_dim1;
tl -= tl_offset;
tr_dim1 = *ldtr;
tr_offset = 1 + tr_dim1;
tr -= tr_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Do not check the input parameters for errors */
*info = 0;
/* Quick return if possible */
if (*n1 == 0 || *n2 == 0) {
return 0;
}
/* Set constants to control overflow */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
sgn = (real) (*isgn);
k = *n1 + *n1 + *n2 - 2;
switch (k) {
case 1: goto L10;
case 2: goto L20;
case 3: goto L30;
case 4: goto L50;
}
/* 1 by 1: TL11*X + SGN*X*TR11 = B11 */
L10:
tau1 = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1];
bet = dabs(tau1);
if (bet <= smlnum) {
tau1 = smlnum;
bet = smlnum;
*info = 1;
}
*scale = 1.f;
gam = (r__1 = b[b_dim1 + 1], dabs(r__1));
if (smlnum * gam > bet) {
*scale = 1.f / gam;
}
x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / tau1;
*xnorm = (r__1 = x[x_dim1 + 1], dabs(r__1));
return 0;
/* 1 by 2: */
/* TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] */
/* [TR21 TR22] */
L20:
/* Computing MAX */
/* Computing MAX */
r__7 = (r__1 = tl[tl_dim1 + 1], dabs(r__1)), r__8 = (r__2 = tr[tr_dim1 +
1], dabs(r__2)), r__7 = max(r__7,r__8), r__8 = (r__3 = tr[(
tr_dim1 << 1) + 1], dabs(r__3)), r__7 = max(r__7,r__8), r__8 = (
r__4 = tr[tr_dim1 + 2], dabs(r__4)), r__7 = max(r__7,r__8), r__8 =
(r__5 = tr[(tr_dim1 << 1) + 2], dabs(r__5));
r__6 = eps * dmax(r__7,r__8);
smin = dmax(r__6,smlnum);
tmp[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1];
tmp[3] = tl[tl_dim1 + 1] + sgn * tr[(tr_dim1 << 1) + 2];
if (*ltranr) {
tmp[1] = sgn * tr[tr_dim1 + 2];
tmp[2] = sgn * tr[(tr_dim1 << 1) + 1];
} else {
tmp[1] = sgn * tr[(tr_dim1 << 1) + 1];
tmp[2] = sgn * tr[tr_dim1 + 2];
}
btmp[0] = b[b_dim1 + 1];
btmp[1] = b[(b_dim1 << 1) + 1];
goto L40;
/* 2 by 1: */
/* op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] */
/* [TL21 TL22] [X21] [X21] [B21] */
L30:
/* Computing MAX */
/* Computing MAX */
r__7 = (r__1 = tr[tr_dim1 + 1], dabs(r__1)), r__8 = (r__2 = tl[tl_dim1 +
1], dabs(r__2)), r__7 = max(r__7,r__8), r__8 = (r__3 = tl[(
tl_dim1 << 1) + 1], dabs(r__3)), r__7 = max(r__7,r__8), r__8 = (
r__4 = tl[tl_dim1 + 2], dabs(r__4)), r__7 = max(r__7,r__8), r__8 =
(r__5 = tl[(tl_dim1 << 1) + 2], dabs(r__5));
r__6 = eps * dmax(r__7,r__8);
smin = dmax(r__6,smlnum);
tmp[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1];
tmp[3] = tl[(tl_dim1 << 1) + 2] + sgn * tr[tr_dim1 + 1];
if (*ltranl) {
tmp[1] = tl[(tl_dim1 << 1) + 1];
tmp[2] = tl[tl_dim1 + 2];
} else {
tmp[1] = tl[tl_dim1 + 2];
tmp[2] = tl[(tl_dim1 << 1) + 1];
}
btmp[0] = b[b_dim1 + 1];
btmp[1] = b[b_dim1 + 2];
L40:
/* Solve 2 by 2 system using complete pivoting. */
/* Set pivots less than SMIN to SMIN. */
ipiv = isamax_(&c__4, tmp, &c__1);
u11 = tmp[ipiv - 1];
if (dabs(u11) <= smin) {
*info = 1;
u11 = smin;
}
u12 = tmp[locu12[ipiv - 1] - 1];
l21 = tmp[locl21[ipiv - 1] - 1] / u11;
u22 = tmp[locu22[ipiv - 1] - 1] - u12 * l21;
xswap = xswpiv[ipiv - 1];
bswap = bswpiv[ipiv - 1];
if (dabs(u22) <= smin) {
*info = 1;
u22 = smin;
}
if (bswap) {
temp = btmp[1];
btmp[1] = btmp[0] - l21 * temp;
btmp[0] = temp;
} else {
btmp[1] -= l21 * btmp[0];
}
*scale = 1.f;
if (smlnum * 2.f * dabs(btmp[1]) > dabs(u22) || smlnum * 2.f * dabs(btmp[
0]) > dabs(u11)) {
/* Computing MAX */
r__1 = dabs(btmp[0]), r__2 = dabs(btmp[1]);
*scale = .5f / dmax(r__1,r__2);
btmp[0] *= *scale;
btmp[1] *= *scale;
}
x2[1] = btmp[1] / u22;
x2[0] = btmp[0] / u11 - u12 / u11 * x2[1];
if (xswap) {
temp = x2[1];
x2[1] = x2[0];
x2[0] = temp;
}
x[x_dim1 + 1] = x2[0];
if (*n1 == 1) {
x[(x_dim1 << 1) + 1] = x2[1];
*xnorm = (r__1 = x[x_dim1 + 1], dabs(r__1)) + (r__2 = x[(x_dim1 << 1)
+ 1], dabs(r__2));
} else {
x[x_dim1 + 2] = x2[1];
/* Computing MAX */
r__3 = (r__1 = x[x_dim1 + 1], dabs(r__1)), r__4 = (r__2 = x[x_dim1 +
2], dabs(r__2));
*xnorm = dmax(r__3,r__4);
}
return 0;
/* 2 by 2: */
/* op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12] */
/* [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22] */
/* Solve equivalent 4 by 4 system using complete pivoting. */
/* Set pivots less than SMIN to SMIN. */
L50:
/* Computing MAX */
r__5 = (r__1 = tr[tr_dim1 + 1], dabs(r__1)), r__6 = (r__2 = tr[(tr_dim1 <<
1) + 1], dabs(r__2)), r__5 = max(r__5,r__6), r__6 = (r__3 = tr[
tr_dim1 + 2], dabs(r__3)), r__5 = max(r__5,r__6), r__6 = (r__4 =
tr[(tr_dim1 << 1) + 2], dabs(r__4));
smin = dmax(r__5,r__6);
/* Computing MAX */
r__5 = smin, r__6 = (r__1 = tl[tl_dim1 + 1], dabs(r__1)), r__5 = max(r__5,
r__6), r__6 = (r__2 = tl[(tl_dim1 << 1) + 1], dabs(r__2)), r__5 =
max(r__5,r__6), r__6 = (r__3 = tl[tl_dim1 + 2], dabs(r__3)), r__5
= max(r__5,r__6), r__6 = (r__4 = tl[(tl_dim1 << 1) + 2], dabs(
r__4));
smin = dmax(r__5,r__6);
/* Computing MAX */
r__1 = eps * smin;
smin = dmax(r__1,smlnum);
btmp[0] = 0.f;
scopy_(&c__16, btmp, &c__0, t16, &c__1);
t16[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1];
t16[5] = tl[(tl_dim1 << 1) + 2] + sgn * tr[tr_dim1 + 1];
t16[10] = tl[tl_dim1 + 1] + sgn * tr[(tr_dim1 << 1) + 2];
t16[15] = tl[(tl_dim1 << 1) + 2] + sgn * tr[(tr_dim1 << 1) + 2];
if (*ltranl) {
t16[4] = tl[tl_dim1 + 2];
t16[1] = tl[(tl_dim1 << 1) + 1];
t16[14] = tl[tl_dim1 + 2];
t16[11] = tl[(tl_dim1 << 1) + 1];
} else {
t16[4] = tl[(tl_dim1 << 1) + 1];
t16[1] = tl[tl_dim1 + 2];
t16[14] = tl[(tl_dim1 << 1) + 1];
t16[11] = tl[tl_dim1 + 2];
}
if (*ltranr) {
t16[8] = sgn * tr[(tr_dim1 << 1) + 1];
t16[13] = sgn * tr[(tr_dim1 << 1) + 1];
t16[2] = sgn * tr[tr_dim1 + 2];
t16[7] = sgn * tr[tr_dim1 + 2];
} else {
t16[8] = sgn * tr[tr_dim1 + 2];
t16[13] = sgn * tr[tr_dim1 + 2];
t16[2] = sgn * tr[(tr_dim1 << 1) + 1];
t16[7] = sgn * tr[(tr_dim1 << 1) + 1];
}
btmp[0] = b[b_dim1 + 1];
btmp[1] = b[b_dim1 + 2];
btmp[2] = b[(b_dim1 << 1) + 1];
btmp[3] = b[(b_dim1 << 1) + 2];
/* Perform elimination */
for (i__ = 1; i__ <= 3; ++i__) {
xmax = 0.f;
for (ip = i__; ip <= 4; ++ip) {
for (jp = i__; jp <= 4; ++jp) {
if ((r__1 = t16[ip + (jp << 2) - 5], dabs(r__1)) >= xmax) {
xmax = (r__1 = t16[ip + (jp << 2) - 5], dabs(r__1));
ipsv = ip;
jpsv = jp;
}
/* L60: */
}
/* L70: */
}
if (ipsv != i__) {
sswap_(&c__4, &t16[ipsv - 1], &c__4, &t16[i__ - 1], &c__4);
temp = btmp[i__ - 1];
btmp[i__ - 1] = btmp[ipsv - 1];
btmp[ipsv - 1] = temp;
}
if (jpsv != i__) {
sswap_(&c__4, &t16[(jpsv << 2) - 4], &c__1, &t16[(i__ << 2) - 4],
&c__1);
}
jpiv[i__ - 1] = jpsv;
if ((r__1 = t16[i__ + (i__ << 2) - 5], dabs(r__1)) < smin) {
*info = 1;
t16[i__ + (i__ << 2) - 5] = smin;
}
for (j = i__ + 1; j <= 4; ++j) {
t16[j + (i__ << 2) - 5] /= t16[i__ + (i__ << 2) - 5];
btmp[j - 1] -= t16[j + (i__ << 2) - 5] * btmp[i__ - 1];
for (k = i__ + 1; k <= 4; ++k) {
t16[j + (k << 2) - 5] -= t16[j + (i__ << 2) - 5] * t16[i__ + (
k << 2) - 5];
/* L80: */
}
/* L90: */
}
/* L100: */
}
if (dabs(t16[15]) < smin) {
t16[15] = smin;
}
*scale = 1.f;
if (smlnum * 8.f * dabs(btmp[0]) > dabs(t16[0]) || smlnum * 8.f * dabs(
btmp[1]) > dabs(t16[5]) || smlnum * 8.f * dabs(btmp[2]) > dabs(
t16[10]) || smlnum * 8.f * dabs(btmp[3]) > dabs(t16[15])) {
/* Computing MAX */
r__1 = dabs(btmp[0]), r__2 = dabs(btmp[1]), r__1 = max(r__1,r__2),
r__2 = dabs(btmp[2]), r__1 = max(r__1,r__2), r__2 = dabs(btmp[
3]);
*scale = .125f / dmax(r__1,r__2);
btmp[0] *= *scale;
btmp[1] *= *scale;
btmp[2] *= *scale;
btmp[3] *= *scale;
}
for (i__ = 1; i__ <= 4; ++i__) {
k = 5 - i__;
temp = 1.f / t16[k + (k << 2) - 5];
tmp[k - 1] = btmp[k - 1] * temp;
for (j = k + 1; j <= 4; ++j) {
tmp[k - 1] -= temp * t16[k + (j << 2) - 5] * tmp[j - 1];
/* L110: */
}
/* L120: */
}
for (i__ = 1; i__ <= 3; ++i__) {
if (jpiv[4 - i__ - 1] != 4 - i__) {
temp = tmp[4 - i__ - 1];
tmp[4 - i__ - 1] = tmp[jpiv[4 - i__ - 1] - 1];
tmp[jpiv[4 - i__ - 1] - 1] = temp;
}
/* L130: */
}
x[x_dim1 + 1] = tmp[0];
x[x_dim1 + 2] = tmp[1];
x[(x_dim1 << 1) + 1] = tmp[2];
x[(x_dim1 << 1) + 2] = tmp[3];
/* Computing MAX */
r__1 = dabs(tmp[0]) + dabs(tmp[2]), r__2 = dabs(tmp[1]) + dabs(tmp[3]);
*xnorm = dmax(r__1,r__2);
return 0;
/* End of SLASY2 */
} /* slasy2_ */
/* 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_ */
/* Subroutine */ int claqp2_(integer *m, integer *n, integer *offset, complex
*a, integer *lda, integer *jpvt, complex *tau, real *vn1, real *vn2,
complex *work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
double c_abs(complex *), sqrt(doublereal);
/* Local variables */
static integer i__, j, mn;
static complex aii;
static integer pvt;
static real temp, temp2;
extern /* Subroutine */ int clarf_(char *, integer *, integer *, complex *
, integer *, complex *, complex *, integer *, complex *, ftnlen);
static integer offpi;
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
static integer itemp;
extern doublereal scnrm2_(integer *, complex *, integer *);
extern /* Subroutine */ int clarfg_(integer *, complex *, complex *,
integer *, complex *);
extern integer isamax_(integer *, real *, integer *);
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAQP2 computes a QR factorization with column pivoting of */
/* the block A(OFFSET+1:M,1:N). */
/* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */
/* 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. */
/* OFFSET (input) INTEGER */
/* The number of rows of the matrix A that must be pivoted */
/* but no factorized. OFFSET >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the M-by-N matrix A. */
/* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is */
/* the triangular factor obtained; the elements in block */
/* A(OFFSET+1:M,1:N) below the diagonal, together with the */
/* array TAU, represent the orthogonal matrix Q as a product of */
/* elementary reflectors. Block A(1:OFFSET,1:N) has been */
/* accordingly pivoted, but no factorized. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* JPVT (input/output) INTEGER array, dimension (N) */
/* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */
/* to the front of A*P (a leading column); if JPVT(i) = 0, */
/* the i-th column of A is a free column. */
/* On exit, if JPVT(i) = k, then the i-th column of A*P */
/* was the k-th column of A. */
/* TAU (output) COMPLEX array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors. */
/* VN1 (input/output) REAL array, dimension (N) */
/* The vector with the partial column norms. */
/* VN2 (input/output) REAL array, dimension (N) */
/* The vector with the exact column norms. */
/* WORK (workspace) COMPLEX array, dimension (N) */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */
/* X. Sun, Computer Science Dept., Duke University, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--jpvt;
--tau;
--vn1;
--vn2;
--work;
/* Function Body */
/* Computing MIN */
i__1 = *m - *offset;
mn = min(i__1,*n);
/* Compute factorization. */
i__1 = mn;
for (i__ = 1; i__ <= i__1; ++i__) {
offpi = *offset + i__;
/* Determine ith pivot column and swap if necessary. */
i__2 = *n - i__ + 1;
pvt = i__ - 1 + isamax_(&i__2, &vn1[i__], &c__1);
if (pvt != i__) {
cswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
c__1);
itemp = jpvt[pvt];
jpvt[pvt] = jpvt[i__];
jpvt[i__] = itemp;
vn1[pvt] = vn1[i__];
vn2[pvt] = vn2[i__];
}
/* Generate elementary reflector H(i). */
if (offpi < *m) {
i__2 = *m - offpi + 1;
clarfg_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ *
a_dim1], &c__1, &tau[i__]);
} else {
clarfg_(&c__1, &a[*m + i__ * a_dim1], &a[*m + i__ * a_dim1], &
c__1, &tau[i__]);
}
if (i__ < *n) {
/* Apply H(i)' to A(offset+i:m,i+1:n) from the left. */
i__2 = offpi + i__ * a_dim1;
aii.r = a[i__2].r, aii.i = a[i__2].i;
i__2 = offpi + i__ * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
i__2 = *m - offpi + 1;
i__3 = *n - i__;
r_cnjg(&q__1, &tau[i__]);
clarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, &
q__1, &a[offpi + (i__ + 1) * a_dim1], lda, &work[1], (
ftnlen)4);
i__2 = offpi + i__ * a_dim1;
a[i__2].r = aii.r, a[i__2].i = aii.i;
}
/* Update partial column norms. */
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
if (vn1[j] != 0.f) {
/* Computing 2nd power */
r__1 = c_abs(&a[offpi + j * a_dim1]) / vn1[j];
temp = 1.f - r__1 * r__1;
temp = dmax(temp,0.f);
/* Computing 2nd power */
r__1 = vn1[j] / vn2[j];
temp2 = temp * .05f * (r__1 * r__1) + 1.f;
if (temp2 == 1.f) {
if (offpi < *m) {
i__3 = *m - offpi;
vn1[j] = scnrm2_(&i__3, &a[offpi + 1 + j * a_dim1], &
c__1);
vn2[j] = vn1[j];
} else {
vn1[j] = 0.f;
vn2[j] = 0.f;
}
} else {
vn1[j] *= sqrt(temp);
}
}
/* L10: */
}
/* L20: */
}
return 0;
/* End of CLAQP2 */
} /* claqp2_ */
/* Subroutine */ int cgeevx_(char *balanc, char *jobvl, char *jobvr, char *
sense, integer *n, complex *a, integer *lda, complex *w, complex *vl,
integer *ldvl, complex *vr, integer *ldvr, integer *ilo, integer *ihi,
real *scale, real *abnrm, real *rconde, real *rcondv, complex *work,
integer *lwork, real *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
real r__1, r__2;
complex q__1, q__2;
/* Local variables */
integer i__, k;
char job[1];
real scl, dum[1], eps;
complex tmp;
char side[1];
real anrm;
integer ierr, itau, iwrk, nout;
integer icond;
logical scalea;
real cscale;
logical select[1];
real bignum;
integer minwrk, maxwrk;
logical wantvl, wntsnb;
integer hswork;
logical wntsne;
real smlnum;
logical lquery, wantvr, wntsnn, wntsnv;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CGEEVX computes for an N-by-N complex nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* Optionally also, it computes a balancing transformation to improve */
/* the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */
/* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */
/* (RCONDE), and reciprocal condition numbers for the right */
/* eigenvectors (RCONDV). */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component real. */
/* Balancing a matrix means permuting the rows and columns to make it */
/* more nearly upper triangular, and applying a diagonal similarity */
/* transformation D * A * D**(-1), where D is a diagonal matrix, to */
/* make its rows and columns closer in norm and the condition numbers */
/* of its eigenvalues and eigenvectors smaller. The computed */
/* reciprocal condition numbers correspond to the balanced matrix. */
/* Permuting rows and columns will not change the condition numbers */
/* (in exact arithmetic) but diagonal scaling will. For further */
/* explanation of balancing, see section 4.10.2 of the LAPACK */
/* Users' Guide. */
/* Arguments */
/* ========= */
/* BALANC (input) CHARACTER*1 */
/* Indicates how the input matrix should be diagonally scaled */
/* and/or permuted to improve the conditioning of its */
/* eigenvalues. */
/* = 'N': Do not diagonally scale or permute; */
/* = 'P': Perform permutations to make the matrix more nearly */
/* upper triangular. Do not diagonally scale; */
/* = 'S': Diagonally scale the matrix, ie. replace A by */
/* D*A*D**(-1), where D is a diagonal matrix chosen */
/* to make the rows and columns of A more equal in */
/* norm. Do not permute; */
/* = 'B': Both diagonally scale and permute A. */
/* Computed reciprocal condition numbers will be for the matrix */
/* after balancing and/or permuting. Permuting does not change */
/* condition numbers (in exact arithmetic), but balancing does. */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVL must = 'V'. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* If SENSE = 'E' or 'B', JOBVR must = 'V'. */
/* SENSE (input) CHARACTER*1 */
/* Determines which reciprocal condition numbers are computed. */
/* = 'N': None are computed; */
/* = 'E': Computed for eigenvalues only; */
/* = 'V': Computed for right eigenvectors only; */
/* = 'B': Computed for eigenvalues and right eigenvectors. */
/* If SENSE = 'E' or 'B', both left and right eigenvectors */
/* must also be computed (JOBVL = 'V' and JOBVR = 'V'). */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. If JOBVL = 'V' or */
/* JOBVR = 'V', A contains the Schur form of the balanced */
/* version of the matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* W (output) COMPLEX array, dimension (N) */
/* W contains the computed eigenvalues. */
/* VL (output) COMPLEX array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order */
/* as their eigenvalues. */
/* If JOBVL = 'N', VL is not referenced. */
/* u(j) = VL(:,j), the j-th column of VL. */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; if */
/* JOBVL = 'V', LDVL >= N. */
/* VR (output) COMPLEX array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order */
/* as their eigenvalues. */
/* If JOBVR = 'N', VR is not referenced. */
/* v(j) = VR(:,j), the j-th column of VR. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1; if */
/* JOBVR = 'V', LDVR >= N. */
/* ILO (output) INTEGER */
/* IHI (output) INTEGER */
/* ILO and IHI are integer values determined when A was */
/* balanced. The balanced A(i,j) = 0 if I > J and */
/* SCALE (output) REAL array, dimension (N) */
/* Details of the permutations and scaling factors applied */
/* when balancing A. If P(j) is the index of the row and column */
/* interchanged with row and column j, and D(j) is the scaling */
/* factor applied to row and column j, then */
/* The order in which the interchanges are made is N to IHI+1, */
/* then 1 to ILO-1. */
/* ABNRM (output) REAL */
/* The one-norm of the balanced matrix (the maximum */
/* of the sum of absolute values of elements of any column). */
/* RCONDE (output) REAL array, dimension (N) */
/* RCONDE(j) is the reciprocal condition number of the j-th */
/* eigenvalue. */
/* RCONDV (output) REAL array, dimension (N) */
/* RCONDV(j) is the reciprocal condition number of the j-th */
/* right eigenvector. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. If SENSE = 'N' or 'E', */
/* LWORK >= max(1,2*N), and if SENSE = 'V' or 'B', */
/* LWORK >= N*N+2*N. */
/* For good performance, LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) REAL array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the QR algorithm failed to compute all the */
/* eigenvalues, and no eigenvectors or condition numbers */
/* have been computed; elements 1:ILO-1 and i+1:N of W */
/* contain eigenvalues which have converged. */
/* ===================================================================== */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--scale;
--rconde;
--rcondv;
--work;
--rwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
wntsnn = lsame_(sense, "N");
wntsne = lsame_(sense, "E");
wntsnv = lsame_(sense, "V");
wntsnb = lsame_(sense, "B");
if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P")
|| lsame_(balanc, "B"))) {
*info = -1;
} else if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -2;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -3;
} else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb)
&& ! (wantvl && wantvr)) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -10;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -12;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* CWorkspace refers to complex workspace, and RWorkspace to real */
/* workspace. NB refers to the optimal block size for the */
/* immediately following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by CHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = *n + *n * ilaenv_(&c__1, "CGEHRD", " ", n, &c__1, n, &
c__0);
if (wantvl) {
chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[1], &c_n1, info);
} else if (wantvr) {
chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[1], &c_n1, info);
} else {
if (wntsnn) {
chseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &
vr[vr_offset], ldvr, &work[1], &c_n1, info);
} else {
chseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &
vr[vr_offset], ldvr, &work[1], &c_n1, info);
}
}
hswork = work[1].r;
if (! wantvl && ! wantvr) {
minwrk = *n << 1;
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + (*n << 1);
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + (*n << 1);
maxwrk = max(i__1,i__2);
}
} else {
minwrk = *n << 1;
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = minwrk, i__2 = *n * *n + (*n << 1);
minwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,hswork);
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
if (! (wntsnn || wntsne)) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n * *n + (*n << 1);
maxwrk = max(i__1,i__2);
}
/* Computing MAX */
i__1 = maxwrk, i__2 = *n << 1;
maxwrk = max(i__1,i__2);
}
maxwrk = max(maxwrk,minwrk);
}
work[1].r = (real) maxwrk, work[1].i = 0.f;
if (*lwork < minwrk && ! lquery) {
*info = -20;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
icond = 0;
anrm = clange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
clascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix and compute ABNRM */
cgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr);
*abnrm = clange_("1", n, n, &a[a_offset], lda, dum);
if (scalea) {
dum[0] = *abnrm;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, &
ierr);
*abnrm = dum[0];
}
/* Reduce to upper Hessenberg form */
/* (CWorkspace: need 2*N, prefer N+N*NB) */
/* (RWorkspace: none) */
itau = 1;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
cgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, &
ierr);
if (wantvl) {
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
clacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate unitary matrix in VL */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
cunghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
clacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
clacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate unitary matrix in VR */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
cunghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], &
i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only */
/* If condition numbers desired, compute Schur form */
if (wntsnn) {
*(unsigned char *)job = 'E';
} else {
*(unsigned char *)job = 'S';
}
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from CHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (CWorkspace: need 2*N) */
/* (RWorkspace: need N) */
ctrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[1], &
ierr);
}
/* Compute condition numbers if desired */
/* (CWorkspace: need N*N+2*N unless SENSE = 'E') */
/* (RWorkspace: need 2*N unless SENSE = 'E') */
if (! wntsnn) {
ctrsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset],
ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout,
&work[iwrk], n, &rwork[1], &icond);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
cgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl,
&ierr);
/* Normalize left eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1.f / scnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
csscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + i__ * vl_dim1;
/* Computing 2nd power */
r__1 = vl[i__3].r;
/* Computing 2nd power */
r__2 = r_imag(&vl[k + i__ * vl_dim1]);
rwork[k] = r__1 * r__1 + r__2 * r__2;
}
k = isamax_(n, &rwork[1], &c__1);
r_cnjg(&q__2, &vl[k + i__ * vl_dim1]);
r__1 = sqrt(rwork[k]);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
tmp.r = q__1.r, tmp.i = q__1.i;
cscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = k + i__ * vl_dim1;
i__3 = k + i__ * vl_dim1;
r__1 = vl[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
vl[i__2].r = q__1.r, vl[i__2].i = q__1.i;
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
cgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr,
&ierr);
/* Normalize right eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1.f / scnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
csscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + i__ * vr_dim1;
/* Computing 2nd power */
r__1 = vr[i__3].r;
/* Computing 2nd power */
r__2 = r_imag(&vr[k + i__ * vr_dim1]);
rwork[k] = r__1 * r__1 + r__2 * r__2;
}
k = isamax_(n, &rwork[1], &c__1);
r_cnjg(&q__2, &vr[k + i__ * vr_dim1]);
r__1 = sqrt(rwork[k]);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
tmp.r = q__1.r, tmp.i = q__1.i;
cscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = k + i__ * vr_dim1;
i__3 = k + i__ * vr_dim1;
r__1 = vr[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
vr[i__2].r = q__1.r, vr[i__2].i = q__1.i;
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1]
, &i__2, &ierr);
if (*info == 0) {
if ((wntsnv || wntsnb) && icond == 0) {
slascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[
1], n, &ierr);
}
} else {
i__1 = *ilo - 1;
clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n,
&ierr);
}
}
work[1].r = (real) maxwrk, work[1].i = 0.f;
return 0;
/* End of CGEEVX */
} /* cgeevx_ */
/* 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 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 stpcon_(char *norm, char *uplo, char *diag, integer *n,
real *ap, real *rcond, real *work, integer *iwork, integer *info,
ftnlen norm_len, ftnlen uplo_len, ftnlen diag_len)
{
/* System generated locals */
integer i__1;
real r__1;
/* Local variables */
static integer ix, kase, kase1;
static real scale;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static real anorm;
extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
static logical upper;
static real xnorm;
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slacon_(
integer *, real *, real *, integer *, real *, integer *);
extern integer isamax_(integer *, real *, integer *);
static real ainvnm;
static logical onenrm;
extern doublereal slantp_(char *, char *, char *, integer *, real *, real
*, ftnlen, ftnlen, ftnlen);
static char normin[1];
extern /* Subroutine */ int slatps_(char *, char *, char *, char *,
integer *, real *, real *, real *, real *, integer *, ftnlen,
ftnlen, ftnlen, ftnlen);
static real smlnum;
static logical nounit;
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* March 31, 1993 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* STPCON estimates the reciprocal of the condition number of a packed */
/* triangular matrix A, in either the 1-norm or the infinity-norm. */
/* The norm of A is computed and an estimate is obtained for */
/* norm(inv(A)), then the reciprocal of the condition number is */
/* computed as */
/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
/* Arguments */
/* ========= */
/* NORM (input) CHARACTER*1 */
/* Specifies whether the 1-norm condition number or the */
/* infinity-norm condition number is required: */
/* = '1' or 'O': 1-norm; */
/* = 'I': Infinity-norm. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* DIAG (input) CHARACTER*1 */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* 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. */
/* If DIAG = 'U', the diagonal elements of A are not referenced */
/* and are assumed to be 1. */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of the matrix A, */
/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */
/* WORK (workspace) REAL array, dimension (3*N) */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--iwork;
--work;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O", (ftnlen)1, (
ftnlen)1);
nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1);
if (! onenrm && ! lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) {
*info = -3;
} else if (*n < 0) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STPCON", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.f;
return 0;
}
*rcond = 0.f;
smlnum = slamch_("Safe minimum", (ftnlen)12) * (real) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = slantp_(norm, uplo, diag, n, &ap[1], &work[1], (ftnlen)1, (ftnlen)
1, (ftnlen)1);
/* Continue only if ANORM > 0. */
if (anorm > 0.f) {
/* Estimate the norm of the inverse of A. */
ainvnm = 0.f;
*(unsigned char *)normin = 'N';
if (onenrm) {
kase1 = 1;
} else {
kase1 = 2;
}
kase = 0;
L10:
slacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase);
if (kase != 0) {
if (kase == kase1) {
/* Multiply by inv(A). */
slatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[
1], &scale, &work[(*n << 1) + 1], info, (ftnlen)1, (
ftnlen)12, (ftnlen)1, (ftnlen)1);
} else {
/* Multiply by inv(A'). */
slatps_(uplo, "Transpose", diag, normin, n, &ap[1], &work[1],
&scale, &work[(*n << 1) + 1], info, (ftnlen)1, (
ftnlen)9, (ftnlen)1, (ftnlen)1);
}
*(unsigned char *)normin = 'Y';
/* Multiply by 1/SCALE if doing so will not cause overflow. */
if (scale != 1.f) {
ix = isamax_(n, &work[1], &c__1);
xnorm = (r__1 = work[ix], dabs(r__1));
if (scale < xnorm * smlnum || scale == 0.f) {
goto L20;
}
srscl_(n, &scale, &work[1], &c__1);
}
goto L10;
}
/* Compute the estimate of the reciprocal condition number. */
if (ainvnm != 0.f) {
*rcond = 1.f / anorm / ainvnm;
}
}
L20:
return 0;
/* End of STPCON */
} /* stpcon_ */
/* Subroutine */ int clatrs_(char *uplo, char *trans, char *diag, char *
normin, integer *n, complex *a, integer *lda, complex *x, real *scale,
real *cnorm, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j;
real xj, rec, tjj;
integer jinc;
real xbnd;
integer imax;
real tmax;
complex tjjs;
real xmax, grow;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real tscal;
complex uscal;
integer jlast;
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
complex csumj;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
logical upper;
extern /* Subroutine */ int ctrsv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *), slabad_(real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
real bignum;
extern integer isamax_(integer *, real *, integer *);
extern doublereal scasum_(integer *, complex *, 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 */
/* ======= */
/* CLATRS solves one of the triangular systems */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
/* with scaling to prevent overflow. Here A is an upper or lower */
/* triangular matrix, A**T denotes the transpose of A, A**H denotes the */
/* conjugate 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 */
/* CTRSV 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**T * x = s*b (Transpose) */
/* = 'C': Solve A**H * x = s*b (Conjugate transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* NORMIN (input) CHARACTER*1 */
/* Specifies whether CNORM has been set or not. */
/* = 'Y': CNORM contains the column norms on entry */
/* = 'N': CNORM is not set on entry. On exit, the norms will */
/* be computed and stored in CNORM. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading n by n */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of */
/* A is not referenced. If UPLO = 'L', the leading n by n lower */
/* triangular part of the array A contains the lower triangular */
/* matrix, and the strictly upper triangular part of A is not */
/* referenced. If DIAG = 'U', the diagonal elements of A are */
/* also not referenced and are assumed to be 1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max (1,N). */
/* X (input/output) COMPLEX 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, A**T * x = s*b, or A**H * 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, CTRSV */
/* 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 CTRSV 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**T *x = b or */
/* A**H *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 CTRSV 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 .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. 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_("CLATRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum /= 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] = scasum_(&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] = scasum_(&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/2. */
imax = isamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5f) {
tscal = 1.f;
} else {
tscal = .5f / (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 CTRSV can be used. */
xmax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, dabs(r__1)) + (r__2 =
r_imag(&x[j]) / 2.f, dabs(r__2));
xmax = dmax(r__3,r__4);
/* L30: */
}
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 L60;
}
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 = .5f / 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 L60;
}
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
xbnd = dmin(r__1,r__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
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;
}
/* L40: */
}
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 = .5f / 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 L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1.f / (cnorm[j] + 1.f);
/* L50: */
}
}
L60:
;
} else {
/* Compute the growth in A**T * x = b or A**H * 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 L90;
}
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 = .5f / 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 L90;
}
/* 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);
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj >= smlnum) {
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
if (xj > tjj) {
xbnd *= tjj / xj;
}
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
/* L70: */
}
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 = .5f / 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 L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.f;
grow /= xj;
/* L80: */
}
}
L90:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
/* elements of X is not too small. */
ctrsv_(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 * .5f) {
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum * .5f / xmax;
csscal_(n, scale, &x[1], &c__1);
xmax = bignum;
} else {
xmax *= 2.f;
}
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. */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3].i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L105;
}
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
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;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
} 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];
}
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
} 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__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L100: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
xj = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L105:
/* 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;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
csscal_(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;
i__4 = j;
q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
caxpy_(&i__3, &q__1, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
i__3 = j - 1;
i__ = icamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__]), dabs(r__2));
}
} 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;
i__4 = j;
q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
caxpy_(&i__3, &q__1, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
i__3 = *n - j;
i__ = j + icamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__]), dabs(r__2));
}
}
/* L110: */
}
} else if (lsame_(trans, "T")) {
/* 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 */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
uscal.r = tscal, uscal.i = 0.f;
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) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3]
.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
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);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r, uscal.i = q__1.i;
}
if (rec < 1.f) {
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f, csumj.i = 0.f;
if (uscal.r == 1.f && uscal.i == 0.f) {
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTU to perform the dot product. */
if (upper) {
i__3 = j - 1;
cdotu_(&q__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
} else if (j < *n) {
i__3 = *n - j;
cdotu_(&q__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
q__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, q__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
q__2.i = q__3.r * x[i__5].i + q__3.i * x[
i__5].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L120: */
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
q__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, q__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
q__2.i = q__3.r * x[i__5].i + q__3.i * x[
i__5].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L130: */
}
}
}
q__1.r = tscal, q__1.i = 0.f;
if (uscal.r == q__1.r && uscal.i == q__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3]
.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L145;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
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;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} 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;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} 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__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L140: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
*scale = 0.f;
xmax = 0.f;
}
L145:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
/* L150: */
}
} else {
/* Solve A**H * 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) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
uscal.r = tscal, uscal.i = 0.f;
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) {
r_cnjg(&q__2, &a[j + j * a_dim1]);
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
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);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r, uscal.i = q__1.i;
}
if (rec < 1.f) {
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f, csumj.i = 0.f;
if (uscal.r == 1.f && uscal.i == 0.f) {
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTC to perform the dot product. */
if (upper) {
i__3 = j - 1;
cdotc_(&q__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
} else if (j < *n) {
i__3 = *n - j;
cdotc_(&q__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
r_cnjg(&q__4, &a[i__ + j * a_dim1]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
q__3.i = q__4.r * uscal.i + q__4.i *
uscal.r;
i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
q__2.i = q__3.r * x[i__4].i + q__3.i * x[
i__4].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L160: */
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
r_cnjg(&q__4, &a[i__ + j * a_dim1]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
q__3.i = q__4.r * uscal.i + q__4.i *
uscal.r;
i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
q__2.i = q__3.r * x[i__4].i + q__3.i * x[
i__4].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L170: */
}
}
}
q__1.r = tscal, q__1.i = 0.f;
if (uscal.r == q__1.r && uscal.i == q__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
if (nounit) {
r_cnjg(&q__2, &a[j + j * a_dim1]);
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L185;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
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;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} 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;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**H *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L180: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
*scale = 0.f;
xmax = 0.f;
}
L185:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
/* L190: */
}
}
*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 CLATRS */
} /* clatrs_ */
/* Subroutine */ int spot05_(char *uplo, integer *n, integer *nrhs, real *a,
integer *lda, real *b, integer *ldb, real *x, integer *ldx, real *
xact, integer *ldxact, real *ferr, real *berr, real *reslts)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
xact_offset, i__1, i__2, i__3;
real r__1, r__2, r__3;
/* Local variables */
integer i__, j, k;
real eps, tmp, diff, axbi;
integer imax;
real unfl, ovfl;
extern logical lsame_(char *, char *);
logical upper;
real xnorm;
extern doublereal slamch_(char *);
real errbnd;
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 */
/* ======= */
/* SPOT05 tests the error bounds from iterative refinement for the */
/* computed solution to a system of equations A*X = B, where A is a */
/* symmetric n by n matrix. */
/* RESLTS(1) = test of the error bound */
/* = norm(X - XACT) / ( norm(X) * FERR ) */
/* A large value is returned if this ratio is not less than one. */
/* RESLTS(2) = residual from the iterative refinement routine */
/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
/* 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 of the matrices X, B, and XACT, and the */
/* order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of the matrices X, B, and XACT. */
/* NRHS >= 0. */
/* A (input) REAL array, dimension (LDA,N) */
/* The symmetric matrix A. If UPLO = 'U', the leading n by n */
/* upper triangular part of A contains the upper triangular part */
/* of the matrix A, and the strictly lower triangular part of A */
/* is not referenced. If UPLO = 'L', the leading n by n lower */
/* triangular part of A contains the lower triangular part of */
/* the matrix A, and the strictly upper triangular part of A is */
/* not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= 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). */
/* X (input) REAL array, dimension (LDX,NRHS) */
/* The computed solution vectors. Each vector is stored as a */
/* column of the matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* XACT (input) REAL array, dimension (LDX,NRHS) */
/* The exact solution vectors. Each vector is stored as a */
/* column of the matrix XACT. */
/* LDXACT (input) INTEGER */
/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
/* FERR (input) REAL array, dimension (NRHS) */
/* The estimated forward error bounds for each solution vector */
/* X. If XTRUE is the true solution, FERR bounds the magnitude */
/* of the largest entry in (X - XTRUE) divided by the magnitude */
/* of the largest entry in X. */
/* BERR (input) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector (i.e., the smallest relative change in any entry of A */
/* or B that makes X an exact solution). */
/* RESLTS (output) REAL array, dimension (2) */
/* The maximum over the NRHS solution vectors of the ratios: */
/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. 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;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.f;
reslts[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
upper = lsame_(uplo, "U");
/* Test 1: Compute the maximum of */
/* norm(X - XACT) / ( norm(X) * FERR ) */
/* over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = isamax_(n, &x[j * x_dim1 + 1], &c__1);
/* Computing MAX */
r__2 = (r__1 = x[imax + j * x_dim1], dabs(r__1));
xnorm = dmax(r__2,unfl);
diff = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = diff, r__3 = (r__1 = x[i__ + j * x_dim1] - xact[i__ + j *
xact_dim1], dabs(r__1));
diff = dmax(r__2,r__3);
/* L10: */
}
if (xnorm > 1.f) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1.f / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
errbnd = dmax(r__1,r__2);
} else {
errbnd = 1.f / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
tmp = (r__1 = b[i__ + k * b_dim1], dabs(r__1));
if (upper) {
i__3 = i__;
for (j = 1; j <= i__3; ++j) {
tmp += (r__1 = a[j + i__ * a_dim1], dabs(r__1)) * (r__2 =
x[j + k * x_dim1], dabs(r__2));
/* L40: */
}
i__3 = *n;
for (j = i__ + 1; j <= i__3; ++j) {
tmp += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * (r__2 =
x[j + k * x_dim1], dabs(r__2));
/* L50: */
}
} else {
i__3 = i__ - 1;
for (j = 1; j <= i__3; ++j) {
tmp += (r__1 = a[i__ + j * a_dim1], dabs(r__1)) * (r__2 =
x[j + k * x_dim1], dabs(r__2));
/* L60: */
}
i__3 = *n;
for (j = i__; j <= i__3; ++j) {
tmp += (r__1 = a[j + i__ * a_dim1], dabs(r__1)) * (r__2 =
x[j + k * x_dim1], dabs(r__2));
/* L70: */
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = dmin(axbi,tmp);
}
/* L80: */
}
/* Computing MAX */
r__1 = axbi, r__2 = (*n + 1) * unfl;
tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = dmax(reslts[2],tmp);
}
/* L90: */
}
return 0;
/* End of SPOT05 */
} /* spot05_ */
/* 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_ */
/* Subroutine */ int ssptrf_(char *uplo, integer *n, real *ap, integer *ipiv,
integer *info)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2, r__3;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, k;
real t, r1, d11, d12, d21, d22;
integer kc, kk, kp;
real wk;
integer kx, knc, kpc, npp;
real wkm1, wkp1;
integer imax, jmax;
extern /* Subroutine */ int sspr_(char *, integer *, real *, real *,
integer *, real *);
real alpha;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
integer kstep;
logical upper;
extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *,
integer *);
real absakk;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
real colmax, rowmax;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSPTRF computes the factorization of a real symmetric matrix A stored */
/* in packed format using the Bunch-Kaufman diagonal pivoting method: */
/* A = U*D*U**T or A = L*D*L**T */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, and D is symmetric and block diagonal with */
/* 1-by-1 and 2-by-2 diagonal blocks. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) REAL array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the symmetric matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L, stored as a packed triangular */
/* matrix overwriting A (see below for further details). */
/* IPIV (output) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D. */
/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
/* has been completed, but the block diagonal matrix D is */
/* exactly singular, and division by zero will occur if it */
/* is used to solve a system of equations. */
/* Further Details */
/* =============== */
/* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services */
/* Company */
/* If UPLO = 'U', then A = U*D*U', where */
/* U = P(n)*U(n)* ... *P(k)U(k)* ..., */
/* i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
/* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
/* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
/* ( I v 0 ) k-s */
/* U(k) = ( 0 I 0 ) s */
/* ( 0 0 I ) n-k */
/* k-s s n-k */
/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
/* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
/* and A(k,k), and v overwrites A(1:k-2,k-1:k). */
/* If UPLO = 'L', then A = L*D*L', where */
/* L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
/* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
/* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
/* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */
/* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
/* that if the diagonal block D(k) is of order s (s = 1 or 2), then */
/* ( I 0 0 ) k-1 */
/* L(k) = ( 0 I 0 ) s */
/* ( 0 v I ) n-k-s+1 */
/* k-1 s n-k-s+1 */
/* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
/* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
/* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ipiv;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSPTRF", &i__1);
return 0;
}
/* Initialize ALPHA for use in choosing pivot block size. */
alpha = (sqrt(17.f) + 1.f) / 8.f;
if (upper) {
/* Factorize A as U*D*U' using the upper triangle of A */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2 */
k = *n;
kc = (*n - 1) * *n / 2 + 1;
L10:
knc = kc;
/* If K < 1, exit from loop */
if (k < 1) {
goto L110;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
absakk = (r__1 = ap[kc + k - 1], dabs(r__1));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
if (k > 1) {
i__1 = k - 1;
imax = isamax_(&i__1, &ap[kc], &c__1);
colmax = (r__1 = ap[kc + imax - 1], dabs(r__1));
} else {
colmax = 0.f;
}
if (dmax(absakk,colmax) == 0.f) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
rowmax = 0.f;
jmax = imax;
kx = imax * (imax + 1) / 2 + imax;
i__1 = k;
for (j = imax + 1; j <= i__1; ++j) {
if ((r__1 = ap[kx], dabs(r__1)) > rowmax) {
rowmax = (r__1 = ap[kx], dabs(r__1));
jmax = j;
}
kx += j;
/* L20: */
}
kpc = (imax - 1) * imax / 2 + 1;
if (imax > 1) {
i__1 = imax - 1;
jmax = isamax_(&i__1, &ap[kpc], &c__1);
/* Computing MAX */
r__2 = rowmax, r__3 = (r__1 = ap[kpc + jmax - 1], dabs(
r__1));
rowmax = dmax(r__2,r__3);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else if ((r__1 = ap[kpc + imax - 1], dabs(r__1)) >= alpha *
rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
} else {
/* interchange rows and columns K-1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
kk = k - kstep + 1;
if (kstep == 2) {
knc = knc - k + 1;
}
if (kp != kk) {
/* Interchange rows and columns KK and KP in the leading */
/* submatrix A(1:k,1:k) */
i__1 = kp - 1;
sswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1);
kx = kpc + kp - 1;
i__1 = kk - 1;
for (j = kp + 1; j <= i__1; ++j) {
kx = kx + j - 1;
t = ap[knc + j - 1];
ap[knc + j - 1] = ap[kx];
ap[kx] = t;
/* L30: */
}
t = ap[knc + kk - 1];
ap[knc + kk - 1] = ap[kpc + kp - 1];
ap[kpc + kp - 1] = t;
if (kstep == 2) {
t = ap[kc + k - 2];
ap[kc + k - 2] = ap[kc + kp - 1];
ap[kc + kp - 1] = t;
}
}
/* Update the leading submatrix */
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = U(k)*D(k) */
/* where U(k) is the k-th column of U */
/* Perform a rank-1 update of A(1:k-1,1:k-1) as */
/* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' */
r1 = 1.f / ap[kc + k - 1];
i__1 = k - 1;
r__1 = -r1;
sspr_(uplo, &i__1, &r__1, &ap[kc], &c__1, &ap[1]);
/* Store U(k) in column k */
i__1 = k - 1;
sscal_(&i__1, &r1, &ap[kc], &c__1);
} else {
/* 2-by-2 pivot block D(k): columns k and k-1 now hold */
/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */
/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */
/* of U */
/* Perform a rank-2 update of A(1:k-2,1:k-2) as */
/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' */
/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' */
if (k > 2) {
d12 = ap[k - 1 + (k - 1) * k / 2];
d22 = ap[k - 1 + (k - 2) * (k - 1) / 2] / d12;
d11 = ap[k + (k - 1) * k / 2] / d12;
t = 1.f / (d11 * d22 - 1.f);
d12 = t / d12;
for (j = k - 2; j >= 1; --j) {
wkm1 = d12 * (d11 * ap[j + (k - 2) * (k - 1) / 2] -
ap[j + (k - 1) * k / 2]);
wk = d12 * (d22 * ap[j + (k - 1) * k / 2] - ap[j + (k
- 2) * (k - 1) / 2]);
for (i__ = j; i__ >= 1; --i__) {
ap[i__ + (j - 1) * j / 2] = ap[i__ + (j - 1) * j /
2] - ap[i__ + (k - 1) * k / 2] * wk - ap[
i__ + (k - 2) * (k - 1) / 2] * wkm1;
/* L40: */
}
ap[j + (k - 1) * k / 2] = wk;
ap[j + (k - 2) * (k - 1) / 2] = wkm1;
/* L50: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k - 1] = -kp;
}
/* Decrease K and return to the start of the main loop */
k -= kstep;
kc = knc - k;
goto L10;
} else {
/* Factorize A as L*D*L' using the lower triangle of A */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2 */
k = 1;
kc = 1;
npp = *n * (*n + 1) / 2;
L60:
knc = kc;
/* If K > N, exit from loop */
if (k > *n) {
goto L110;
}
kstep = 1;
/* Determine rows and columns to be interchanged and whether */
/* a 1-by-1 or 2-by-2 pivot block will be used */
absakk = (r__1 = ap[kc], dabs(r__1));
/* IMAX is the row-index of the largest off-diagonal element in */
/* column K, and COLMAX is its absolute value */
if (k < *n) {
i__1 = *n - k;
imax = k + isamax_(&i__1, &ap[kc + 1], &c__1);
colmax = (r__1 = ap[kc + imax - k], dabs(r__1));
} else {
colmax = 0.f;
}
if (dmax(absakk,colmax) == 0.f) {
/* Column K is zero: set INFO and continue */
if (*info == 0) {
*info = k;
}
kp = k;
} else {
if (absakk >= alpha * colmax) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else {
/* JMAX is the column-index of the largest off-diagonal */
/* element in row IMAX, and ROWMAX is its absolute value */
rowmax = 0.f;
kx = kc + imax - k;
i__1 = imax - 1;
for (j = k; j <= i__1; ++j) {
if ((r__1 = ap[kx], dabs(r__1)) > rowmax) {
rowmax = (r__1 = ap[kx], dabs(r__1));
jmax = j;
}
kx = kx + *n - j;
/* L70: */
}
kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1;
if (imax < *n) {
i__1 = *n - imax;
jmax = imax + isamax_(&i__1, &ap[kpc + 1], &c__1);
/* Computing MAX */
r__2 = rowmax, r__3 = (r__1 = ap[kpc + jmax - imax], dabs(
r__1));
rowmax = dmax(r__2,r__3);
}
if (absakk >= alpha * colmax * (colmax / rowmax)) {
/* no interchange, use 1-by-1 pivot block */
kp = k;
} else if ((r__1 = ap[kpc], dabs(r__1)) >= alpha * rowmax) {
/* interchange rows and columns K and IMAX, use 1-by-1 */
/* pivot block */
kp = imax;
} else {
/* interchange rows and columns K+1 and IMAX, use 2-by-2 */
/* pivot block */
kp = imax;
kstep = 2;
}
}
kk = k + kstep - 1;
if (kstep == 2) {
knc = knc + *n - k + 1;
}
if (kp != kk) {
/* Interchange rows and columns KK and KP in the trailing */
/* submatrix A(k:n,k:n) */
if (kp < *n) {
i__1 = *n - kp;
sswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1],
&c__1);
}
kx = knc + kp - kk;
i__1 = kp - 1;
for (j = kk + 1; j <= i__1; ++j) {
kx = kx + *n - j + 1;
t = ap[knc + j - kk];
ap[knc + j - kk] = ap[kx];
ap[kx] = t;
/* L80: */
}
t = ap[knc];
ap[knc] = ap[kpc];
ap[kpc] = t;
if (kstep == 2) {
t = ap[kc + 1];
ap[kc + 1] = ap[kc + kp - k];
ap[kc + kp - k] = t;
}
}
/* Update the trailing submatrix */
if (kstep == 1) {
/* 1-by-1 pivot block D(k): column k now holds */
/* W(k) = L(k)*D(k) */
/* where L(k) is the k-th column of L */
if (k < *n) {
/* Perform a rank-1 update of A(k+1:n,k+1:n) as */
/* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' */
r1 = 1.f / ap[kc];
i__1 = *n - k;
r__1 = -r1;
sspr_(uplo, &i__1, &r__1, &ap[kc + 1], &c__1, &ap[kc + *n
- k + 1]);
/* Store L(k) in column K */
i__1 = *n - k;
sscal_(&i__1, &r1, &ap[kc + 1], &c__1);
}
} else {
/* 2-by-2 pivot block D(k): columns K and K+1 now hold */
/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */
/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */
/* of L */
if (k < *n - 1) {
/* Perform a rank-2 update of A(k+2:n,k+2:n) as */
/* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )' */
/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' */
d21 = ap[k + 1 + (k - 1) * ((*n << 1) - k) / 2];
d11 = ap[k + 1 + k * ((*n << 1) - k - 1) / 2] / d21;
d22 = ap[k + (k - 1) * ((*n << 1) - k) / 2] / d21;
t = 1.f / (d11 * d22 - 1.f);
d21 = t / d21;
i__1 = *n;
for (j = k + 2; j <= i__1; ++j) {
wk = d21 * (d11 * ap[j + (k - 1) * ((*n << 1) - k) /
2] - ap[j + k * ((*n << 1) - k - 1) / 2]);
wkp1 = d21 * (d22 * ap[j + k * ((*n << 1) - k - 1) /
2] - ap[j + (k - 1) * ((*n << 1) - k) / 2]);
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
ap[i__ + (j - 1) * ((*n << 1) - j) / 2] = ap[i__
+ (j - 1) * ((*n << 1) - j) / 2] - ap[i__
+ (k - 1) * ((*n << 1) - k) / 2] * wk -
ap[i__ + k * ((*n << 1) - k - 1) / 2] *
wkp1;
/* L90: */
}
ap[j + (k - 1) * ((*n << 1) - k) / 2] = wk;
ap[j + k * ((*n << 1) - k - 1) / 2] = wkp1;
/* L100: */
}
}
}
}
/* Store details of the interchanges in IPIV */
if (kstep == 1) {
ipiv[k] = kp;
} else {
ipiv[k] = -kp;
ipiv[k + 1] = -kp;
}
/* Increase K and return to the start of the main loop */
k += kstep;
kc = knc + *n - k + 2;
goto L60;
}
L110:
return 0;
/* End of SSPTRF */
} /* ssptrf_ */
