/* 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 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 */
}
/* Subroutine */ int strcon_(char *norm, char *uplo, char *diag, integer *n,
real *a, integer *lda, 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
March 31, 1993
Purpose
=======
STRCON estimates the reciprocal of the condition number of a
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.
A (input) REAL array, dimension (LDA,N)
The triangular matrix A. If UPLO = 'U', the leading N-by-N
upper triangular part of the array A contains the upper
triangular matrix, and the strictly lower triangular part of
A is not referenced. If UPLO = 'L', the leading N-by-N lower
triangular part of the array A contains the lower triangular
matrix, and the strictly upper triangular part of A is not
referenced. If DIAG = 'U', the diagonal elements of A are
also not referenced and are assumed to be 1.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
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
=====================================================================
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 *);
static real anorm;
extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
static logical upper;
static real xnorm;
static integer ix;
extern doublereal slamch_(char *);
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 doublereal slantr_(char *, char *, char *, integer *, integer *,
real *, integer *, real *);
extern /* Subroutine */ int slatrs_(char *, char *, char *, char *,
integer *, real *, integer *, real *, real *, real *, integer *);
static real smlnum;
static logical nounit;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
nounit = lsame_(diag, "N");
if (! onenrm && ! lsame_(norm, "I")) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("STRCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*rcond = 1.f;
return 0;
}
*rcond = 0.f;
smlnum = slamch_("Safe minimum") * (real) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = slantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &work[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). */
slatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset],
lda, &work[1], &scale, &work[(*n << 1) + 1], info);
} else {
/* Multiply by inv(A'). */
slatrs_(uplo, "Transpose", diag, normin, n, &a[a_offset], lda,
&work[1], &scale, &work[(*n << 1) + 1], info);
}
*(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 STRCON */
} /* strcon_ */
/* Subroutine */
int sgecon_(char *norm, integer *n, real *a, integer *lda, real *anorm, real *rcond, real *work, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1;
/* Local variables */
real sl;
integer ix;
real su;
integer kase, kase1;
real scale;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */
int srscl_(integer *, real *, real *, integer *), slacn2_(integer *, real *, real *, integer *, real *, integer *, integer *);
extern real slamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
real ainvnm;
logical onenrm;
char normin[1];
extern /* Subroutine */
int slatrs_(char *, char *, char *, char *, integer *, real *, integer *, real *, real *, real *, integer *);
real smlnum;
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--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:
slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
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**T). */
slatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info);
/* Multiply by inv(L**T). */
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], f2c_abs(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 */
}
int slaein_(int *rightv, int *noinit, int *n,
float *h__, int *ldh, float *wr, float *wi, float *vr, float *vi, float
*b, int *ldb, float *work, float *eps3, float *smlnum, float *bignum,
int *info)
{
/* System generated locals */
int b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4;
float r__1, r__2, r__3, r__4;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int i__, j;
float w, x, y;
int i1, i2, i3;
float w1, ei, ej, xi, xr, rec;
int its, ierr;
float temp, norm, vmax;
extern double snrm2_(int *, float *, int *);
float scale;
extern int sscal_(int *, float *, float *, int *);
char trans[1];
float vcrit;
extern double sasum_(int *, float *, int *);
float rootn, vnorm;
extern double slapy2_(float *, float *);
float absbii, absbjj;
extern int isamax_(int *, float *, int *);
extern int sladiv_(float *, float *, float *, float *, float *
, float *);
char normin[1];
float nrmsml;
extern int slatrs_(char *, char *, char *, char *,
int *, float *, int *, float *, float *, float *, int *);
float growto;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAEIN uses inverse iteration to find a right or left eigenvector */
/* corresponding to the eigenvalue (WR,WI) of a float upper Hessenberg */
/* matrix H. */
/* Arguments */
/* ========= */
/* RIGHTV (input) LOGICAL */
/* = .TRUE. : compute right eigenvector; */
/* = .FALSE.: compute left eigenvector. */
/* NOINIT (input) LOGICAL */
/* = .TRUE. : no initial vector supplied in (VR,VI). */
/* = .FALSE.: initial vector supplied in (VR,VI). */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* H (input) REAL array, dimension (LDH,N) */
/* The upper Hessenberg matrix H. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= MAX(1,N). */
/* WR (input) REAL */
/* WI (input) REAL */
/* The float and imaginary parts of the eigenvalue of H whose */
/* corresponding right or left eigenvector is to be computed. */
/* VR (input/output) REAL array, dimension (N) */
/* VI (input/output) REAL array, dimension (N) */
/* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain */
/* a float starting vector for inverse iteration using the float */
/* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI */
/* must contain the float and imaginary parts of a complex */
/* starting vector for inverse iteration using the complex */
/* eigenvalue (WR,WI); otherwise VR and VI need not be set. */
/* On exit, if WI = 0.0 (float eigenvalue), VR contains the */
/* computed float eigenvector; if WI.ne.0.0 (complex eigenvalue), */
/* VR and VI contain the float and imaginary parts of the */
/* computed complex eigenvector. The eigenvector is normalized */
/* so that the component of largest magnitude has magnitude 1; */
/* here the magnitude of a complex number (x,y) is taken to be */
/* |x| + |y|. */
/* VI is not referenced if WI = 0.0. */
/* B (workspace) REAL array, dimension (LDB,N) */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= N+1. */
/* WORK (workspace) REAL array, dimension (N) */
/* EPS3 (input) REAL */
/* A small machine-dependent value which is used to perturb */
/* close eigenvalues, and to replace zero pivots. */
/* SMLNUM (input) REAL */
/* A machine-dependent value close to the underflow threshold. */
/* BIGNUM (input) REAL */
/* A machine-dependent value close to the overflow threshold. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* = 1: inverse iteration did not converge; VR is set to the */
/* last iterate, and so is VI if WI.ne.0.0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--vr;
--vi;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
*info = 0;
/* GROWTO is the threshold used in the acceptance test for an */
/* eigenvector. */
rootn = sqrt((float) (*n));
growto = .1f / rootn;
/* Computing MAX */
r__1 = 1.f, r__2 = *eps3 * rootn;
nrmsml = MAX(r__1,r__2) * *smlnum;
/* Form B = H - (WR,WI)*I (except that the subdiagonal elements and */
/* the imaginary parts of the diagonal elements are not stored). */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
b[i__ + j * b_dim1] = h__[i__ + j * h_dim1];
/* L10: */
}
b[j + j * b_dim1] = h__[j + j * h_dim1] - *wr;
/* L20: */
}
if (*wi == 0.f) {
/* Real eigenvalue. */
if (*noinit) {
/* Set initial vector. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
vr[i__] = *eps3;
/* L30: */
}
} else {
/* Scale supplied initial vector. */
vnorm = snrm2_(n, &vr[1], &c__1);
r__1 = *eps3 * rootn / MAX(vnorm,nrmsml);
sscal_(n, &r__1, &vr[1], &c__1);
}
if (*rightv) {
/* LU decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
ei = h__[i__ + 1 + i__ * h_dim1];
if ((r__1 = b[i__ + i__ * b_dim1], ABS(r__1)) < ABS(ei)) {
/* Interchange rows and eliminate. */
x = b[i__ + i__ * b_dim1] / ei;
b[i__ + i__ * b_dim1] = ei;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
temp = b[i__ + 1 + j * b_dim1];
b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - x *
temp;
b[i__ + j * b_dim1] = temp;
/* L40: */
}
} else {
/* Eliminate without interchange. */
if (b[i__ + i__ * b_dim1] == 0.f) {
b[i__ + i__ * b_dim1] = *eps3;
}
x = ei / b[i__ + i__ * b_dim1];
if (x != 0.f) {
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
b[i__ + 1 + j * b_dim1] -= x * b[i__ + j * b_dim1]
;
/* L50: */
}
}
}
/* L60: */
}
if (b[*n + *n * b_dim1] == 0.f) {
b[*n + *n * b_dim1] = *eps3;
}
*(unsigned char *)trans = 'N';
} else {
/* UL decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
for (j = *n; j >= 2; --j) {
ej = h__[j + (j - 1) * h_dim1];
if ((r__1 = b[j + j * b_dim1], ABS(r__1)) < ABS(ej)) {
/* Interchange columns and eliminate. */
x = b[j + j * b_dim1] / ej;
b[j + j * b_dim1] = ej;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = b[i__ + (j - 1) * b_dim1];
b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - x *
temp;
b[i__ + j * b_dim1] = temp;
/* L70: */
}
} else {
/* Eliminate without interchange. */
if (b[j + j * b_dim1] == 0.f) {
b[j + j * b_dim1] = *eps3;
}
x = ej / b[j + j * b_dim1];
if (x != 0.f) {
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
b[i__ + (j - 1) * b_dim1] -= x * b[i__ + j *
b_dim1];
/* L80: */
}
}
}
/* L90: */
}
if (b[b_dim1 + 1] == 0.f) {
b[b_dim1 + 1] = *eps3;
}
*(unsigned char *)trans = 'T';
}
*(unsigned char *)normin = 'N';
i__1 = *n;
for (its = 1; its <= i__1; ++its) {
/* Solve U*x = scale*v for a right eigenvector */
/* or U'*x = scale*v for a left eigenvector, */
/* overwriting x on v. */
slatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &
vr[1], &scale, &work[1], &ierr);
*(unsigned char *)normin = 'Y';
/* Test for sufficient growth in the norm of v. */
vnorm = sasum_(n, &vr[1], &c__1);
if (vnorm >= growto * scale) {
goto L120;
}
/* Choose new orthogonal starting vector and try again. */
temp = *eps3 / (rootn + 1.f);
vr[1] = *eps3;
i__2 = *n;
for (i__ = 2; i__ <= i__2; ++i__) {
vr[i__] = temp;
/* L100: */
}
vr[*n - its + 1] -= *eps3 * rootn;
/* L110: */
}
/* Failure to find eigenvector in N iterations. */
*info = 1;
L120:
/* Normalize eigenvector. */
i__ = isamax_(n, &vr[1], &c__1);
r__2 = 1.f / (r__1 = vr[i__], ABS(r__1));
sscal_(n, &r__2, &vr[1], &c__1);
} else {
/* Complex eigenvalue. */
if (*noinit) {
/* Set initial vector. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
vr[i__] = *eps3;
vi[i__] = 0.f;
/* L130: */
}
} else {
/* Scale supplied initial vector. */
r__1 = snrm2_(n, &vr[1], &c__1);
r__2 = snrm2_(n, &vi[1], &c__1);
norm = slapy2_(&r__1, &r__2);
rec = *eps3 * rootn / MAX(norm,nrmsml);
sscal_(n, &rec, &vr[1], &c__1);
sscal_(n, &rec, &vi[1], &c__1);
}
if (*rightv) {
/* LU decomposition with partial pivoting of B, replacing zero */
/* pivots by EPS3. */
/* The imaginary part of the (i,j)-th element of U is stored in */
/* B(j+1,i). */
b[b_dim1 + 2] = -(*wi);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
b[i__ + 1 + b_dim1] = 0.f;
/* L140: */
}
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
absbii = slapy2_(&b[i__ + i__ * b_dim1], &b[i__ + 1 + i__ *
b_dim1]);
ei = h__[i__ + 1 + i__ * h_dim1];
if (absbii < ABS(ei)) {
/* Interchange rows and eliminate. */
xr = b[i__ + i__ * b_dim1] / ei;
xi = b[i__ + 1 + i__ * b_dim1] / ei;
b[i__ + i__ * b_dim1] = ei;
b[i__ + 1 + i__ * b_dim1] = 0.f;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
temp = b[i__ + 1 + j * b_dim1];
b[i__ + 1 + j * b_dim1] = b[i__ + j * b_dim1] - xr *
temp;
b[j + 1 + (i__ + 1) * b_dim1] = b[j + 1 + i__ *
b_dim1] - xi * temp;
b[i__ + j * b_dim1] = temp;
b[j + 1 + i__ * b_dim1] = 0.f;
/* L150: */
}
b[i__ + 2 + i__ * b_dim1] = -(*wi);
b[i__ + 1 + (i__ + 1) * b_dim1] -= xi * *wi;
b[i__ + 2 + (i__ + 1) * b_dim1] += xr * *wi;
} else {
/* Eliminate without interchanging rows. */
if (absbii == 0.f) {
b[i__ + i__ * b_dim1] = *eps3;
b[i__ + 1 + i__ * b_dim1] = 0.f;
absbii = *eps3;
}
ei = ei / absbii / absbii;
xr = b[i__ + i__ * b_dim1] * ei;
xi = -b[i__ + 1 + i__ * b_dim1] * ei;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
b[i__ + 1 + j * b_dim1] = b[i__ + 1 + j * b_dim1] -
xr * b[i__ + j * b_dim1] + xi * b[j + 1 + i__
* b_dim1];
b[j + 1 + (i__ + 1) * b_dim1] = -xr * b[j + 1 + i__ *
b_dim1] - xi * b[i__ + j * b_dim1];
/* L160: */
}
b[i__ + 2 + (i__ + 1) * b_dim1] -= *wi;
}
/* Compute 1-norm of offdiagonal elements of i-th row. */
i__2 = *n - i__;
i__3 = *n - i__;
work[i__] = sasum_(&i__2, &b[i__ + (i__ + 1) * b_dim1], ldb)
+ sasum_(&i__3, &b[i__ + 2 + i__ * b_dim1], &c__1);
/* L170: */
}
if (b[*n + *n * b_dim1] == 0.f && b[*n + 1 + *n * b_dim1] == 0.f)
{
b[*n + *n * b_dim1] = *eps3;
}
work[*n] = 0.f;
i1 = *n;
i2 = 1;
i3 = -1;
} else {
/* UL decomposition with partial pivoting of conjg(B), */
/* replacing zero pivots by EPS3. */
/* The imaginary part of the (i,j)-th element of U is stored in */
/* B(j+1,i). */
b[*n + 1 + *n * b_dim1] = *wi;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
b[*n + 1 + j * b_dim1] = 0.f;
/* L180: */
}
for (j = *n; j >= 2; --j) {
ej = h__[j + (j - 1) * h_dim1];
absbjj = slapy2_(&b[j + j * b_dim1], &b[j + 1 + j * b_dim1]);
if (absbjj < ABS(ej)) {
/* Interchange columns and eliminate */
xr = b[j + j * b_dim1] / ej;
xi = b[j + 1 + j * b_dim1] / ej;
b[j + j * b_dim1] = ej;
b[j + 1 + j * b_dim1] = 0.f;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = b[i__ + (j - 1) * b_dim1];
b[i__ + (j - 1) * b_dim1] = b[i__ + j * b_dim1] - xr *
temp;
b[j + i__ * b_dim1] = b[j + 1 + i__ * b_dim1] - xi *
temp;
b[i__ + j * b_dim1] = temp;
b[j + 1 + i__ * b_dim1] = 0.f;
/* L190: */
}
b[j + 1 + (j - 1) * b_dim1] = *wi;
b[j - 1 + (j - 1) * b_dim1] += xi * *wi;
b[j + (j - 1) * b_dim1] -= xr * *wi;
} else {
/* Eliminate without interchange. */
if (absbjj == 0.f) {
b[j + j * b_dim1] = *eps3;
b[j + 1 + j * b_dim1] = 0.f;
absbjj = *eps3;
}
ej = ej / absbjj / absbjj;
xr = b[j + j * b_dim1] * ej;
xi = -b[j + 1 + j * b_dim1] * ej;
i__1 = j - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
b[i__ + (j - 1) * b_dim1] = b[i__ + (j - 1) * b_dim1]
- xr * b[i__ + j * b_dim1] + xi * b[j + 1 +
i__ * b_dim1];
b[j + i__ * b_dim1] = -xr * b[j + 1 + i__ * b_dim1] -
xi * b[i__ + j * b_dim1];
/* L200: */
}
b[j + (j - 1) * b_dim1] += *wi;
}
/* Compute 1-norm of offdiagonal elements of j-th column. */
i__1 = j - 1;
i__2 = j - 1;
work[j] = sasum_(&i__1, &b[j * b_dim1 + 1], &c__1) + sasum_(&
i__2, &b[j + 1 + b_dim1], ldb);
/* L210: */
}
if (b[b_dim1 + 1] == 0.f && b[b_dim1 + 2] == 0.f) {
b[b_dim1 + 1] = *eps3;
}
work[1] = 0.f;
i1 = 1;
i2 = *n;
i3 = 1;
}
i__1 = *n;
for (its = 1; its <= i__1; ++its) {
scale = 1.f;
vmax = 1.f;
vcrit = *bignum;
/* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector, */
/* or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector, */
/* overwriting (xr,xi) on (vr,vi). */
i__2 = i2;
i__3 = i3;
for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3)
{
if (work[i__] > vcrit) {
rec = 1.f / vmax;
sscal_(n, &rec, &vr[1], &c__1);
sscal_(n, &rec, &vi[1], &c__1);
scale *= rec;
vmax = 1.f;
vcrit = *bignum;
}
xr = vr[i__];
xi = vi[i__];
if (*rightv) {
i__4 = *n;
for (j = i__ + 1; j <= i__4; ++j) {
xr = xr - b[i__ + j * b_dim1] * vr[j] + b[j + 1 + i__
* b_dim1] * vi[j];
xi = xi - b[i__ + j * b_dim1] * vi[j] - b[j + 1 + i__
* b_dim1] * vr[j];
/* L220: */
}
} else {
i__4 = i__ - 1;
for (j = 1; j <= i__4; ++j) {
xr = xr - b[j + i__ * b_dim1] * vr[j] + b[i__ + 1 + j
* b_dim1] * vi[j];
xi = xi - b[j + i__ * b_dim1] * vi[j] - b[i__ + 1 + j
* b_dim1] * vr[j];
/* L230: */
}
}
w = (r__1 = b[i__ + i__ * b_dim1], ABS(r__1)) + (r__2 = b[
i__ + 1 + i__ * b_dim1], ABS(r__2));
if (w > *smlnum) {
if (w < 1.f) {
w1 = ABS(xr) + ABS(xi);
if (w1 > w * *bignum) {
rec = 1.f / w1;
sscal_(n, &rec, &vr[1], &c__1);
sscal_(n, &rec, &vi[1], &c__1);
xr = vr[i__];
xi = vi[i__];
scale *= rec;
vmax *= rec;
}
}
/* Divide by diagonal element of B. */
sladiv_(&xr, &xi, &b[i__ + i__ * b_dim1], &b[i__ + 1 +
i__ * b_dim1], &vr[i__], &vi[i__]);
/* Computing MAX */
r__3 = (r__1 = vr[i__], ABS(r__1)) + (r__2 = vi[i__],
ABS(r__2));
vmax = MAX(r__3,vmax);
vcrit = *bignum / vmax;
} else {
i__4 = *n;
for (j = 1; j <= i__4; ++j) {
vr[j] = 0.f;
vi[j] = 0.f;
/* L240: */
}
vr[i__] = 1.f;
vi[i__] = 1.f;
scale = 0.f;
vmax = 1.f;
vcrit = *bignum;
}
/* L250: */
}
/* Test for sufficient growth in the norm of (VR,VI). */
vnorm = sasum_(n, &vr[1], &c__1) + sasum_(n, &vi[1], &c__1);
if (vnorm >= growto * scale) {
goto L280;
}
/* Choose a new orthogonal starting vector and try again. */
y = *eps3 / (rootn + 1.f);
vr[1] = *eps3;
vi[1] = 0.f;
i__3 = *n;
for (i__ = 2; i__ <= i__3; ++i__) {
vr[i__] = y;
vi[i__] = 0.f;
/* L260: */
}
vr[*n - its + 1] -= *eps3 * rootn;
/* L270: */
}
/* Failure to find eigenvector in N iterations */
*info = 1;
L280:
/* Normalize eigenvector. */
vnorm = 0.f;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__3 = vnorm, r__4 = (r__1 = vr[i__], ABS(r__1)) + (r__2 = vi[
i__], ABS(r__2));
vnorm = MAX(r__3,r__4);
/* L290: */
}
r__1 = 1.f / vnorm;
sscal_(n, &r__1, &vr[1], &c__1);
r__1 = 1.f / vnorm;
sscal_(n, &r__1, &vi[1], &c__1);
}
return 0;
/* End of SLAEIN */
} /* slaein_ */
int spocon_(char *uplo, int *n, float *a, int *lda,
float *anorm, float *rcond, float *work, int *iwork, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1;
float r__1;
/* Local variables */
int ix, kase;
float scale;
extern int lsame_(char *, char *);
int isave[3];
extern int srscl_(int *, float *, float *, int *);
int upper;
extern int slacn2_(int *, float *, float *, int *,
float *, int *, int *);
float scalel;
extern double slamch_(char *);
float scaleu;
extern int xerbla_(char *, int *);
extern int isamax_(int *, float *, int *);
float ainvnm;
char normin[1];
extern int slatrs_(char *, char *, char *, char *,
int *, float *, int *, float *, float *, float *, int *);
float smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPOCON estimates the reciprocal of the condition number (in the */
/* 1-norm) of a float symmetric positive definite matrix using the */
/* Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF. */
/* 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. */
/* A (input) REAL array, dimension (LDA,N) */
/* The triangular factor U or L from the Cholesky factorization */
/* A = U**T*U or A = L*L**T, as computed by SPOTRF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,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 .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < MAX(1,*n)) {
*info = -4;
} else if (*anorm < 0.f) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPOCON", &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 1-norm of inv(A). */
kase = 0;
*(unsigned char *)normin = 'N';
L10:
slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
if (kase != 0) {
if (upper) {
/* Multiply by inv(U'). */
slatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset],
lda, &work[1], &scalel, &work[(*n << 1) + 1], info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
slatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &scaleu, &work[(*n << 1) + 1],
info);
} else {
/* Multiply by inv(L). */
slatrs_("Lower", "No transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &scalel, &work[(*n << 1) + 1],
info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
slatrs_("Lower", "Transpose", "Non-unit", normin, n, &a[a_offset],
lda, &work[1], &scaleu, &work[(*n << 1) + 1], info);
}
/* 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], ABS(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 SPOCON */
} /* spocon_ */
/* Subroutine */ int spocon_(char *uplo, 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
March 31, 1993
Purpose
=======
SPOCON estimates the reciprocal of the condition number (in the
1-norm) of a real symmetric positive definite matrix using the
Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF.
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.
A (input) REAL array, dimension (LDA,N)
The triangular factor U or L from the Cholesky factorization
A = U**T*U or A = L*L**T, as computed by SPOTRF.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,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
=====================================================================
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;
static real scale;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
static logical upper;
static integer ix;
static real scalel;
extern doublereal slamch_(char *);
static real scaleu;
extern /* Subroutine */ int xerbla_(char *, integer *), slacon_(
integer *, real *, real *, integer *, real *, integer *);
extern integer isamax_(integer *, real *, integer *);
static real ainvnm;
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;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
} else if (*anorm < 0.f) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPOCON", &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 1-norm of inv(A). */
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'). */
slatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset],
lda, &work[1], &scalel, &work[(*n << 1) + 1], info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(U). */
slatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &scaleu, &work[(*n << 1) + 1],
info);
} else {
/* Multiply by inv(L). */
slatrs_("Lower", "No transpose", "Non-unit", normin, n, &a[
a_offset], lda, &work[1], &scalel, &work[(*n << 1) + 1],
info);
*(unsigned char *)normin = 'Y';
/* Multiply by inv(L'). */
slatrs_("Lower", "Transpose", "Non-unit", normin, n, &a[a_offset],
lda, &work[1], &scaleu, &work[(*n << 1) + 1], info);
}
/* 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 SPOCON */
} /* spocon_ */
/* Subroutine */
int strcon_(char *norm, char *uplo, char *diag, integer *n, real *a, integer *lda, real *rcond, real *work, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1;
real r__1;
/* Local variables */
integer ix, kase, kase1;
real scale;
extern logical lsame_(char *, char *);
integer isave[3];
real anorm;
extern /* Subroutine */
int srscl_(integer *, real *, real *, integer *);
logical upper;
real xnorm;
extern /* Subroutine */
int slacn2_(integer *, real *, real *, integer *, real *, integer *, integer *);
extern real slamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
extern integer isamax_(integer *, real *, integer *);
real ainvnm;
logical onenrm;
char normin[1];
extern real slantr_(char *, char *, char *, integer *, integer *, real *, integer *, real *);
extern /* Subroutine */
int slatrs_(char *, char *, char *, char *, integer *, real *, integer *, real *, real *, real *, integer *);
real smlnum;
logical nounit;
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
--iwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
nounit = lsame_(diag, "N");
if (! onenrm && ! lsame_(norm, "I"))
{
*info = -1;
}
else if (! upper && ! lsame_(uplo, "L"))
{
*info = -2;
}
else if (! nounit && ! lsame_(diag, "U"))
{
*info = -3;
}
else if (*n < 0)
{
*info = -4;
}
else if (*lda < max(1,*n))
{
*info = -6;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("STRCON", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
*rcond = 1.f;
return 0;
}
*rcond = 0.f;
smlnum = slamch_("Safe minimum") * (real) max(1,*n);
/* Compute the norm of the triangular matrix A. */
anorm = slantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &work[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:
slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
if (kase != 0)
{
if (kase == kase1)
{
/* Multiply by inv(A). */
slatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset], lda, &work[1], &scale, &work[(*n << 1) + 1], info);
}
else
{
/* Multiply by inv(A**T). */
slatrs_(uplo, "Transpose", diag, normin, n, &a[a_offset], lda, &work[1], &scale, &work[(*n << 1) + 1], info);
}
*(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], f2c_abs(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 STRCON */
}
/* Subroutine */ int serrtr_(char *path, integer *nunit)
{
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
real a[4] /* was [2][2] */, b[2], w[2], x[2];
char c2[2];
real r1[2], r2[2];
integer iw[2], info;
real scale, rcond;
extern /* Subroutine */ int strti2_(char *, char *, integer *, real *,
integer *, integer *), alaesm_(char *, logical *,
integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), slatbs_(char *, char *, char *, char *,
integer *, integer *, real *, integer *, real *, real *, real *,
integer *), stbcon_(char *, char *
, char *, integer *, integer *, real *, integer *, real *, real *,
integer *, integer *), stbrfs_(char *,
char *, char *, integer *, integer *, integer *, real *, integer *
, real *, integer *, real *, integer *, real *, real *, real *,
integer *, integer *), slatps_(char *,
char *, char *, char *, integer *, real *, real *, real *, real *,
integer *), stpcon_(char *, char
*, char *, integer *, real *, real *, real *, integer *, integer *
), slatrs_(char *, char *, char *, char *,
integer *, real *, integer *, real *, real *, real *, integer *), strcon_(char *, char *, char *,
integer *, real *, integer *, real *, real *, integer *, integer *
), stbtrs_(char *, char *, char *,
integer *, integer *, integer *, real *, integer *, real *,
integer *, integer *), stprfs_(char *,
char *, char *, integer *, integer *, real *, real *, integer *,
real *, integer *, real *, real *, real *, integer *, integer *), strrfs_(char *, char *, char *, integer *
, integer *, real *, integer *, real *, integer *, real *,
integer *, real *, real *, real *, integer *, integer *), stptri_(char *, char *, integer *, real *,
integer *), strtri_(char *, char *, integer *,
real *, integer *, integer *), stptrs_(char *,
char *, char *, integer *, integer *, real *, real *, integer *,
integer *), strtrs_(char *, char *, char *
, integer *, integer *, real *, integer *, real *, integer *,
integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SERRTR tests the error exits for the REAL triangular */
/* routines. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
a[0] = 1.f;
a[2] = 2.f;
a[3] = 3.f;
a[1] = 4.f;
infoc_1.ok = TRUE_;
if (lsamen_(&c__2, c2, "TR")) {
/* Test error exits for the general triangular routines. */
/* STRTRI */
s_copy(srnamc_1.srnamt, "STRTRI", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
strtri_("/", "N", &c__0, a, &c__1, &info);
chkxer_("STRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strtri_("U", "/", &c__0, a, &c__1, &info);
chkxer_("STRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
strtri_("U", "N", &c_n1, a, &c__1, &info);
chkxer_("STRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
strtri_("U", "N", &c__2, a, &c__1, &info);
chkxer_("STRTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STRTI2 */
s_copy(srnamc_1.srnamt, "STRTI2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
strti2_("/", "N", &c__0, a, &c__1, &info);
chkxer_("STRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strti2_("U", "/", &c__0, a, &c__1, &info);
chkxer_("STRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
strti2_("U", "N", &c_n1, a, &c__1, &info);
chkxer_("STRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
strti2_("U", "N", &c__2, a, &c__1, &info);
chkxer_("STRTI2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STRTRS */
s_copy(srnamc_1.srnamt, "STRTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
strtrs_("/", "N", "N", &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strtrs_("U", "/", "N", &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
strtrs_("U", "N", "/", &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strtrs_("U", "N", "N", &c_n1, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
strtrs_("U", "N", "N", &c__0, &c_n1, a, &c__1, x, &c__1, &info);
chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
strtrs_("U", "N", "N", &c__2, &c__1, a, &c__1, x, &c__2, &info);
chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
strtrs_("U", "N", "N", &c__2, &c__1, a, &c__2, x, &c__1, &info);
chkxer_("STRTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STRRFS */
s_copy(srnamc_1.srnamt, "STRRFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
strrfs_("/", "N", "N", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, iw, &info);
chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strrfs_("U", "/", "N", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, iw, &info);
chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
strrfs_("U", "N", "/", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, iw, &info);
chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strrfs_("U", "N", "N", &c_n1, &c__0, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, iw, &info);
chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
strrfs_("U", "N", "N", &c__0, &c_n1, a, &c__1, b, &c__1, x, &c__1, r1,
r2, w, iw, &info);
chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
strrfs_("U", "N", "N", &c__2, &c__1, a, &c__1, b, &c__2, x, &c__2, r1,
r2, w, iw, &info);
chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
strrfs_("U", "N", "N", &c__2, &c__1, a, &c__2, b, &c__1, x, &c__2, r1,
r2, w, iw, &info);
chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
strrfs_("U", "N", "N", &c__2, &c__1, a, &c__2, b, &c__2, x, &c__1, r1,
r2, w, iw, &info);
chkxer_("STRRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STRCON */
s_copy(srnamc_1.srnamt, "STRCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
strcon_("/", "U", "N", &c__0, a, &c__1, &rcond, w, iw, &info);
chkxer_("STRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
strcon_("1", "/", "N", &c__0, a, &c__1, &rcond, w, iw, &info);
chkxer_("STRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
strcon_("1", "U", "/", &c__0, a, &c__1, &rcond, w, iw, &info);
chkxer_("STRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
strcon_("1", "U", "N", &c_n1, a, &c__1, &rcond, w, iw, &info);
chkxer_("STRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
strcon_("1", "U", "N", &c__2, a, &c__1, &rcond, w, iw, &info);
chkxer_("STRCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SLATRS */
s_copy(srnamc_1.srnamt, "SLATRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
slatrs_("/", "N", "N", "N", &c__0, a, &c__1, x, &scale, w, &info);
chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
slatrs_("U", "/", "N", "N", &c__0, a, &c__1, x, &scale, w, &info);
chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
slatrs_("U", "N", "/", "N", &c__0, a, &c__1, x, &scale, w, &info);
chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
slatrs_("U", "N", "N", "/", &c__0, a, &c__1, x, &scale, w, &info);
chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
slatrs_("U", "N", "N", "N", &c_n1, a, &c__1, x, &scale, w, &info);
chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
slatrs_("U", "N", "N", "N", &c__2, a, &c__1, x, &scale, w, &info);
chkxer_("SLATRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "TP")) {
/* Test error exits for the packed triangular routines. */
/* STPTRI */
s_copy(srnamc_1.srnamt, "STPTRI", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
stptri_("/", "N", &c__0, a, &info);
chkxer_("STPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
stptri_("U", "/", &c__0, a, &info);
chkxer_("STPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
stptri_("U", "N", &c_n1, a, &info);
chkxer_("STPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STPTRS */
s_copy(srnamc_1.srnamt, "STPTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
stptrs_("/", "N", "N", &c__0, &c__0, a, x, &c__1, &info);
chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
stptrs_("U", "/", "N", &c__0, &c__0, a, x, &c__1, &info);
chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
stptrs_("U", "N", "/", &c__0, &c__0, a, x, &c__1, &info);
chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
stptrs_("U", "N", "N", &c_n1, &c__0, a, x, &c__1, &info);
chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
stptrs_("U", "N", "N", &c__0, &c_n1, a, x, &c__1, &info);
chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
stptrs_("U", "N", "N", &c__2, &c__1, a, x, &c__1, &info);
chkxer_("STPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STPRFS */
s_copy(srnamc_1.srnamt, "STPRFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
stprfs_("/", "N", "N", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
iw, &info);
chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
stprfs_("U", "/", "N", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
iw, &info);
chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
stprfs_("U", "N", "/", &c__0, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
iw, &info);
chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
stprfs_("U", "N", "N", &c_n1, &c__0, a, b, &c__1, x, &c__1, r1, r2, w,
iw, &info);
chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
stprfs_("U", "N", "N", &c__0, &c_n1, a, b, &c__1, x, &c__1, r1, r2, w,
iw, &info);
chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
stprfs_("U", "N", "N", &c__2, &c__1, a, b, &c__1, x, &c__2, r1, r2, w,
iw, &info);
chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
stprfs_("U", "N", "N", &c__2, &c__1, a, b, &c__2, x, &c__1, r1, r2, w,
iw, &info);
chkxer_("STPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STPCON */
s_copy(srnamc_1.srnamt, "STPCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
stpcon_("/", "U", "N", &c__0, a, &rcond, w, iw, &info);
chkxer_("STPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
stpcon_("1", "/", "N", &c__0, a, &rcond, w, iw, &info);
chkxer_("STPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
stpcon_("1", "U", "/", &c__0, a, &rcond, w, iw, &info);
chkxer_("STPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
stpcon_("1", "U", "N", &c_n1, a, &rcond, w, iw, &info);
chkxer_("STPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SLATPS */
s_copy(srnamc_1.srnamt, "SLATPS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
slatps_("/", "N", "N", "N", &c__0, a, x, &scale, w, &info);
chkxer_("SLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
slatps_("U", "/", "N", "N", &c__0, a, x, &scale, w, &info);
chkxer_("SLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
slatps_("U", "N", "/", "N", &c__0, a, x, &scale, w, &info);
chkxer_("SLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
slatps_("U", "N", "N", "/", &c__0, a, x, &scale, w, &info);
chkxer_("SLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
slatps_("U", "N", "N", "N", &c_n1, a, x, &scale, w, &info);
chkxer_("SLATPS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
} else if (lsamen_(&c__2, c2, "TB")) {
/* Test error exits for the banded triangular routines. */
/* STBTRS */
s_copy(srnamc_1.srnamt, "STBTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
stbtrs_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
stbtrs_("U", "/", "N", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
stbtrs_("U", "N", "/", &c__0, &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
stbtrs_("U", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
stbtrs_("U", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, x, &c__1, &info);
chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
stbtrs_("U", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, x, &c__1, &info);
chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
stbtrs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__1, x, &c__2, &info);
chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
stbtrs_("U", "N", "N", &c__2, &c__0, &c__1, a, &c__1, x, &c__1, &info);
chkxer_("STBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STBRFS */
s_copy(srnamc_1.srnamt, "STBRFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
stbrfs_("/", "N", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
stbrfs_("U", "/", "N", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
stbrfs_("U", "N", "/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
stbrfs_("U", "N", "N", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
stbrfs_("U", "N", "N", &c__0, &c_n1, &c__0, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
stbrfs_("U", "N", "N", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
stbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__1, b, &c__2, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
stbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__1, x, &
c__2, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
stbrfs_("U", "N", "N", &c__2, &c__1, &c__1, a, &c__2, b, &c__2, x, &
c__1, r1, r2, w, iw, &info);
chkxer_("STBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* STBCON */
s_copy(srnamc_1.srnamt, "STBCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
stbcon_("/", "U", "N", &c__0, &c__0, a, &c__1, &rcond, w, iw, &info);
chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
stbcon_("1", "/", "N", &c__0, &c__0, a, &c__1, &rcond, w, iw, &info);
chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
stbcon_("1", "U", "/", &c__0, &c__0, a, &c__1, &rcond, w, iw, &info);
chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
stbcon_("1", "U", "N", &c_n1, &c__0, a, &c__1, &rcond, w, iw, &info);
chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
stbcon_("1", "U", "N", &c__0, &c_n1, a, &c__1, &rcond, w, iw, &info);
chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
stbcon_("1", "U", "N", &c__2, &c__1, a, &c__1, &rcond, w, iw, &info);
chkxer_("STBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* SLATBS */
s_copy(srnamc_1.srnamt, "SLATBS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
slatbs_("/", "N", "N", "N", &c__0, &c__0, a, &c__1, x, &scale, w, &
info);
chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
slatbs_("U", "/", "N", "N", &c__0, &c__0, a, &c__1, x, &scale, w, &
info);
chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
slatbs_("U", "N", "/", "N", &c__0, &c__0, a, &c__1, x, &scale, w, &
info);
chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
slatbs_("U", "N", "N", "/", &c__0, &c__0, a, &c__1, x, &scale, w, &
info);
chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
slatbs_("U", "N", "N", "N", &c_n1, &c__0, a, &c__1, x, &scale, w, &
info);
chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
slatbs_("U", "N", "N", "N", &c__1, &c_n1, a, &c__1, x, &scale, w, &
info);
chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
slatbs_("U", "N", "N", "N", &c__2, &c__1, a, &c__1, x, &scale, w, &
info);
chkxer_("SLATBS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of SERRTR */
} /* serrtr_ */
