/* Subroutine */ int csysvx_(char *fact, char *uplo, integer *n, integer *
nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond,
real *ferr, real *berr, complex *work, integer *lwork, real *rwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2;
/* Local variables */
integer nb;
extern logical lsame_(char *, char *);
real anorm;
extern doublereal slamch_(char *);
logical nofact;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
real *);
extern /* Subroutine */ int csycon_(char *, integer *, complex *, integer
*, integer *, real *, real *, complex *, integer *),
csyrfs_(char *, integer *, integer *, complex *, integer *,
complex *, integer *, integer *, complex *, integer *, complex *,
integer *, real *, real *, complex *, real *, integer *),
csytrf_(char *, integer *, complex *, integer *, integer *,
complex *, integer *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex
*, integer *, integer *, complex *, integer *, integer *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CSYSVX uses the diagonal pivoting factorization to compute the */
/* solution to a complex system of linear equations A * X = B, */
/* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
/* matrices. */
/* Error bounds on the solution and a condition estimate are also */
/* provided. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A. */
/* The form of the factorization is */
/* A = U * D * U**T, if UPLO = 'U', or */
/* A = L * D * L**T, if UPLO = 'L', */
/* 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. */
/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
/* returns with INFO = i. Otherwise, the factored form of A is used */
/* to estimate the condition number of the matrix A. If the */
/* reciprocal of the condition number is less than machine precision, */
/* INFO = N+1 is returned as a warning, but the routine still goes on */
/* to solve for X and compute error bounds as described below. */
/* 3. The system of equations is solved for X using the factored form */
/* of A. */
/* 4. Iterative refinement is applied to improve the computed solution */
/* matrix and calculate error bounds and backward error estimates */
/* for it. */
/* Arguments */
/* ========= */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of A has been */
/* supplied on entry. */
/* = 'F': On entry, AF and IPIV contain the factored form */
/* of A. A, AF and IPIV will not be modified. */
/* = 'N': The matrix A will be copied to AF and factored. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input) COMPLEX 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). */
/* AF (input or output) COMPLEX array, dimension (LDAF,N) */
/* If FACT = 'F', then AF is an input argument and on entry */
/* contains the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L from the factorization */
/* A = U*D*U**T or A = L*D*L**T as computed by CSYTRF. */
/* If FACT = 'N', then AF is an output argument and on exit */
/* returns the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L from the factorization */
/* A = U*D*U**T or A = L*D*L**T. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input or output) INTEGER array, dimension (N) */
/* If FACT = 'F', then IPIV is an input argument and on entry */
/* contains details of the interchanges and the block structure */
/* of D, as determined by CSYTRF. */
/* 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. */
/* If FACT = 'N', then IPIV is an output argument and on exit */
/* contains details of the interchanges and the block structure */
/* of D, as determined by CSYTRF. */
/* B (input) COMPLEX array, dimension (LDB,NRHS) */
/* The N-by-NRHS right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) COMPLEX array, dimension (LDX,NRHS) */
/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) REAL */
/* The estimate of the reciprocal condition number of the matrix */
/* A. If RCOND is less than the machine precision (in */
/* particular, if RCOND = 0), the matrix is singular to working */
/* precision. This condition is indicated by a return code of */
/* INFO > 0. */
/* FERR (output) REAL array, dimension (NRHS) */
/* The estimated 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). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* 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/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of WORK. LWORK >= max(1,2*N), and for best */
/* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where */
/* NB is the optimal blocksize for CSYTRF. */
/* 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 (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, and i is */
/* <= N: D(i,i) is exactly zero. The factorization */
/* has been completed but the factor D is exactly */
/* singular, so the solution and error bounds could */
/* not be computed. RCOND = 0 is returned. */
/* = N+1: D is nonsingular, but RCOND is less than machine */
/* precision, meaning that the matrix is singular */
/* to working precision. Nevertheless, the */
/* solution and error bounds are computed because */
/* there are a number of situations where the */
/* computed solution can be more accurate than the */
/* value of RCOND would suggest. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
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;
--rwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
lquery = *lwork == -1;
if (! nofact && ! lsame_(fact, "F")) {
*info = -1;
} else if (! lsame_(uplo, "U") && ! lsame_(uplo,
"L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (*ldb < max(1,*n)) {
*info = -11;
} else if (*ldx < max(1,*n)) {
*info = -13;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -18;
}
}
if (*info == 0) {
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
lwkopt = max(i__1,i__2);
if (nofact) {
nb = ilaenv_(&c__1, "CSYTRF", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = lwkopt, i__2 = *n * nb;
lwkopt = max(i__1,i__2);
}
work[1].r = (real) lwkopt, work[1].i = 0.f;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CSYSVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
if (nofact) {
/* Compute the factorization A = U*D*U' or A = L*D*L'. */
clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
csytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], lwork,
info);
/* Return if INFO is non-zero. */
if (*info > 0) {
*rcond = 0.f;
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = clansy_("I", uplo, n, &a[a_offset], lda, &rwork[1]);
/* Compute the reciprocal of the condition number of A. */
csycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
info);
/* Compute the solution vectors X. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
csytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
info);
/* Use iterative refinement to improve the computed solutions and */
/* compute error bounds and backward error estimates for them. */
csyrfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1],
&b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1]
, &rwork[1], info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon")) {
*info = *n + 1;
}
work[1].r = (real) lwkopt, work[1].i = 0.f;
return 0;
/* End of CSYSVX */
} /* csysvx_ */
/* Subroutine */ int cstt22_(integer *n, integer *m, integer *kband, real *ad,
real *ae, real *sd, real *se, complex *u, integer *ldu, complex *
work, integer *ldwork, real *rwork, real *result)
{
/* System generated locals */
integer u_dim1, u_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4,
i__5, i__6;
real r__1, r__2, r__3, r__4, r__5;
complex q__1, q__2;
/* Local variables */
static complex aukj;
static real unfl;
static integer i__, j, k;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
static real anorm, wnorm;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), slamch_(char *), clansy_(char
*, char *, integer *, complex *, integer *, real *);
static real ulp;
#define work_subscr(a_1,a_2) (a_2)*work_dim1 + a_1
#define work_ref(a_1,a_2) work[work_subscr(a_1,a_2)]
#define u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1
#define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CSTT22 checks a set of M eigenvalues and eigenvectors,
A U = U S
where A is Hermitian tridiagonal, the columns of U are unitary,
and S is diagonal (if KBAND=0) or Hermitian tridiagonal (if KBAND=1).
Two tests are performed:
RESULT(1) = | U* A U - S | / ( |A| m ulp )
RESULT(2) = | I - U*U | / ( m ulp )
Arguments
=========
N (input) INTEGER
The size of the matrix. If it is zero, CSTT22 does nothing.
It must be at least zero.
M (input) INTEGER
The number of eigenpairs to check. If it is zero, CSTT22
does nothing. It must be at least zero.
KBAND (input) INTEGER
The bandwidth of the matrix S. It may only be zero or one.
If zero, then S is diagonal, and SE is not referenced. If
one, then S is Hermitian tri-diagonal.
AD (input) REAL array, dimension (N)
The diagonal of the original (unfactored) matrix A. A is
assumed to be Hermitian tridiagonal.
AE (input) REAL array, dimension (N)
The off-diagonal of the original (unfactored) matrix A. A
is assumed to be Hermitian tridiagonal. AE(1) is ignored,
AE(2) is the (1,2) and (2,1) element, etc.
SD (input) REAL array, dimension (N)
The diagonal of the (Hermitian tri-) diagonal matrix S.
SE (input) REAL array, dimension (N)
The off-diagonal of the (Hermitian tri-) diagonal matrix S.
Not referenced if KBSND=0. If KBAND=1, then AE(1) is
ignored, SE(2) is the (1,2) and (2,1) element, etc.
U (input) REAL array, dimension (LDU, N)
The unitary matrix in the decomposition.
LDU (input) INTEGER
The leading dimension of U. LDU must be at least N.
WORK (workspace) COMPLEX array, dimension (LDWORK, M+1)
LDWORK (input) INTEGER
The leading dimension of WORK. LDWORK must be at least
max(1,M).
RWORK (workspace) REAL array, dimension (N)
RESULT (output) REAL array, dimension (2)
The values computed by the two tests described above. The
values are currently limited to 1/ulp, to avoid overflow.
=====================================================================
Parameter adjustments */
--ad;
--ae;
--sd;
--se;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1 * 1;
work -= work_offset;
--rwork;
--result;
/* Function Body */
result[1] = 0.f;
result[2] = 0.f;
if (*n <= 0 || *m <= 0) {
return 0;
}
unfl = slamch_("Safe minimum");
ulp = slamch_("Epsilon");
/* Do Test 1
Compute the 1-norm of A. */
if (*n > 1) {
anorm = dabs(ad[1]) + dabs(ae[1]);
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
/* Computing MAX */
r__4 = anorm, r__5 = (r__1 = ad[j], dabs(r__1)) + (r__2 = ae[j],
dabs(r__2)) + (r__3 = ae[j - 1], dabs(r__3));
anorm = dmax(r__4,r__5);
/* L10: */
}
/* Computing MAX */
r__3 = anorm, r__4 = (r__1 = ad[*n], dabs(r__1)) + (r__2 = ae[*n - 1],
dabs(r__2));
anorm = dmax(r__3,r__4);
} else {
anorm = dabs(ad[1]);
}
anorm = dmax(anorm,unfl);
/* Norm of U*AU - S */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *m;
for (j = 1; j <= i__2; ++j) {
i__3 = work_subscr(i__, j);
work[i__3].r = 0.f, work[i__3].i = 0.f;
i__3 = *n;
for (k = 1; k <= i__3; ++k) {
i__4 = k;
i__5 = u_subscr(k, j);
q__1.r = ad[i__4] * u[i__5].r, q__1.i = ad[i__4] * u[i__5].i;
aukj.r = q__1.r, aukj.i = q__1.i;
if (k != *n) {
i__4 = k;
i__5 = u_subscr(k + 1, j);
q__2.r = ae[i__4] * u[i__5].r, q__2.i = ae[i__4] * u[i__5]
.i;
q__1.r = aukj.r + q__2.r, q__1.i = aukj.i + q__2.i;
aukj.r = q__1.r, aukj.i = q__1.i;
}
if (k != 1) {
i__4 = k - 1;
i__5 = u_subscr(k - 1, j);
q__2.r = ae[i__4] * u[i__5].r, q__2.i = ae[i__4] * u[i__5]
.i;
q__1.r = aukj.r + q__2.r, q__1.i = aukj.i + q__2.i;
aukj.r = q__1.r, aukj.i = q__1.i;
}
i__4 = work_subscr(i__, j);
i__5 = work_subscr(i__, j);
i__6 = u_subscr(k, i__);
q__2.r = u[i__6].r * aukj.r - u[i__6].i * aukj.i, q__2.i = u[
i__6].r * aukj.i + u[i__6].i * aukj.r;
q__1.r = work[i__5].r + q__2.r, q__1.i = work[i__5].i +
q__2.i;
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
/* L20: */
}
/* L30: */
}
i__2 = work_subscr(i__, i__);
i__3 = work_subscr(i__, i__);
i__4 = i__;
q__1.r = work[i__3].r - sd[i__4], q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
if (*kband == 1) {
if (i__ != 1) {
i__2 = work_subscr(i__, i__ - 1);
i__3 = work_subscr(i__, i__ - 1);
i__4 = i__ - 1;
q__1.r = work[i__3].r - se[i__4], q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
}
if (i__ != *n) {
i__2 = work_subscr(i__, i__ + 1);
i__3 = work_subscr(i__, i__ + 1);
i__4 = i__;
q__1.r = work[i__3].r - se[i__4], q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
}
}
/* L40: */
}
wnorm = clansy_("1", "L", m, &work[work_offset], m, &rwork[1]);
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*m * ulp);
} else {
if (anorm < 1.f) {
/* Computing MIN */
r__1 = wnorm, r__2 = *m * anorm;
result[1] = dmin(r__1,r__2) / anorm / (*m * ulp);
} else {
/* Computing MIN */
r__1 = wnorm / anorm, r__2 = (real) (*m);
result[1] = dmin(r__1,r__2) / (*m * ulp);
}
}
/* Do Test 2
Compute U*U - I */
cgemm_("T", "N", m, m, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu, &
c_b1, &work[work_offset], m);
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = work_subscr(j, j);
i__3 = work_subscr(j, j);
q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L50: */
}
/* Computing MIN */
r__1 = (real) (*m), r__2 = clange_("1", m, m, &work[work_offset], m, &
rwork[1]);
result[2] = dmin(r__1,r__2) / (*m * ulp);
return 0;
/* End of CSTT22 */
} /* cstt22_ */
/* Subroutine */ int cheevr_(char *jobz, char *range, char *uplo, integer *n,
complex *a, integer *lda, real *vl, real *vu, integer *il, integer *
iu, real *abstol, integer *m, real *w, complex *z__, integer *ldz,
integer *isuppz, complex *work, integer *lwork, real *rwork, integer *
lrwork, integer *iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, nb, jj;
real eps, vll, vuu, tmp1, anrm;
integer imax;
real rmin, rmax;
logical test;
integer itmp1, indrd, indre;
real sigma;
extern logical lsame_(char *, char *);
integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
char order[1];
integer indwk;
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
integer lwmin;
logical lower;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
logical wantz, alleig, indeig;
integer iscale, ieeeok, indibl, indrdd, indifl, indree;
logical valeig;
extern doublereal slamch_(char *);
extern /* Subroutine */ int chetrd_(char *, integer *, complex *, integer
*, real *, real *, complex *, complex *, integer *, integer *), csscal_(integer *, real *, complex *, integer *);
real safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
real abstll, bignum;
integer indtau, indisp;
extern /* Subroutine */ int cstein_(integer *, real *, real *, integer *,
real *, integer *, integer *, complex *, integer *, real *,
integer *, integer *, integer *);
integer indiwo, indwkn;
extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
real *);
extern /* Subroutine */ int cstemr_(char *, char *, integer *, real *,
real *, real *, real *, integer *, integer *, integer *, real *,
complex *, integer *, integer *, integer *, logical *, real *,
integer *, integer *, integer *, integer *);
integer indrwk, liwmin;
logical tryrac;
extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
integer lrwmin, llwrkn, llwork, nsplit;
real smlnum;
extern /* Subroutine */ int cunmtr_(char *, char *, char *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, integer *), sstebz_(
char *, char *, integer *, real *, real *, integer *, integer *,
real *, real *, real *, integer *, integer *, real *, integer *,
integer *, real *, integer *, integer *);
logical lquery;
integer lwkopt, llrwork;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHEEVR computes selected eigenvalues and, optionally, eigenvectors */
/* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can */
/* be selected by specifying either a range of values or a range of */
/* indices for the desired eigenvalues. */
/* CHEEVR first reduces the matrix A to tridiagonal form T with a call */
/* to CHETRD. Then, whenever possible, CHEEVR calls CSTEMR to compute */
/* the eigenspectrum using Relatively Robust Representations. CSTEMR */
/* computes eigenvalues by the dqds algorithm, while orthogonal */
/* eigenvectors are computed from various "good" L D L^T representations */
/* (also known as Relatively Robust Representations). Gram-Schmidt */
/* orthogonalization is avoided as far as possible. More specifically, */
/* the various steps of the algorithm are as follows. */
/* For each unreduced block (submatrix) of T, */
/* (a) Compute T - sigma I = L D L^T, so that L and D */
/* define all the wanted eigenvalues to high relative accuracy. */
/* This means that small relative changes in the entries of D and L */
/* cause only small relative changes in the eigenvalues and */
/* eigenvectors. The standard (unfactored) representation of the */
/* tridiagonal matrix T does not have this property in general. */
/* (b) Compute the eigenvalues to suitable accuracy. */
/* If the eigenvectors are desired, the algorithm attains full */
/* accuracy of the computed eigenvalues only right before */
/* the corresponding vectors have to be computed, see steps c) and d). */
/* (c) For each cluster of close eigenvalues, select a new */
/* shift close to the cluster, find a new factorization, and refine */
/* the shifted eigenvalues to suitable accuracy. */
/* (d) For each eigenvalue with a large enough relative separation compute */
/* the corresponding eigenvector by forming a rank revealing twisted */
/* factorization. Go back to (c) for any clusters that remain. */
/* The desired accuracy of the output can be specified by the input */
/* parameter ABSTOL. */
/* For more details, see DSTEMR's documentation and: */
/* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */
/* to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */
/* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */
/* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */
/* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */
/* 2004. Also LAPACK Working Note 154. */
/* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */
/* tridiagonal eigenvalue/eigenvector problem", */
/* Computer Science Division Technical Report No. UCB/CSD-97-971, */
/* UC Berkeley, May 1997. */
/* Note 1 : CHEEVR calls CSTEMR when the full spectrum is requested */
/* on machines which conform to the ieee-754 floating point standard. */
/* CHEEVR calls SSTEBZ and CSTEIN on non-ieee machines and */
/* when partial spectrum requests are made. */
/* Normal execution of CSTEMR may create NaNs and infinities and */
/* hence may abort due to a floating point exception in environments */
/* which do not handle NaNs and infinities in the ieee standard default */
/* manner. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* RANGE (input) CHARACTER*1 */
/* = 'A': all eigenvalues will be found. */
/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
/* will be found. */
/* = 'I': the IL-th through IU-th eigenvalues will be found. */
/* ********* For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and */
/* ********* CSTEIN are called */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA, N) */
/* On entry, the Hermitian matrix A. If UPLO = 'U', the */
/* leading N-by-N upper triangular part of A contains the */
/* upper triangular part of the matrix A. If UPLO = 'L', */
/* the leading N-by-N lower triangular part of A contains */
/* the lower triangular part of the matrix A. */
/* On exit, the lower triangle (if UPLO='L') or the upper */
/* triangle (if UPLO='U') of A, including the diagonal, is */
/* destroyed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* VL (input) REAL */
/* VU (input) REAL */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* ABSTOL (input) REAL */
/* The absolute error tolerance for the eigenvalues. */
/* An approximate eigenvalue is accepted as converged */
/* when it is determined to lie in an interval [a,b] */
/* of width less than or equal to */
/* ABSTOL + EPS * max( |a|,|b| ) , */
/* where EPS is the machine precision. If ABSTOL is less than */
/* or equal to zero, then EPS*|T| will be used in its place, */
/* where |T| is the 1-norm of the tridiagonal matrix obtained */
/* by reducing A to tridiagonal form. */
/* See "Computing Small Singular Values of Bidiagonal Matrices */
/* with Guaranteed High Relative Accuracy," by Demmel and */
/* Kahan, LAPACK Working Note #3. */
/* If high relative accuracy is important, set ABSTOL to */
/* SLAMCH( 'Safe minimum' ). Doing so will guarantee that */
/* eigenvalues are computed to high relative accuracy when */
/* possible in future releases. The current code does not */
/* make any guarantees about high relative accuracy, but */
/* furutre releases will. See J. Barlow and J. Demmel, */
/* "Computing Accurate Eigensystems of Scaled Diagonally */
/* Dominant Matrices", LAPACK Working Note #7, for a discussion */
/* of which matrices define their eigenvalues to high relative */
/* accuracy. */
/* M (output) INTEGER */
/* The total number of eigenvalues found. 0 <= M <= N. */
/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
/* W (output) REAL array, dimension (N) */
/* The first M elements contain the selected eigenvalues in */
/* ascending order. */
/* Z (output) COMPLEX array, dimension (LDZ, max(1,M)) */
/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
/* contain the orthonormal eigenvectors of the matrix A */
/* corresponding to the selected eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* If JOBZ = 'N', then Z is not referenced. */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z; if RANGE = 'V', the exact value of M */
/* is not known in advance and an upper bound must be used. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
/* The support of the eigenvectors in Z, i.e., the indices */
/* indicating the nonzero elements in Z. The i-th eigenvector */
/* is nonzero only in elements ISUPPZ( 2*i-1 ) through */
/* ISUPPZ( 2*i ). */
/* ********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= max(1,2*N). */
/* For optimal efficiency, LWORK >= (NB+1)*N, */
/* where NB is the max of the blocksize for CHETRD and for */
/* CUNMTR as returned by ILAENV. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal sizes of the WORK, RWORK and */
/* IWORK arrays, returns these values as the first entries of */
/* the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK)) */
/* On exit, if INFO = 0, RWORK(1) returns the optimal */
/* (and minimal) LRWORK. */
/* LRWORK (input) INTEGER */
/* The length of the array RWORK. LRWORK >= max(1,24*N). */
/* If LRWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK, RWORK */
/* and IWORK arrays, returns these values as the first entries */
/* of the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal */
/* (and minimal) LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. LIWORK >= max(1,10*N). */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK, RWORK */
/* and IWORK arrays, returns these values as the first entries */
/* of the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: Internal error */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Inderjit Dhillon, IBM Almaden, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* Ken Stanley, Computer Science Division, University of */
/* California at Berkeley, USA */
/* Jason Riedy, Computer Science Division, University of */
/* California at Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--isuppz;
--work;
--rwork;
--iwork;
/* Function Body */
ieeeok = ilaenv_(&c__10, "CHEEVR", "N", &c__1, &c__2, &c__3, &c__4);
lower = lsame_(uplo, "L");
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
/* Computing MAX */
i__1 = 1, i__2 = *n * 24;
lrwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = *n * 10;
liwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
lwmin = max(i__1,i__2);
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -8;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -9;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -10;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -15;
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "CUNMTR", uplo, n, &c_n1, &c_n1, &
c_n1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = (nb + 1) * *n;
lwkopt = max(i__1,lwmin);
work[1].r = (real) lwkopt, work[1].i = 0.f;
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -18;
} else if (*lrwork < lrwmin && ! lquery) {
*info = -20;
} else if (*liwork < liwmin && ! lquery) {
*info = -22;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEEVR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
work[1].r = 1.f, work[1].i = 0.f;
return 0;
}
if (*n == 1) {
work[1].r = 2.f, work[1].i = 0.f;
if (alleig || indeig) {
*m = 1;
i__1 = a_dim1 + 1;
w[1] = a[i__1].r;
} else {
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
if (*vl < a[i__1].r && *vu >= a[i__2].r) {
*m = 1;
i__1 = a_dim1 + 1;
w[1] = a[i__1].r;
}
}
if (wantz) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1.f, z__[i__1].i = 0.f;
}
return 0;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
rmax = dmin(r__1,r__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
}
anrm = clansy_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
csscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
csscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
/* L20: */
}
}
if (*abstol > 0.f) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Initialize indices into workspaces. Note: The IWORK indices are */
/* used only if SSTERF or CSTEMR fail. */
/* WORK(INDTAU:INDTAU+N-1) stores the complex scalar factors of the */
/* elementary reflectors used in CHETRD. */
indtau = 1;
/* INDWK is the starting offset of the remaining complex workspace, */
/* and LLWORK is the remaining complex workspace size. */
indwk = indtau + *n;
llwork = *lwork - indwk + 1;
/* RWORK(INDRD:INDRD+N-1) stores the real tridiagonal's diagonal */
/* entries. */
indrd = 1;
/* RWORK(INDRE:INDRE+N-1) stores the off-diagonal entries of the */
/* tridiagonal matrix from CHETRD. */
indre = indrd + *n;
/* RWORK(INDRDD:INDRDD+N-1) is a copy of the diagonal entries over */
/* -written by CSTEMR (the SSTERF path copies the diagonal to W). */
indrdd = indre + *n;
/* RWORK(INDREE:INDREE+N-1) is a copy of the off-diagonal entries over */
/* -written while computing the eigenvalues in SSTERF and CSTEMR. */
indree = indrdd + *n;
/* INDRWK is the starting offset of the left-over real workspace, and */
/* LLRWORK is the remaining workspace size. */
indrwk = indree + *n;
llrwork = *lrwork - indrwk + 1;
/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in SSTEBZ and */
/* stores the block indices of each of the M<=N eigenvalues. */
indibl = 1;
/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in SSTEBZ and */
/* stores the starting and finishing indices of each block. */
indisp = indibl + *n;
/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors */
/* that corresponding to eigenvectors that fail to converge in */
/* SSTEIN. This information is discarded; if any fail, the driver */
/* returns INFO > 0. */
indifl = indisp + *n;
/* INDIWO is the offset of the remaining integer workspace. */
indiwo = indisp + *n;
/* Call CHETRD to reduce Hermitian matrix to tridiagonal form. */
chetrd_(uplo, n, &a[a_offset], lda, &rwork[indrd], &rwork[indre], &work[
indtau], &work[indwk], &llwork, &iinfo);
/* If all eigenvalues are desired */
/* then call SSTERF or CSTEMR and CUNMTR. */
test = FALSE_;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE_;
}
}
if ((alleig || test) && ieeeok == 1) {
if (! wantz) {
scopy_(n, &rwork[indrd], &c__1, &w[1], &c__1);
i__1 = *n - 1;
scopy_(&i__1, &rwork[indre], &c__1, &rwork[indree], &c__1);
ssterf_(n, &w[1], &rwork[indree], info);
} else {
i__1 = *n - 1;
scopy_(&i__1, &rwork[indre], &c__1, &rwork[indree], &c__1);
scopy_(n, &rwork[indrd], &c__1, &rwork[indrdd], &c__1);
if (*abstol <= *n * 2.f * eps) {
tryrac = TRUE_;
} else {
tryrac = FALSE_;
}
cstemr_(jobz, "A", n, &rwork[indrdd], &rwork[indree], vl, vu, il,
iu, m, &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac,
&rwork[indrwk], &llrwork, &iwork[1], liwork, info);
/* Apply unitary matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by CSTEIN. */
if (wantz && *info == 0) {
indwkn = indwk;
llwrkn = *lwork - indwkn + 1;
cunmtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau]
, &z__[z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
}
}
if (*info == 0) {
*m = *n;
goto L30;
}
*info = 0;
}
/* Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN. */
/* Also call SSTEBZ and CSTEIN if CSTEMR fails. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indrd], &
rwork[indre], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &
rwork[indrwk], &iwork[indiwo], info);
if (wantz) {
cstein_(n, &rwork[indrd], &rwork[indre], m, &w[1], &iwork[indibl], &
iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
indiwo], &iwork[indifl], info);
/* Apply unitary matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by CSTEIN. */
indwkn = indwk;
llwrkn = *lwork - indwkn + 1;
cunmtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L30:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &w[1], &c__1);
}
/* If eigenvalues are not in order, then sort them, along with */
/* eigenvectors. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp1) {
i__ = jj;
tmp1 = w[jj];
}
/* L40: */
}
if (i__ != 0) {
itmp1 = iwork[indibl + i__ - 1];
w[i__] = w[j];
iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
w[j] = tmp1;
iwork[indibl + j - 1] = itmp1;
cswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
&c__1);
}
/* L50: */
}
}
/* Set WORK(1) to optimal workspace size. */
work[1].r = (real) lwkopt, work[1].i = 0.f;
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
return 0;
/* End of CHEEVR */
} /* cheevr_ */
/* Subroutine */ int cstt22_(integer *n, integer *m, integer *kband, real *ad,
real *ae, real *sd, real *se, complex *u, integer *ldu, complex *
work, integer *ldwork, real *rwork, real *result)
{
/* System generated locals */
integer u_dim1, u_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4,
i__5, i__6;
real r__1, r__2, r__3, r__4, r__5;
complex q__1, q__2;
/* Local variables */
integer i__, j, k;
real ulp;
complex aukj;
real unfl;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
real anorm, wnorm;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), slamch_(char *), clansy_(char
*, char *, integer *, complex *, integer *, real *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CSTT22 checks a set of M eigenvalues and eigenvectors, */
/* A U = U S */
/* where A is Hermitian tridiagonal, the columns of U are unitary, */
/* and S is diagonal (if KBAND=0) or Hermitian tridiagonal (if KBAND=1). */
/* Two tests are performed: */
/* RESULT(1) = | U* A U - S | / ( |A| m ulp ) */
/* RESULT(2) = | I - U*U | / ( m ulp ) */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The size of the matrix. If it is zero, CSTT22 does nothing. */
/* It must be at least zero. */
/* M (input) INTEGER */
/* The number of eigenpairs to check. If it is zero, CSTT22 */
/* does nothing. It must be at least zero. */
/* KBAND (input) INTEGER */
/* The bandwidth of the matrix S. It may only be zero or one. */
/* If zero, then S is diagonal, and SE is not referenced. If */
/* one, then S is Hermitian tri-diagonal. */
/* AD (input) REAL array, dimension (N) */
/* The diagonal of the original (unfactored) matrix A. A is */
/* assumed to be Hermitian tridiagonal. */
/* AE (input) REAL array, dimension (N) */
/* The off-diagonal of the original (unfactored) matrix A. A */
/* is assumed to be Hermitian tridiagonal. AE(1) is ignored, */
/* AE(2) is the (1,2) and (2,1) element, etc. */
/* SD (input) REAL array, dimension (N) */
/* The diagonal of the (Hermitian tri-) diagonal matrix S. */
/* SE (input) REAL array, dimension (N) */
/* The off-diagonal of the (Hermitian tri-) diagonal matrix S. */
/* Not referenced if KBSND=0. If KBAND=1, then AE(1) is */
/* ignored, SE(2) is the (1,2) and (2,1) element, etc. */
/* U (input) REAL array, dimension (LDU, N) */
/* The unitary matrix in the decomposition. */
/* LDU (input) INTEGER */
/* The leading dimension of U. LDU must be at least N. */
/* WORK (workspace) COMPLEX array, dimension (LDWORK, M+1) */
/* LDWORK (input) INTEGER */
/* The leading dimension of WORK. LDWORK must be at least */
/* max(1,M). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESULT (output) REAL array, dimension (2) */
/* The values computed by the two tests described above. The */
/* values are currently limited to 1/ulp, to avoid overflow. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ad;
--ae;
--sd;
--se;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
--rwork;
--result;
/* Function Body */
result[1] = 0.f;
result[2] = 0.f;
if (*n <= 0 || *m <= 0) {
return 0;
}
unfl = slamch_("Safe minimum");
ulp = slamch_("Epsilon");
/* Do Test 1 */
/* Compute the 1-norm of A. */
if (*n > 1) {
anorm = dabs(ad[1]) + dabs(ae[1]);
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
/* Computing MAX */
r__4 = anorm, r__5 = (r__1 = ad[j], dabs(r__1)) + (r__2 = ae[j],
dabs(r__2)) + (r__3 = ae[j - 1], dabs(r__3));
anorm = dmax(r__4,r__5);
/* L10: */
}
/* Computing MAX */
r__3 = anorm, r__4 = (r__1 = ad[*n], dabs(r__1)) + (r__2 = ae[*n - 1],
dabs(r__2));
anorm = dmax(r__3,r__4);
} else {
anorm = dabs(ad[1]);
}
anorm = dmax(anorm,unfl);
/* Norm of U*AU - S */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *m;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * work_dim1;
work[i__3].r = 0.f, work[i__3].i = 0.f;
i__3 = *n;
for (k = 1; k <= i__3; ++k) {
i__4 = k;
i__5 = k + j * u_dim1;
q__1.r = ad[i__4] * u[i__5].r, q__1.i = ad[i__4] * u[i__5].i;
aukj.r = q__1.r, aukj.i = q__1.i;
if (k != *n) {
i__4 = k;
i__5 = k + 1 + j * u_dim1;
q__2.r = ae[i__4] * u[i__5].r, q__2.i = ae[i__4] * u[i__5]
.i;
q__1.r = aukj.r + q__2.r, q__1.i = aukj.i + q__2.i;
aukj.r = q__1.r, aukj.i = q__1.i;
}
if (k != 1) {
i__4 = k - 1;
i__5 = k - 1 + j * u_dim1;
q__2.r = ae[i__4] * u[i__5].r, q__2.i = ae[i__4] * u[i__5]
.i;
q__1.r = aukj.r + q__2.r, q__1.i = aukj.i + q__2.i;
aukj.r = q__1.r, aukj.i = q__1.i;
}
i__4 = i__ + j * work_dim1;
i__5 = i__ + j * work_dim1;
i__6 = k + i__ * u_dim1;
q__2.r = u[i__6].r * aukj.r - u[i__6].i * aukj.i, q__2.i = u[
i__6].r * aukj.i + u[i__6].i * aukj.r;
q__1.r = work[i__5].r + q__2.r, q__1.i = work[i__5].i +
q__2.i;
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
/* L20: */
}
/* L30: */
}
i__2 = i__ + i__ * work_dim1;
i__3 = i__ + i__ * work_dim1;
i__4 = i__;
q__1.r = work[i__3].r - sd[i__4], q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
if (*kband == 1) {
if (i__ != 1) {
i__2 = i__ + (i__ - 1) * work_dim1;
i__3 = i__ + (i__ - 1) * work_dim1;
i__4 = i__ - 1;
q__1.r = work[i__3].r - se[i__4], q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
}
if (i__ != *n) {
i__2 = i__ + (i__ + 1) * work_dim1;
i__3 = i__ + (i__ + 1) * work_dim1;
i__4 = i__;
q__1.r = work[i__3].r - se[i__4], q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
}
}
/* L40: */
}
wnorm = clansy_("1", "L", m, &work[work_offset], m, &rwork[1]);
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*m * ulp);
} else {
if (anorm < 1.f) {
/* Computing MIN */
r__1 = wnorm, r__2 = *m * anorm;
result[1] = dmin(r__1,r__2) / anorm / (*m * ulp);
} else {
/* Computing MIN */
r__1 = wnorm / anorm, r__2 = (real) (*m);
result[1] = dmin(r__1,r__2) / (*m * ulp);
}
}
/* Do Test 2 */
/* Compute U*U - I */
cgemm_("T", "N", m, m, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu, &
c_b1, &work[work_offset], m);
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * work_dim1;
i__3 = j + j * work_dim1;
q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L50: */
}
/* Computing MIN */
r__1 = (real) (*m), r__2 = clange_("1", m, m, &work[work_offset], m, &
rwork[1]);
result[2] = dmin(r__1,r__2) / (*m * ulp);
return 0;
/* End of CSTT22 */
} /* cstt22_ */
/* Subroutine */ int cdrvsy_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
a, complex *afac, complex *ainv, complex *b, complex *x, complex *
xact, complex *work, real *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char facts[1*2] = "F" "N";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, type \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', UPLO='\002,a"
"1,\002', N =\002,i5,\002, type \002,i2,\002, test \002,i2,\002, "
"ratio =\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5, i__6[2];
char ch__1[2];
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static char fact[1];
static integer ioff, mode, imat, info;
static char path[3], dist[1], uplo[1], type__[1];
static integer nrun, i__, j, k, n, ifact;
extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *);
static integer nfail, iseed[4], nbmin;
static real rcond;
static integer nimat;
extern doublereal sget06_(real *, real *);
extern /* Subroutine */ int cpot05_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, complex *, integer *, complex
*, integer *, real *, real *, real *);
static real anorm;
extern /* Subroutine */ int csyt01_(char *, integer *, complex *, integer
*, complex *, integer *, integer *, complex *, integer *, real *,
real *), csyt02_(char *, integer *, integer *, complex *,
integer *, complex *, integer *, complex *, integer *, real *,
real *);
static integer iuplo, izero, i1, i2, k1, lwork, nerrs;
static logical zerot;
extern /* Subroutine */ int csysv_(char *, integer *, integer *, complex *
, integer *, integer *, complex *, integer *, complex *, integer *
, integer *);
static char xtype[1];
extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), aladhd_(integer *, char *);
static integer nb, in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer ku, nt;
static real rcondc;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), clarhs_(char *, char
*, char *, char *, integer *, integer *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, integer *, integer *),
claset_(char *, integer *, integer *, complex *, complex *,
complex *, integer *), alasvm_(char *, integer *, integer
*, integer *, integer *);
static real cndnum;
extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
*, char *, real *, integer *, real *, real *, integer *, integer *
, char *, complex *, integer *, complex *, integer *);
static real ainvnm;
extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
real *);
extern /* Subroutine */ int xlaenv_(integer *, integer *), clatsy_(char *,
integer *, complex *, integer *, integer *), cerrvx_(
char *, integer *), csytrf_(char *, integer *, complex *,
integer *, integer *, complex *, integer *, integer *),
csytri_(char *, integer *, complex *, integer *, integer *,
complex *, integer *);
static real result[6];
extern /* Subroutine */ int csysvx_(char *, char *, integer *, integer *,
complex *, integer *, complex *, integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *, real *, complex *
, integer *, real *, integer *);
static integer lda;
/* Fortran I/O blocks */
static cilist io___42 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CDRVSY tests the driver routines CSYSV 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.
NMAX (input) INTEGER
The maximum value permitted for N, used in dimensioning the
work arrays.
A (workspace) COMPLEX array, dimension (NMAX*NMAX)
AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX)
AINV (workspace) COMPLEX array, dimension (NMAX*NMAX)
B (workspace) COMPLEX array, dimension (NMAX*NRHS)
X (workspace) COMPLEX array, dimension (NMAX*NRHS)
XACT (workspace) COMPLEX array, dimension (NMAX*NRHS)
WORK (workspace) COMPLEX array, dimension
(NMAX*max(2,NRHS))
RWORK (workspace) REAL array, dimension (NMAX+2*NRHS)
IWORK (workspace) INTEGER array, dimension (NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "SY", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Computing MAX */
i__1 = *nmax << 1, i__2 = *nmax * *nrhs;
lwork = max(i__1,i__2);
/* Test the error exits */
if (*tsterr) {
cerrvx_(path, nout);
}
infoc_1.infot = 0;
/* Set the block size and minimum block size for testing. */
nb = 1;
nbmin = 2;
xlaenv_(&c__1, &nb);
xlaenv_(&c__2, &nbmin);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 11;
if (n <= 0) {
nimat = 1;
}
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L170;
}
/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 6;
if (zerot && n < imat - 2) {
goto L170;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (imat != 11) {
/* Set up parameters with CLATB4 and generate a test
matrix with CLATMS. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
mode, &cndnum, dist);
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)6, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &
work[1], &info);
/* Check error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
goto L160;
}
/* For types 3-6, zero one or more rows and columns of
the matrix to test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
if (imat < 6) {
/* Set row and column IZERO to zero. */
if (iuplo == 1) {
ioff = (izero - 1) * lda;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0.f, a[i__4].i = 0.f;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0.f, a[i__4].i = 0.f;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L50: */
}
}
} else {
if (iuplo == 1) {
/* Set the first IZERO rows to zero. */
ioff = 0;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i2 = min(j,izero);
i__4 = i2;
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = ioff + i__;
a[i__5].r = 0.f, a[i__5].i = 0.f;
/* L60: */
}
ioff += lda;
/* L70: */
}
} else {
/* Set the last IZERO rows to zero. */
ioff = 0;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i1 = max(j,izero);
i__4 = n;
for (i__ = i1; i__ <= i__4; ++i__) {
i__5 = ioff + i__;
a[i__5].r = 0.f, a[i__5].i = 0.f;
/* L80: */
}
ioff += lda;
/* L90: */
}
}
}
} else {
izero = 0;
}
} else {
/* IMAT = NTYPES: Use a special block diagonal matrix to
test alternate code for the 2-by-2 blocks. */
clatsy_(uplo, &n, &a[1], &lda, iseed);
}
for (ifact = 1; ifact <= 2; ++ifact) {
/* Do first for FACT = 'F', then for other values. */
*(unsigned char *)fact = *(unsigned char *)&facts[ifact -
1];
/* Compute the condition number for comparison with
the value returned by CSYSVX. */
if (zerot) {
if (ifact == 1) {
goto L150;
}
rcondc = 0.f;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = clansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
/* Factor the matrix A. */
clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
csytrf_(uplo, &n, &afac[1], &lda, &iwork[1], &work[1],
&lwork, &info);
/* Compute inv(A) and take its norm. */
clacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
csytri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
&info);
ainvnm = clansy_("1", uplo, &n, &ainv[1], &lda, &
rwork[1]);
/* Compute the 1-norm condition number of A. */
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
}
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)6, (ftnlen)6);
clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, nrhs, &
a[1], &lda, &xact[1], &lda, &b[1], &lda, iseed, &
info);
*(unsigned char *)xtype = 'C';
/* --- Test CSYSV --- */
if (ifact == 2) {
clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor the matrix and solve the system using CSYSV. */
s_copy(srnamc_1.srnamt, "CSYSV ", (ftnlen)6, (ftnlen)
6);
csysv_(uplo, &n, nrhs, &afac[1], &lda, &iwork[1], &x[
1], &lda, &work[1], &lwork, &info);
/* Adjust the expected value of INFO to account for
pivoting. */
k = izero;
if (k > 0) {
L100:
if (iwork[k] < 0) {
if (iwork[k] != -k) {
k = -iwork[k];
goto L100;
}
} else if (iwork[k] != k) {
k = iwork[k];
goto L100;
}
}
/* Check error code from CSYSV . */
if (info != k) {
alaerh_(path, "CSYSV ", &info, &k, uplo, &n, &n, &
c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
nout);
goto L120;
} else if (info != 0) {
goto L120;
}
/* Reconstruct matrix from factors and compute
residual. */
csyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[
1], &ainv[1], &lda, &rwork[1], result);
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
csyt02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
cget04_(&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___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "CSYSV ", (ftnlen)6);
do_fio(&c__1, uplo, (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;
}
/* L110: */
}
nrun += nt;
L120:
;
}
/* --- Test CSYSVX --- */
if (ifact == 2) {
claset_(uplo, &n, &n, &c_b49, &c_b49, &afac[1], &lda);
}
claset_("Full", &n, nrhs, &c_b49, &c_b49, &x[1], &lda);
/* Solve the system and compute the condition number and
error bounds using CSYSVX. */
s_copy(srnamc_1.srnamt, "CSYSVX", (ftnlen)6, (ftnlen)6);
csysvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &lda,
&iwork[1], &b[1], &lda, &x[1], &lda, &rcond, &
rwork[1], &rwork[*nrhs + 1], &work[1], &lwork, &
rwork[(*nrhs << 1) + 1], &info);
/* Adjust the expected value of INFO to account for
pivoting. */
k = izero;
if (k > 0) {
L130:
if (iwork[k] < 0) {
if (iwork[k] != -k) {
k = -iwork[k];
goto L130;
}
} else if (iwork[k] != k) {
k = iwork[k];
goto L130;
}
}
/* Check the error code from CSYSVX. */
if (info != k) {
/* Writing concatenation */
i__6[0] = 1, a__1[0] = fact;
i__6[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__6, &c__2, (ftnlen)2);
alaerh_(path, "CSYSVX", &info, &k, ch__1, &n, &n, &
c_n1, &c_n1, nrhs, &imat, &nfail, &nerrs,
nout);
goto L150;
}
if (info == 0) {
if (ifact >= 2) {
/* Reconstruct matrix from factors and compute
residual. */
csyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
iwork[1], &ainv[1], &lda, &rwork[(*nrhs <<
1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
csyt02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[(*nrhs << 1) + 1], &
result[1]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
/* Check the error bounds from iterative refinement. */
cpot05_(uplo, &n, nrhs, &a[1], &lda, &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &rwork[*
nrhs + 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from CSYSVX with the computed value
in RCONDC. */
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___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, "CSYSVX", (ftnlen)6);
do_fio(&c__1, fact, (ftnlen)1);
do_fio(&c__1, uplo, (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;
}
/* L140: */
}
nrun = nrun + 7 - k1;
L150:
;
}
L160:
;
}
L170:
;
}
/* L180: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CDRVSY */
} /* cdrvsy_ */
/* Subroutine */ int cqlt01_(integer *m, integer *n, complex *a, complex *af,
complex *q, complex *l, integer *lda, complex *tau, complex *work,
integer *lwork, real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1, i__2;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), cherk_(char *,
char *, integer *, integer *, real *, complex *, integer *, real *
, complex *, integer *);
static real resid, anorm;
static integer minmn;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
extern /* Subroutine */ int cgeqlf_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *);
extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
real *);
extern /* Subroutine */ int cungql_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *);
static real eps;
#define l_subscr(a_1,a_2) (a_2)*l_dim1 + a_1
#define l_ref(a_1,a_2) l[l_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CQLT01 tests CGEQLF, which computes the QL factorization of an m-by-n
matrix A, and partially tests CUNGQL which forms the m-by-m
orthogonal matrix Q.
CQLT01 compares L with Q'*A, and checks that Q is orthogonal.
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.
A (input) COMPLEX array, dimension (LDA,N)
The m-by-n matrix A.
AF (output) COMPLEX array, dimension (LDA,N)
Details of the QL factorization of A, as returned by CGEQLF.
See CGEQLF for further details.
Q (output) COMPLEX array, dimension (LDA,M)
The m-by-m orthogonal matrix Q.
L (workspace) COMPLEX array, dimension (LDA,max(M,N))
LDA (input) INTEGER
The leading dimension of the arrays A, AF, Q and R.
LDA >= max(M,N).
TAU (output) COMPLEX array, dimension (min(M,N))
The scalar factors of the elementary reflectors, as returned
by CGEQLF.
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
RWORK (workspace) REAL array, dimension (M)
RESULT (output) REAL array, dimension (2)
The test ratios:
RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
=====================================================================
Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1 * 1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
minmn = min(*m,*n);
eps = slamch_("Epsilon");
/* Copy the matrix A to the array AF. */
clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
/* Factorize the matrix A in the array AF. */
s_copy(srnamc_1.srnamt, "CGEQLF", (ftnlen)6, (ftnlen)6);
cgeqlf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy details of Q */
claset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda);
if (*m >= *n) {
if (*n < *m && *n > 0) {
i__1 = *m - *n;
clacpy_("Full", &i__1, n, &af[af_offset], lda, &q_ref(1, *m - *n
+ 1), lda);
}
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
clacpy_("Upper", &i__1, &i__2, &af_ref(*m - *n + 1, 2), lda, &
q_ref(*m - *n + 1, *m - *n + 2), lda);
}
} else {
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
clacpy_("Upper", &i__1, &i__2, &af_ref(1, *n - *m + 2), lda, &
q_ref(1, 2), lda);
}
}
/* Generate the m-by-m matrix Q */
s_copy(srnamc_1.srnamt, "CUNGQL", (ftnlen)6, (ftnlen)6);
cungql_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L */
claset_("Full", m, n, &c_b12, &c_b12, &l[l_offset], lda);
if (*m >= *n) {
if (*n > 0) {
clacpy_("Lower", n, n, &af_ref(*m - *n + 1, 1), lda, &l_ref(*m - *
n + 1, 1), lda);
}
} else {
if (*n > *m && *m > 0) {
i__1 = *n - *m;
clacpy_("Full", m, &i__1, &af[af_offset], lda, &l[l_offset], lda);
}
if (*m > 0) {
clacpy_("Lower", m, m, &af_ref(1, *n - *m + 1), lda, &l_ref(1, *n
- *m + 1), lda);
}
}
/* Compute L - Q'*A */
cgemm_("Conjugate transpose", "No transpose", m, n, m, &c_b19, &q[
q_offset], lda, &a[a_offset], lda, &c_b20, &l[l_offset], lda);
/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
resid = clange_("1", m, n, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.f) {
result[1] = resid / (real) max(1,*m) / anorm / eps;
} else {
result[1] = 0.f;
}
/* Compute I - Q'*Q */
claset_("Full", m, m, &c_b12, &c_b20, &l[l_offset], lda);
cherk_("Upper", "Conjugate transpose", m, m, &c_b28, &q[q_offset], lda, &
c_b29, &l[l_offset], lda);
/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
resid = clansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (real) max(1,*m) / eps;
return 0;
/* End of CQLT01 */
} /* cqlt01_ */
/* Subroutine */
int csysvx_(char *fact, char *uplo, integer *n, integer * nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer * ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, integer *lwork, real *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2;
/* Local variables */
integer nb;
extern logical lsame_(char *, char *);
real anorm;
extern real slamch_(char *);
logical nofact;
extern /* Subroutine */
int clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
extern real clansy_(char *, char *, integer *, complex *, integer *, real *);
extern /* Subroutine */
int csycon_(char *, integer *, complex *, integer *, integer *, real *, real *, complex *, integer *), csyrfs_(char *, integer *, integer *, complex *, integer *, complex *, integer *, integer *, complex *, integer *, complex *, integer *, real *, real *, complex *, real *, integer *), csytrf_(char *, integer *, complex *, integer *, integer *, complex *, integer *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */
int csytrs_(char *, integer *, integer *, complex *, integer *, integer *, complex *, integer *, integer *);
/* -- LAPACK driver routine (version 3.4.1) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* April 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
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;
--rwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
lquery = *lwork == -1;
if (! nofact && ! lsame_(fact, "F"))
{
*info = -1;
}
else if (! lsame_(uplo, "U") && ! lsame_(uplo, "L"))
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
else if (*nrhs < 0)
{
*info = -4;
}
else if (*lda < max(1,*n))
{
*info = -6;
}
else if (*ldaf < max(1,*n))
{
*info = -8;
}
else if (*ldb < max(1,*n))
{
*info = -11;
}
else if (*ldx < max(1,*n))
{
*info = -13;
}
else /* if(complicated condition) */
{
/* Computing MAX */
i__1 = 1;
i__2 = *n << 1; // , expr subst
if (*lwork < max(i__1,i__2) && ! lquery)
{
*info = -18;
}
}
if (*info == 0)
{
/* Computing MAX */
i__1 = 1;
i__2 = *n << 1; // , expr subst
lwkopt = max(i__1,i__2);
if (nofact)
{
nb = ilaenv_(&c__1, "CSYTRF", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = lwkopt;
i__2 = *n * nb; // , expr subst
lwkopt = max(i__1,i__2);
}
work[1].r = (real) lwkopt;
work[1].i = 0.f; // , expr subst
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CSYSVX", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
if (nofact)
{
/* Compute the factorization A = U*D*U**T or A = L*D*L**T. */
clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
csytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], lwork, info);
/* Return if INFO is non-zero. */
if (*info > 0)
{
*rcond = 0.f;
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = clansy_("I", uplo, n, &a[a_offset], lda, &rwork[1]);
/* Compute the reciprocal of the condition number of A. */
csycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1], info);
/* Compute the solution vectors X. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
csytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solutions and */
/* compute error bounds and backward error estimates for them. */
csyrfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1] , &rwork[1], info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon"))
{
*info = *n + 1;
}
work[1].r = (real) lwkopt;
work[1].i = 0.f; // , expr subst
return 0;
/* End of CSYSVX */
}
/* Subroutine */ int csyt03_(char *uplo, integer *n, complex *a, integer *lda,
complex *ainv, integer *ldainv, complex *work, integer *ldwork, real
*rwork, real *rcond, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, ainv_dim1, ainv_offset, work_dim1, work_offset,
i__1, i__2, i__3, i__4;
complex q__1;
/* Local variables */
integer i__, j;
real eps;
extern logical lsame_(char *, char *);
real anorm;
extern /* Subroutine */ int csymm_(char *, char *, integer *, integer *,
complex *, complex *, integer *, complex *, integer *, complex *,
complex *, integer *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), slamch_(char *);
real ainvnm;
extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
real *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CSYT03 computes the residual for a complex symmetric matrix times */
/* its inverse: */
/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ) */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* complex symmetric matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The original complex symmetric matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AINV (input/output) COMPLEX array, dimension (LDAINV,N) */
/* On entry, the inverse of the matrix A, stored as a symmetric */
/* matrix in the same format as A. */
/* In this version, AINV is expanded into a full matrix and */
/* multiplied by A, so the opposing triangle of AINV will be */
/* changed; i.e., if the upper triangular part of AINV is */
/* stored, the lower triangular part will be used as work space. */
/* LDAINV (input) INTEGER */
/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
/* WORK (workspace) COMPLEX array, dimension (LDWORK,N) */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of A, computed as */
/* RCOND = 1/ (norm(A) * norm(AINV)). */
/* RESID (output) REAL */
/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
ainv_dim1 = *ldainv;
ainv_offset = 1 + ainv_dim1;
ainv -= ainv_offset;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*rcond = 1.f;
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
eps = slamch_("Epsilon");
anorm = clansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
ainvnm = clansy_("1", uplo, n, &ainv[ainv_offset], ldainv, &rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
*rcond = 0.f;
*resid = 1.f / eps;
return 0;
}
*rcond = 1.f / anorm / ainvnm;
/* Expand AINV into a full matrix and call CSYMM to multiply */
/* AINV on the left by A (store the result in WORK). */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * ainv_dim1;
i__4 = i__ + j * ainv_dim1;
ainv[i__3].r = ainv[i__4].r, ainv[i__3].i = ainv[i__4].i;
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * ainv_dim1;
i__4 = i__ + j * ainv_dim1;
ainv[i__3].r = ainv[i__4].r, ainv[i__3].i = ainv[i__4].i;
/* L30: */
}
/* L40: */
}
}
q__1.r = -1.f, q__1.i = -0.f;
csymm_("Left", uplo, n, n, &q__1, &a[a_offset], lda, &ainv[ainv_offset],
ldainv, &c_b1, &work[work_offset], ldwork);
/* Add the identity matrix to WORK . */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * work_dim1;
i__3 = i__ + i__ * work_dim1;
q__1.r = work[i__3].r + 1.f, q__1.i = work[i__3].i + 0.f;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L50: */
}
/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
*resid = clange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
*resid = *resid * *rcond / eps / (real) (*n);
return 0;
/* End of CSYT03 */
} /* csyt03_ */
/* Subroutine */ int cqlt01_(integer *m, integer *n, complex *a, complex *af,
complex *q, complex *l, integer *lda, complex *tau, complex *work,
integer *lwork, real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
real eps;
integer info;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), cherk_(char *,
char *, integer *, integer *, real *, complex *, integer *, real *
, complex *, integer *);
real resid, anorm;
integer minmn;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
extern /* Subroutine */ int cgeqlf_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *);
extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
real *);
extern /* Subroutine */ int cungql_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CQLT01 tests CGEQLF, which computes the QL factorization of an m-by-n */
/* matrix A, and partially tests CUNGQL which forms the m-by-m */
/* orthogonal matrix Q. */
/* CQLT01 compares L with Q'*A, and checks that Q is orthogonal. */
/* 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. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The m-by-n matrix A. */
/* AF (output) COMPLEX array, dimension (LDA,N) */
/* Details of the QL factorization of A, as returned by CGEQLF. */
/* See CGEQLF for further details. */
/* Q (output) COMPLEX array, dimension (LDA,M) */
/* The m-by-m orthogonal matrix Q. */
/* L (workspace) COMPLEX array, dimension (LDA,max(M,N)) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and R. */
/* LDA >= max(M,N). */
/* TAU (output) COMPLEX array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by CGEQLF. */
/* WORK (workspace) COMPLEX array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) REAL array, dimension (M) */
/* RESULT (output) REAL array, dimension (2) */
/* The test ratios: */
/* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
minmn = min(*m,*n);
eps = slamch_("Epsilon");
/* Copy the matrix A to the array AF. */
clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
/* Factorize the matrix A in the array AF. */
s_copy(srnamc_1.srnamt, "CGEQLF", (ftnlen)6, (ftnlen)6);
cgeqlf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy details of Q */
claset_("Full", m, m, &c_b1, &c_b1, &q[q_offset], lda);
if (*m >= *n) {
if (*n < *m && *n > 0) {
i__1 = *m - *n;
clacpy_("Full", &i__1, n, &af[af_offset], lda, &q[(*m - *n + 1) *
q_dim1 + 1], lda);
}
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
clacpy_("Upper", &i__1, &i__2, &af[*m - *n + 1 + (af_dim1 << 1)],
lda, &q[*m - *n + 1 + (*m - *n + 2) * q_dim1], lda);
}
} else {
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
clacpy_("Upper", &i__1, &i__2, &af[(*n - *m + 2) * af_dim1 + 1],
lda, &q[(q_dim1 << 1) + 1], lda);
}
}
/* Generate the m-by-m matrix Q */
s_copy(srnamc_1.srnamt, "CUNGQL", (ftnlen)6, (ftnlen)6);
cungql_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L */
claset_("Full", m, n, &c_b12, &c_b12, &l[l_offset], lda);
if (*m >= *n) {
if (*n > 0) {
clacpy_("Lower", n, n, &af[*m - *n + 1 + af_dim1], lda, &l[*m - *
n + 1 + l_dim1], lda);
}
} else {
if (*n > *m && *m > 0) {
i__1 = *n - *m;
clacpy_("Full", m, &i__1, &af[af_offset], lda, &l[l_offset], lda);
}
if (*m > 0) {
clacpy_("Lower", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &l[(
*n - *m + 1) * l_dim1 + 1], lda);
}
}
/* Compute L - Q'*A */
cgemm_("Conjugate transpose", "No transpose", m, n, m, &c_b19, &q[
q_offset], lda, &a[a_offset], lda, &c_b20, &l[l_offset], lda);
/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
anorm = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
resid = clange_("1", m, n, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.f) {
result[1] = resid / (real) max(1,*m) / anorm / eps;
} else {
result[1] = 0.f;
}
/* Compute I - Q'*Q */
claset_("Full", m, m, &c_b12, &c_b20, &l[l_offset], lda);
cherk_("Upper", "Conjugate transpose", m, m, &c_b28, &q[q_offset], lda, &
c_b29, &l[l_offset], lda);
/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
resid = clansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (real) max(1,*m) / eps;
return 0;
/* End of CQLT01 */
} /* cqlt01_ */
/* Subroutine */ int csyt01_(char *uplo, integer *n, complex *a, integer *lda,
complex *afac, integer *ldafac, integer *ipiv, complex *c__, integer
*ldc, real *rwork, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, c_dim1, c_offset, i__1,
i__2, i__3, i__4, i__5;
complex q__1;
/* Local variables */
integer i__, j;
real eps;
integer info;
real anorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CSYT01 reconstructs a complex symmetric indefinite matrix A from its */
/* block L*D*L' or U*D*U' factorization and computes the residual */
/* norm( C - A ) / ( N * norm(A) * EPS ), */
/* where C is the reconstructed matrix, EPS is the machine epsilon, */
/* L' is the transpose of L, and U' is the transpose of U. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* complex symmetric matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The original complex symmetric matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AFAC (input) COMPLEX array, dimension (LDAFAC,N) */
/* The factored form of the matrix A. AFAC contains the block */
/* diagonal matrix D and the multipliers used to obtain the */
/* factor L or U from the block L*D*L' or U*D*U' factorization */
/* as computed by CSYTRF. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from CSYTRF. */
/* C (workspace) COMPLEX array, dimension (LDC,N) */
/* LDC (integer) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
--ipiv;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
/* Determine EPS and the norm of A. */
eps = slamch_("Epsilon");
anorm = clansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
/* Initialize C to the identity matrix. */
claset_("Full", n, n, &c_b1, &c_b2, &c__[c_offset], ldc);
/* Call CLAVSY to form the product D * U' (or D * L' ). */
clavsy_(uplo, "Transpose", "Non-unit", n, n, &afac[afac_offset], ldafac, &
ipiv[1], &c__[c_offset], ldc, &info);
/* Call CLAVSY again to multiply by U (or L ). */
clavsy_(uplo, "No transpose", "Unit", n, n, &afac[afac_offset], ldafac, &
ipiv[1], &c__[c_offset], ldc, &info);
/* Compute the difference C - A . */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * a_dim1;
q__1.r = c__[i__4].r - a[i__5].r, q__1.i = c__[i__4].i - a[
i__5].i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = i__ + j * a_dim1;
q__1.r = c__[i__4].r - a[i__5].r, q__1.i = c__[i__4].i - a[
i__5].i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L30: */
}
/* L40: */
}
}
/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
*resid = clansy_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
if (anorm <= 0.f) {
if (*resid != 0.f) {
*resid = 1.f / eps;
}
} else {
*resid = *resid / (real) (*n) / anorm / eps;
}
return 0;
/* End of CSYT01 */
} /* csyt01_ */
/* Subroutine */ int crqt02_(integer *m, integer *n, integer *k, complex *a,
complex *af, complex *q, complex *r__, integer *lda, complex *tau,
complex *work, integer *lwork, real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
r_offset, i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
real eps;
integer info;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), cherk_(char *,
char *, integer *, integer *, real *, complex *, integer *, real *
, complex *, integer *);
real resid, anorm;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *);
extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
real *);
extern /* Subroutine */ int cungrq_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CRQT02 tests CUNGRQ, which generates an m-by-n matrix Q with */
/* orthonornmal rows that is defined as the product of k elementary */
/* reflectors. */
/* Given the RQ factorization of an m-by-n matrix A, CRQT02 generates */
/* the orthogonal matrix Q defined by the factorization of the last k */
/* rows of A; it compares R(m-k+1:m,n-m+1:n) with */
/* A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are */
/* orthonormal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q to be generated. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q to be generated. */
/* N >= M >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. M >= K >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The m-by-n matrix A which was factorized by CRQT01. */
/* AF (input) COMPLEX array, dimension (LDA,N) */
/* Details of the RQ factorization of A, as returned by CGERQF. */
/* See CGERQF for further details. */
/* Q (workspace) COMPLEX array, dimension (LDA,N) */
/* R (workspace) COMPLEX array, dimension (LDA,M) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
/* TAU (input) COMPLEX array, dimension (M) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the RQ factorization in AF. */
/* WORK (workspace) COMPLEX array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) REAL array, dimension (M) */
/* RESULT (output) REAL array, dimension (2) */
/* The test ratios: */
/* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
r_dim1 = *lda;
r_offset = 1 + r_dim1;
r__ -= r_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
if (*m == 0 || *n == 0 || *k == 0) {
result[1] = 0.f;
result[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
/* Copy the last k rows of the factorization to the array Q */
claset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
if (*k < *n) {
i__1 = *n - *k;
clacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*m - *k
+ 1 + q_dim1], lda);
}
if (*k > 1) {
i__1 = *k - 1;
i__2 = *k - 1;
clacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) *
af_dim1], lda, &q[*m - *k + 2 + (*n - *k + 1) * q_dim1], lda);
}
/* Generate the last n rows of the matrix Q */
s_copy(srnamc_1.srnamt, "CUNGRQ", (ftnlen)32, (ftnlen)6);
cungrq_(m, n, k, &q[q_offset], lda, &tau[*m - *k + 1], &work[1], lwork, &
info);
/* Copy R(m-k+1:m,n-m+1:n) */
claset_("Full", k, m, &c_b9, &c_b9, &r__[*m - *k + 1 + (*n - *m + 1) *
r_dim1], lda);
clacpy_("Upper", k, k, &af[*m - *k + 1 + (*n - *k + 1) * af_dim1], lda, &
r__[*m - *k + 1 + (*n - *k + 1) * r_dim1], lda);
/* Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)' */
cgemm_("No transpose", "Conjugate transpose", k, m, n, &c_b14, &a[*m - *k
+ 1 + a_dim1], lda, &q[q_offset], lda, &c_b15, &r__[*m - *k + 1 +
(*n - *m + 1) * r_dim1], lda);
/* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = clange_("1", k, n, &a[*m - *k + 1 + a_dim1], lda, &rwork[1]);
resid = clange_("1", k, m, &r__[*m - *k + 1 + (*n - *m + 1) * r_dim1],
lda, &rwork[1]);
if (anorm > 0.f) {
result[1] = resid / (real) max(1,*n) / anorm / eps;
} else {
result[1] = 0.f;
}
/* Compute I - Q*Q' */
claset_("Full", m, m, &c_b9, &c_b15, &r__[r_offset], lda);
cherk_("Upper", "No transpose", m, n, &c_b23, &q[q_offset], lda, &c_b24, &
r__[r_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = clansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);
result[2] = resid / (real) max(1,*n) / eps;
return 0;
/* End of CRQT02 */
} /* crqt02_ */
/* Subroutine */ int csyt02_(char *uplo, integer *n, integer *nrhs, complex *
a, integer *lda, complex *x, integer *ldx, complex *b, integer *ldb,
real *rwork, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2;
complex q__1;
/* Local variables */
integer j;
real eps, anorm, bnorm;
extern /* Subroutine */ int csymm_(char *, char *, integer *, integer *,
complex *, complex *, integer *, complex *, integer *, complex *,
complex *, integer *);
real xnorm;
extern doublereal slamch_(char *), clansy_(char *, char *,
integer *, complex *, integer *, real *), scasum_(
integer *, complex *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CSYT02 computes the residual for a solution to a complex symmetric */
/* system of linear equations A*x = b: */
/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of B, the matrix of right hand sides. */
/* NRHS >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The original complex symmetric matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* X (input) COMPLEX array, dimension (LDX,NRHS) */
/* The computed solution vectors for the system of linear */
/* equations. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the right hand side vectors for the system of */
/* linear equations. */
/* On exit, B is overwritten with the difference B - A*X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* The maximum over the number of right hand sides of */
/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0 */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--rwork;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = clansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute B - A*X (or B - A'*X ) and store in B . */
q__1.r = -1.f, q__1.i = -0.f;
csymm_("Left", uplo, n, nrhs, &q__1, &a[a_offset], lda, &x[x_offset], ldx,
&c_b1, &b[b_offset], ldb);
/* Compute the maximum over the number of right hand sides of */
/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bnorm = scasum_(n, &b[j * b_dim1 + 1], &c__1);
xnorm = scasum_(n, &x[j * x_dim1 + 1], &c__1);
if (xnorm <= 0.f) {
*resid = 1.f / eps;
} else {
/* Computing MAX */
r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
*resid = dmax(r__1,r__2);
}
/* L10: */
}
return 0;
/* End of CSYT02 */
} /* csyt02_ */
/* Subroutine */ int cchksy_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval, real *
thresh, logical *tsterr, integer *nmax, complex *a, complex *afac,
complex *ainv, complex *b, complex *x, complex *xact, complex *work,
real *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NB =\002,i4,\002, type \002,i2,\002, test \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) =\002,g"
"12.5)";
static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, n, i1, i2, nb, in, kl, ku, nt, lda, inb, ioff, mode,
imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *), cget04_(
integer *, integer *, complex *, integer *, complex *, integer *,
real *, real *);
integer nfail, iseed[4];
real rcond;
integer nimat;
extern doublereal sget06_(real *, real *);
extern /* Subroutine */ int cpot05_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, complex *, integer *, complex
*, integer *, real *, real *, real *);
real anorm;
extern /* Subroutine */ int csyt01_(char *, integer *, complex *, integer
*, complex *, integer *, integer *, complex *, integer *, real *,
real *), csyt02_(char *, integer *, integer *, complex *,
integer *, complex *, integer *, complex *, integer *, real *,
real *), csyt03_(char *, integer *, complex *, integer *,
complex *, integer *, complex *, integer *, real *, real *, real *
);
integer iuplo, izero, nerrs, lwork;
logical zerot;
char xtype[1];
extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), alaerh_(char *, char *, integer *,
integer *, char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *);
real rcondc;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), clarhs_(char *, char
*, char *, char *, integer *, integer *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, integer *, integer *),
alasum_(char *, integer *, integer *, integer *, integer *);
real cndnum;
extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
*, char *, real *, integer *, real *, real *, integer *, integer *
, char *, complex *, integer *, complex *, integer *);
extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
real *);
logical trfcon;
extern /* Subroutine */ int csycon_(char *, integer *, complex *, integer
*, integer *, real *, real *, complex *, integer *),
clatsy_(char *, integer *, complex *, integer *, integer *), xlaenv_(integer *, integer *), cerrsy_(char *, integer *), csyrfs_(char *, integer *, integer *, complex *,
integer *, complex *, integer *, integer *, complex *, integer *,
complex *, integer *, real *, real *, complex *, real *, integer *
), csytrf_(char *, integer *, complex *, integer *,
integer *, complex *, integer *, integer *), csytri_(char
*, integer *, complex *, integer *, integer *, complex *, integer
*);
real result[8];
extern /* Subroutine */ int csytrs_(char *, integer *, integer *, complex
*, integer *, integer *, complex *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKSY tests CSYTRF, -TRI, -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. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the blocksize NB. */
/* 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. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* 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(2,NSMAX)) */
/* RWORK (workspace) REAL array, */
/* dimension (NMAX+2*NSMAX) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "SY", (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) {
cerrsy_(path, nout);
}
infoc_1.infot = 0;
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 11;
if (n <= 0) {
nimat = 1;
}
izero = 0;
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L170;
}
/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 6;
if (zerot && n < imat - 2) {
goto L170;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (imat != 11) {
/* Set up parameters with CLATB4 and generate a test */
/* matrix with CLATMS. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &
mode, &cndnum, dist);
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)6, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, "N", &a[1], &lda, &work[
1], &info);
/* Check error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
goto L160;
}
/* For types 3-6, zero one or more rows and columns of */
/* the matrix to test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
if (imat < 6) {
/* Set row and column IZERO to zero. */
if (iuplo == 1) {
ioff = (izero - 1) * lda;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0.f, a[i__4].i = 0.f;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0.f, a[i__4].i = 0.f;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L50: */
}
}
} else {
if (iuplo == 1) {
/* Set the first IZERO rows to zero. */
ioff = 0;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i2 = min(j,izero);
i__4 = i2;
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = ioff + i__;
a[i__5].r = 0.f, a[i__5].i = 0.f;
/* L60: */
}
ioff += lda;
/* L70: */
}
} else {
/* Set the last IZERO rows to zero. */
ioff = 0;
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i1 = max(j,izero);
i__4 = n;
for (i__ = i1; i__ <= i__4; ++i__) {
i__5 = ioff + i__;
a[i__5].r = 0.f, a[i__5].i = 0.f;
/* L80: */
}
ioff += lda;
/* L90: */
}
}
}
} else {
izero = 0;
}
} else {
/* Use a special block diagonal matrix to test alternate */
/* code for the 2 x 2 blocks. */
clatsy_(uplo, &n, &a[1], &lda, iseed);
}
/* Do for each value of NB in NBVAL */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the L*D*L' or U*D*U' factorization of the */
/* matrix. */
clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
lwork = max(2,nb) * lda;
s_copy(srnamc_1.srnamt, "CSYTRF", (ftnlen)6, (ftnlen)6);
csytrf_(uplo, &n, &afac[1], &lda, &iwork[1], &ainv[1], &
lwork, &info);
/* Adjust the expected value of INFO to account for */
/* pivoting. */
k = izero;
if (k > 0) {
L100:
if (iwork[k] < 0) {
if (iwork[k] != -k) {
k = -iwork[k];
goto L100;
}
} else if (iwork[k] != k) {
k = iwork[k];
goto L100;
}
}
/* Check error code from CSYTRF. */
if (info != k) {
alaerh_(path, "CSYTRF", &info, &k, uplo, &n, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
}
if (info != 0) {
trfcon = TRUE_;
} else {
trfcon = FALSE_;
}
/* + TEST 1 */
/* Reconstruct matrix from factors and compute residual. */
csyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[1],
&ainv[1], &lda, &rwork[1], result);
nt = 1;
/* + TEST 2 */
/* Form the inverse and compute the residual. */
if (inb == 1 && ! trfcon) {
clacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "CSYTRI", (ftnlen)6, (ftnlen)
6);
csytri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
&info);
/* Check error code from CSYTRI. */
if (info != 0) {
alaerh_(path, "CSYTRI", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
nerrs, nout);
}
csyt03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[
1], &lda, &rwork[1], &rcondc, &result[1]);
nt = 2;
}
/* Print information about the tests that did not pass */
/* the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (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;
}
/* L110: */
}
nrun += nt;
/* Skip the other tests if this is not the first block */
/* size. */
if (inb > 1) {
goto L150;
}
/* Do only the condition estimate if INFO is not 0. */
if (trfcon) {
rcondc = 0.f;
goto L140;
}
i__4 = *nns;
for (irhs = 1; irhs <= i__4; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 3 */
/* Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)6, (ftnlen)
6);
clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "CSYTRS", (ftnlen)6, (ftnlen)
6);
csytrs_(uplo, &n, &nrhs, &afac[1], &lda, &iwork[1], &
x[1], &lda, &info);
/* Check error code from CSYTRS. */
if (info != 0) {
alaerh_(path, "CSYTRS", &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);
csyt02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
/* + TESTS 5, 6, and 7 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "CSYRFS", (ftnlen)6, (ftnlen)
6);
csyrfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
&iwork[1], &b[1], &lda, &x[1], &lda, &rwork[1]
, &rwork[nrhs + 1], &work[1], &rwork[(nrhs <<
1) + 1], &info);
/* Check error code from CSYRFS. */
if (info != 0) {
alaerh_(path, "CSYRFS", &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[4]);
cpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &rwork[
nrhs + 1], &result[5]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
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;
}
/* L120: */
}
nrun += 5;
/* L130: */
}
/* + TEST 8 */
/* Get an estimate of RCOND = 1/CNDNUM. */
L140:
anorm = clansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
s_copy(srnamc_1.srnamt, "CSYCON", (ftnlen)6, (ftnlen)6);
csycon_(uplo, &n, &afac[1], &lda, &iwork[1], &anorm, &
rcond, &work[1], &info);
/* Check error code from CSYCON. */
if (info != 0) {
alaerh_(path, "CSYCON", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
result[7] = sget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass */
/* the threshold. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real)
);
e_wsfe();
++nfail;
}
++nrun;
L150:
;
}
L160:
;
}
L170:
;
}
/* L180: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CCHKSY */
} /* cchksy_ */
/* Subroutine */ int cqrt02_(integer *m, integer *n, integer *k, complex *a,
complex *af, complex *q, complex *r__, integer *lda, complex *tau,
complex *work, integer *lwork, real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
r_offset, i__1;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), cherk_(char *,
char *, integer *, integer *, real *, complex *, integer *, real *
, complex *, integer *);
static real resid, anorm;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *);
extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
real *);
extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *);
static real eps;
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CQRT02 tests CUNGQR, which generates an m-by-n matrix Q with
orthonornmal columns that is defined as the product of k elementary
reflectors.
Given the QR factorization of an m-by-n matrix A, CQRT02 generates
the orthogonal matrix Q defined by the factorization of the first k
columns of A; it compares R(1:n,1:k) with Q(1:m,1:n)'*A(1:m,1:k),
and checks that the columns of Q are orthonormal.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q to be generated. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q to be generated.
M >= N >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. N >= K >= 0.
A (input) COMPLEX array, dimension (LDA,N)
The m-by-n matrix A which was factorized by CQRT01.
AF (input) COMPLEX array, dimension (LDA,N)
Details of the QR factorization of A, as returned by CGEQRF.
See CGEQRF for further details.
Q (workspace) COMPLEX array, dimension (LDA,N)
R (workspace) COMPLEX array, dimension (LDA,N)
LDA (input) INTEGER
The leading dimension of the arrays A, AF, Q and R. LDA >= M.
TAU (input) COMPLEX array, dimension (N)
The scalar factors of the elementary reflectors corresponding
to the QR factorization in AF.
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
RWORK (workspace) REAL array, dimension (M)
RESULT (output) REAL array, dimension (2)
The test ratios:
RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS )
RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
=====================================================================
Parameter adjustments */
r_dim1 = *lda;
r_offset = 1 + r_dim1 * 1;
r__ -= r_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
eps = slamch_("Epsilon");
/* Copy the first k columns of the factorization to the array Q */
claset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
i__1 = *m - 1;
clacpy_("Lower", &i__1, k, &af_ref(2, 1), lda, &q_ref(2, 1), lda);
/* Generate the first n columns of the matrix Q */
s_copy(srnamc_1.srnamt, "CUNGQR", (ftnlen)6, (ftnlen)6);
cungqr_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy R(1:n,1:k) */
claset_("Full", n, k, &c_b8, &c_b8, &r__[r_offset], lda);
clacpy_("Upper", n, k, &af[af_offset], lda, &r__[r_offset], lda);
/* Compute R(1:n,1:k) - Q(1:m,1:n)' * A(1:m,1:k) */
cgemm_("Conjugate transpose", "No transpose", n, k, m, &c_b13, &q[
q_offset], lda, &a[a_offset], lda, &c_b14, &r__[r_offset], lda);
/* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) . */
anorm = clange_("1", m, k, &a[a_offset], lda, &rwork[1]);
resid = clange_("1", n, k, &r__[r_offset], lda, &rwork[1]);
if (anorm > 0.f) {
result[1] = resid / (real) max(1,*m) / anorm / eps;
} else {
result[1] = 0.f;
}
/* Compute I - Q'*Q */
claset_("Full", n, n, &c_b8, &c_b14, &r__[r_offset], lda);
cherk_("Upper", "Conjugate transpose", n, m, &c_b22, &q[q_offset], lda, &
c_b23, &r__[r_offset], lda);
/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
resid = clansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
result[2] = resid / (real) max(1,*m) / eps;
return 0;
/* End of CQRT02 */
} /* cqrt02_ */
/* Subroutine */ int csyt02_(char *uplo, integer *n, integer *nrhs, complex *
a, integer *lda, complex *x, integer *ldx, complex *b, integer *ldb,
real *rwork, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2;
complex q__1;
/* Local variables */
static integer j;
static real anorm, bnorm;
extern /* Subroutine */ int csymm_(char *, char *, integer *, integer *,
complex *, complex *, integer *, complex *, integer *, complex *,
complex *, integer *);
static real xnorm;
extern doublereal slamch_(char *), clansy_(char *, char *,
integer *, complex *, integer *, real *), scasum_(
integer *, complex *, integer *);
static real eps;
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CSYT02 computes the residual for a solution to a complex symmetric
system of linear equations A*x = b:
RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ),
where EPS is the machine epsilon.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
symmetric matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The number of rows and columns of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of columns of B, the matrix of right hand sides.
NRHS >= 0.
A (input) COMPLEX array, dimension (LDA,N)
The original complex symmetric matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N)
X (input) COMPLEX array, dimension (LDX,NRHS)
The computed solution vectors for the system of linear
equations.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
B (input/output) COMPLEX array, dimension (LDB,NRHS)
On entry, the right hand side vectors for the system of
linear equations.
On exit, B is overwritten with the difference B - A*X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
RWORK (workspace) REAL array, dimension (N)
RESID (output) REAL
The maximum over the number of right hand sides of
norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
=====================================================================
Quick exit if N = 0 or NRHS = 0
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--rwork;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = clansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute B - A*X (or B - A'*X ) and store in B . */
q__1.r = -1.f, q__1.i = 0.f;
csymm_("Left", uplo, n, nrhs, &q__1, &a[a_offset], lda, &x[x_offset], ldx,
&c_b1, &b[b_offset], ldb);
/* Compute the maximum over the number of right hand sides of
norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bnorm = scasum_(n, &b_ref(1, j), &c__1);
xnorm = scasum_(n, &x_ref(1, j), &c__1);
if (xnorm <= 0.f) {
*resid = 1.f / eps;
} else {
/* Computing MAX */
r__1 = *resid, r__2 = bnorm / anorm / xnorm / eps;
*resid = dmax(r__1,r__2);
}
/* L10: */
}
return 0;
/* End of CSYT02 */
} /* csyt02_ */
/* Subroutine */ int csyrfsx_(char *uplo, char *equed, integer *n, integer *
nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
ipiv, real *s, complex *b, integer *ldb, complex *x, integer *ldx,
real *rcond, real *berr, integer *n_err_bnds__, real *err_bnds_norm__,
real *err_bnds_comp__, integer *nparams, real *params, complex *work,
real *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
real r__1, r__2;
/* Local variables */
real illrcond_thresh__, unstable_thresh__, err_lbnd__;
integer ref_type__;
integer j;
real rcond_tmp__;
integer prec_type__;
real cwise_wrong__;
char norm[1];
logical ignore_cwise__;
real anorm;
logical rcequ;
integer ithresh, n_norms__;
real rthresh;
/* -- LAPACK routine (version 3.2.1) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- April 2009 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* Purpose */
/* ======= */
/* CSYRFSX improves the computed solution to a system of linear */
/* equations when the coefficient matrix is symmetric indefinite, and */
/* provides error bounds and backward error estimates for the */
/* solution. In addition to normwise error bound, the code provides */
/* maximum componentwise error bound if possible. See comments for */
/* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds. */
/* The original system of linear equations may have been equilibrated */
/* before calling this routine, as described by arguments EQUED and S */
/* below. In this case, the solution and error bounds returned are */
/* for the original unequilibrated system. */
/* Arguments */
/* ========= */
/* Some optional parameters are bundled in the PARAMS array. These */
/* settings determine how refinement is performed, but often the */
/* defaults are acceptable. If the defaults are acceptable, users */
/* can pass NPARAMS = 0 which prevents the source code from accessing */
/* the PARAMS argument. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* EQUED (input) CHARACTER*1 */
/* Specifies the form of equilibration that was done to A */
/* before calling this routine. This is needed to compute */
/* the solution and error bounds correctly. */
/* = 'N': No equilibration */
/* = 'Y': Both row and column equilibration, i.e., A has been */
/* replaced by diag(S) * A * diag(S). */
/* The right hand side B has been changed accordingly. */
/* 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 B and X. NRHS >= 0. */
/* A (input) COMPLEX 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). */
/* AF (input) COMPLEX array, dimension (LDAF,N) */
/* The factored form of the matrix A. AF contains the block */
/* diagonal matrix D and the multipliers used to obtain the */
/* factor U or L from the factorization A = U*D*U**T or A = */
/* L*D*L**T as computed by SSYTRF. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by SSYTRF. */
/* S (input or output) REAL array, dimension (N) */
/* The scale factors for A. If EQUED = 'Y', A is multiplied on */
/* the left and right by diag(S). S is an input argument if FACT = */
/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
/* = 'Y', each element of S must be positive. If S is output, each */
/* element of S is a power of the radix. If S is input, each element */
/* of S should be a power of the radix to ensure a reliable solution */
/* and error estimates. Scaling by powers of the radix does not cause */
/* rounding errors unless the result underflows or overflows. */
/* Rounding errors during scaling lead to refining with a matrix that */
/* is not equivalent to the input matrix, producing error estimates */
/* that may not be reliable. */
/* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by SGETRS. */
/* On exit, the improved solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) REAL */
/* Reciprocal scaled condition number. This is an estimate of the */
/* reciprocal Skeel condition number of the matrix A after */
/* equilibration (if done). If this is less than the machine */
/* precision (in particular, if it is zero), the matrix is singular */
/* to working precision. Note that the error may still be small even */
/* if this number is very small and the matrix appears ill- */
/* conditioned. */
/* BERR (output) REAL array, dimension (NRHS) */
/* Componentwise relative backward error. This is 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). */
/* N_ERR_BNDS (input) INTEGER */
/* Number of error bounds to return for each right hand side */
/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
/* ERR_BNDS_COMP below. */
/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* normwise relative error, which is defined as follows: */
/* Normwise relative error in the ith solution vector: */
/* max_j (abs(XTRUE(j,i) - X(j,i))) */
/* ------------------------------ */
/* max_j abs(X(j,i)) */
/* The array is indexed by the type of error information as described */
/* below. There currently are up to three pieces of information */
/* returned. */
/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_NORM(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated normwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*A, where S scales each row by a power of the */
/* radix so all absolute row sums of Z are approximately 1. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* componentwise relative error, which is defined as follows: */
/* Componentwise relative error in the ith solution vector: */
/* abs(XTRUE(j,i) - X(j,i)) */
/* max_j ---------------------- */
/* abs(X(j,i)) */
/* The array is indexed by the right-hand side i (on which the */
/* componentwise relative error depends), and the type of error */
/* information as described below. There currently are up to three */
/* pieces of information returned for each right-hand side. If */
/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
/* the first (:,N_ERR_BNDS) entries are returned. */
/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_COMP(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated componentwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*(A*diag(x)), where x is the solution for the */
/* current right-hand side and S scales each row of */
/* A*diag(x) by a power of the radix so all absolute row */
/* sums of Z are approximately 1. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* NPARAMS (input) INTEGER */
/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
/* PARAMS array is never referenced and default values are used. */
/* PARAMS (input / output) REAL array, dimension NPARAMS */
/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
/* that entry will be filled with default value used for that */
/* parameter. Only positions up to NPARAMS are accessed; defaults */
/* are used for higher-numbered parameters. */
/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
/* refinement or not. */
/* Default: 1.0 */
/* = 0.0 : No refinement is performed, and no error bounds are */
/* computed. */
/* = 1.0 : Use the double-precision refinement algorithm, */
/* possibly with doubled-single computations if the */
/* compilation environment does not support DOUBLE */
/* PRECISION. */
/* (other values are reserved for future use) */
/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
/* computations allowed for refinement. */
/* Default: 10 */
/* Aggressive: Set to 100 to permit convergence using approximate */
/* factorizations or factorizations other than LU. If */
/* the factorization uses a technique other than */
/* Gaussian elimination, the guarantees in */
/* err_bnds_norm and err_bnds_comp may no longer be */
/* trustworthy. */
/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
/* will attempt to find a solution with small componentwise */
/* relative error in the double-precision algorithm. Positive */
/* is true, 0.0 is false. */
/* Default: 1.0 (attempt componentwise convergence) */
/* WORK (workspace) COMPLEX array, dimension (2*N) */
/* RWORK (workspace) REAL array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: Successful exit. The solution to every right-hand side is */
/* guaranteed. */
/* < 0: If INFO = -i, the i-th argument had an illegal value */
/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly singular, so */
/* the solution and error bounds could not be computed. RCOND = 0 */
/* is returned. */
/* = N+J: The solution corresponding to the Jth right-hand side is */
/* not guaranteed. The solutions corresponding to other right- */
/* hand sides K with K > J may not be guaranteed as well, but */
/* only the first such right-hand side is reported. If a small */
/* componentwise error is not requested (PARAMS(3) = 0.0) then */
/* the Jth right-hand side is the first with a normwise error */
/* bound that is not guaranteed (the smallest J such */
/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
/* the Jth right-hand side is the first with either a normwise or */
/* componentwise error bound that is not guaranteed (the smallest */
/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
/* about all of the right-hand sides check ERR_BNDS_NORM or */
/* ERR_BNDS_COMP. */
/* ================================================================== */
/* Check the input parameters. */
/* Parameter adjustments */
err_bnds_comp_dim1 = *nrhs;
err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
err_bnds_comp__ -= err_bnds_comp_offset;
err_bnds_norm_dim1 = *nrhs;
err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
err_bnds_norm__ -= err_bnds_norm_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
--s;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--berr;
--params;
--work;
--rwork;
/* Function Body */
*info = 0;
ref_type__ = 1;
if (*nparams >= 1) {
if (params[1] < 0.f) {
params[1] = 1.f;
} else {
ref_type__ = params[1];
}
}
/* Set default parameters. */
illrcond_thresh__ = (real) (*n) * slamch_("Epsilon");
ithresh = 10;
rthresh = .5f;
unstable_thresh__ = .25f;
ignore_cwise__ = FALSE_;
if (*nparams >= 2) {
if (params[2] < 0.f) {
params[2] = (real) ithresh;
} else {
ithresh = (integer) params[2];
}
}
if (*nparams >= 3) {
if (params[3] < 0.f) {
if (ignore_cwise__) {
params[3] = 0.f;
} else {
params[3] = 1.f;
}
} else {
ignore_cwise__ = params[3] == 0.f;
}
}
if (ref_type__ == 0 || *n_err_bnds__ == 0) {
n_norms__ = 0;
} else if (ignore_cwise__) {
n_norms__ = 1;
} else {
n_norms__ = 2;
}
rcequ = lsame_(equed, "Y");
/* Test input parameters. */
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! rcequ && ! lsame_(equed, "N")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (*ldb < max(1,*n)) {
*info = -11;
} else if (*ldx < max(1,*n)) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CSYRFSX", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || *nrhs == 0) {
*rcond = 1.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
berr[j] = 0.f;
if (*n_err_bnds__ >= 1) {
err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
} else if (*n_err_bnds__ >= 2) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.f;
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.f;
} else if (*n_err_bnds__ >= 3) {
err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.f;
err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.f;
}
}
return 0;
}
/* Default to failure. */
*rcond = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
berr[j] = 1.f;
if (*n_err_bnds__ >= 1) {
err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
} else if (*n_err_bnds__ >= 2) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
} else if (*n_err_bnds__ >= 3) {
err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.f;
err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.f;
}
}
/* Compute the norm of A and the reciprocal of the condition */
/* number of A. */
*(unsigned char *)norm = 'I';
anorm = clansy_(norm, uplo, n, &a[a_offset], lda, &rwork[1]);
csycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
info);
/* Perform refinement on each right-hand side */
if (ref_type__ != 0) {
prec_type__ = ilaprec_("D");
cla_syrfsx_extended__(&prec_type__, uplo, n, nrhs, &a[a_offset], lda,
&af[af_offset], ldaf, &ipiv[1], &rcequ, &s[1], &b[b_offset],
ldb, &x[x_offset], ldx, &berr[1], &n_norms__, &
err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[
err_bnds_comp_offset], &work[1], &rwork[1], &work[*n + 1],
(complex *)(&rwork[1]), rcond, &ithresh, &rthresh, &unstable_thresh__, &
ignore_cwise__, info, (ftnlen)1);
}
/* Computing MAX */
r__1 = 10.f, r__2 = sqrt((real) (*n));
err_lbnd__ = dmax(r__1,r__2) * slamch_("Epsilon");
if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
/* Compute scaled normwise condition number cond(A*C). */
if (rcequ) {
rcond_tmp__ = cla_syrcond_c__(uplo, n, &a[a_offset], lda, &af[
af_offset], ldaf, &ipiv[1], &s[1], &c_true, info, &work[1]
, &rwork[1], (ftnlen)1);
} else {
rcond_tmp__ = cla_syrcond_c__(uplo, n, &a[a_offset], lda, &af[
af_offset], ldaf, &ipiv[1], &s[1], &c_false, info, &work[
1], &rwork[1], (ftnlen)1);
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Cap the error at 1.0. */
if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
<< 1)] > 1.f) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
}
/* Threshold the error (see LAWN). */
if (rcond_tmp__ < illrcond_thresh__) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f;
err_bnds_norm__[j + err_bnds_norm_dim1] = 0.f;
if (*info <= *n) {
*info = *n + j;
}
} else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
err_lbnd__) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f;
}
/* Save the condition number. */
if (*n_err_bnds__ >= 3) {
err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
}
}
}
if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
/* each right-hand side using the current solution as an estimate of */
/* the true solution. If the componentwise error estimate is too */
/* large, then the solution is a lousy estimate of truth and the */
/* estimated RCOND may be too optimistic. To avoid misleading users, */
/* the inverse condition number is set to 0.0 when the estimated */
/* cwise error is at least CWISE_WRONG. */
cwise_wrong__ = sqrt(slamch_("Epsilon"));
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
cwise_wrong__) {
rcond_tmp__ = cla_syrcond_x__(uplo, n, &a[a_offset], lda, &af[
af_offset], ldaf, &ipiv[1], &x[j * x_dim1 + 1], info,
&work[1], &rwork[1], (ftnlen)1);
} else {
rcond_tmp__ = 0.f;
}
/* Cap the error at 1.0. */
if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
<< 1)] > 1.f) {
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
}
/* Threshold the error (see LAWN). */
if (rcond_tmp__ < illrcond_thresh__) {
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f;
err_bnds_comp__[j + err_bnds_comp_dim1] = 0.f;
if (params[3] == 1.f && *info < *n + j) {
*info = *n + j;
}
} else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
err_lbnd__) {
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f;
}
/* Save the condition number. */
if (*n_err_bnds__ >= 3) {
err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
}
}
}
return 0;
/* End of CSYRFSX */
} /* csyrfsx_ */
