/* Subroutine */ int cchkhp_(logical *dotype, integer *nn, integer *nval,
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, "
"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)";
/* 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, in, kl, ku, nt, lda, npp, 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];
extern /* Subroutine */ int chpt01_(char *, integer *, complex *, complex
*, integer *, complex *, integer *, real *, real *);
extern logical lsame_(char *, char *);
real rcond;
integer nimat;
extern doublereal sget06_(real *, real *);
extern /* Subroutine */ int cppt02_(char *, integer *, integer *, complex
*, complex *, integer *, complex *, integer *, real *, real *), cppt03_(char *, integer *, complex *, complex *, complex
*, integer *, real *, real *, real *);
real anorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), cppt05_(char *, integer *, integer *,
complex *, complex *, integer *, complex *, integer *, complex *,
integer *, real *, real *, real *);
integer iuplo, izero, nerrs;
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 *), claipd_(integer *, complex *, integer *, integer
*);
extern doublereal clanhp_(char *, char *, integer *, complex *, real *);
real rcondc;
extern /* Subroutine */ int chpcon_(char *, integer *, complex *, integer
*, real *, real *, complex *, integer *);
char packit[1];
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 chprfs_(char *, integer *, integer *, complex
*, complex *, integer *, complex *, integer *, complex *, integer
*, real *, real *, complex *, real *, integer *), chptrf_(
char *, integer *, complex *, integer *, integer *),
clatms_(integer *, integer *, char *, integer *, char *, real *,
integer *, real *, real *, integer *, integer *, char *, complex *
, integer *, complex *, integer *),
chptri_(char *, integer *, complex *, integer *, complex *,
integer *);
logical trfcon;
extern /* Subroutine */ int chptrs_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, integer *), cerrsy_(
char *, integer *);
real result[8];
/* Fortran I/O blocks */
static cilist io___38 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKHP tests CHPTRF, -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. */
/* 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+1)/2) */
/* AFAC (workspace) COMPLEX array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* AINV (workspace) COMPLEX array, dimension */
/* (NMAX*(NMAX+1)/2) */
/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* WORK (workspace) COMPLEX array, dimension */
/* (NMAX*max(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;
--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, "HP", (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 = 10;
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 L160;
}
/* 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 L160;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
if (lsame_(uplo, "U")) {
*(unsigned char *)packit = 'C';
} else {
*(unsigned char *)packit = 'R';
}
/* 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, packit, &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 L150;
}
/* 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) * izero / 2;
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 += i__;
/* 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 = ioff + n - i__;
/* 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 {
ioff = 0;
if (iuplo == 1) {
/* Set the first IZERO rows and columns to zero. */
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 += j;
/* L70: */
}
} else {
/* Set the last IZERO rows and columns to zero. */
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 = ioff + n - j;
/* L90: */
}
}
}
} else {
izero = 0;
}
/* Set the imaginary part of the diagonals. */
if (iuplo == 1) {
claipd_(&n, &a[1], &c__2, &c__1);
} else {
claipd_(&n, &a[1], &n, &c_n1);
}
/* Compute the L*D*L' or U*D*U' factorization of the matrix. */
npp = n * (n + 1) / 2;
ccopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
s_copy(srnamc_1.srnamt, "CHPTRF", (ftnlen)6, (ftnlen)6);
chptrf_(uplo, &n, &afac[1], &iwork[1], &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 CHPTRF. */
if (info != k) {
alaerh_(path, "CHPTRF", &info, &k, uplo, &n, &n, &c_n1, &
c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
if (info != 0) {
trfcon = TRUE_;
} else {
trfcon = FALSE_;
}
/* + TEST 1 */
/* Reconstruct matrix from factors and compute residual. */
chpt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1], &lda,
&rwork[1], result);
nt = 1;
/* + TEST 2 */
/* Form the inverse and compute the residual. */
if (! trfcon) {
ccopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
s_copy(srnamc_1.srnamt, "CHPTRI", (ftnlen)6, (ftnlen)6);
chptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &info);
/* Check error code from CHPTRI. */
if (info != 0) {
alaerh_(path, "CHPTRI", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
cppt03_(uplo, &n, &a[1], &ainv[1], &work[1], &lda, &rwork[
1], &rcondc, &result[1]);
nt = 2;
}
/* 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) {
alahd_(nout, path);
}
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&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;
/* Do only the condition estimate if INFO is not 0. */
if (trfcon) {
rcondc = 0.f;
goto L140;
}
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++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);
*(unsigned char *)xtype = 'C';
clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "CHPTRS", (ftnlen)6, (ftnlen)6);
chptrs_(uplo, &n, &nrhs, &afac[1], &iwork[1], &x[1], &lda,
&info);
/* Check error code from CHPTRS. */
if (info != 0) {
alaerh_(path, "CHPTRS", &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);
cppt02_(uplo, &n, &nrhs, &a[1], &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, "CHPRFS", (ftnlen)6, (ftnlen)6);
chprfs_(uplo, &n, &nrhs, &a[1], &afac[1], &iwork[1], &b[1]
, &lda, &x[1], &lda, &rwork[1], &rwork[nrhs + 1],
&work[1], &rwork[(nrhs << 1) + 1], &info);
/* Check error code from CHPRFS. */
if (info != 0) {
alaerh_(path, "CHPRFS", &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]);
cppt05_(uplo, &n, &nrhs, &a[1], &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___41.ciunit = *nout;
s_wsfe(&io___41);
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 = clanhp_("1", uplo, &n, &a[1], &rwork[1]);
s_copy(srnamc_1.srnamt, "CHPCON", (ftnlen)6, (ftnlen)6);
chpcon_(uplo, &n, &afac[1], &iwork[1], &anorm, &rcond, &work[
1], &info);
/* Check error code from CHPCON. */
if (info != 0) {
alaerh_(path, "CHPCON", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
result[7] = sget06_(&rcond, &rcondc);
/* Print the test ratio if it is .GE. THRESH. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___43.ciunit = *nout;
s_wsfe(&io___43);
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: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CCHKHP */
} /* cchkhp_ */
/* Subroutine */ int chpt01_(char *uplo, integer *n, complex *a, complex *
afac, integer *ipiv, complex *c__, integer *ldc, real *rwork, real *
resid)
{
/* System generated locals */
integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5;
real r__1;
complex q__1;
/* Local variables */
integer i__, j, jc;
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 */
/* ======= */
/* CHPT01 reconstructs a Hermitian indefinite packed 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 conjugate transpose of L, and U' is the conjugate transpose */
/* of U. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian 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 (N*(N+1)/2) */
/* The original Hermitian matrix A, stored as a packed */
/* triangular matrix. */
/* AFAC (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The factored form of the matrix A, stored as a packed */
/* triangular matrix. 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 CHPTRF. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from CHPTRF. */
/* 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;
--afac;
--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 = clanhp_("1", uplo, n, &a[1], &rwork[1]);
/* Check the imaginary parts of the diagonal elements and return with */
/* an error code if any are nonzero. */
jc = 1;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (r_imag(&afac[jc]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
jc = jc + j + 1;
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (r_imag(&afac[jc]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
jc = jc + *n - j + 1;
/* L20: */
}
}
/* Initialize C to the identity matrix. */
claset_("Full", n, n, &c_b1, &c_b2, &c__[c_offset], ldc);
/* Call CLAVHP to form the product D * U' (or D * L' ). */
clavhp_(uplo, "Conjugate", "Non-unit", n, n, &afac[1], &ipiv[1], &c__[
c_offset], ldc, &info);
/* Call CLAVHP again to multiply by U ( or L ). */
clavhp_(uplo, "No transpose", "Unit", n, n, &afac[1], &ipiv[1], &c__[
c_offset], ldc, &info);
/* Compute the difference C - A . */
if (lsame_(uplo, "U")) {
jc = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = jc + i__;
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: */
}
i__2 = j + j * c_dim1;
i__3 = j + j * c_dim1;
i__4 = jc + j;
r__1 = a[i__4].r;
q__1.r = c__[i__3].r - r__1, q__1.i = c__[i__3].i;
c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
jc += j;
/* L40: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * c_dim1;
i__3 = j + j * c_dim1;
i__4 = jc;
r__1 = a[i__4].r;
q__1.r = c__[i__3].r - r__1, q__1.i = c__[i__3].i;
c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = jc + i__ - j;
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;
/* L50: */
}
jc = jc + *n - j + 1;
/* L60: */
}
}
/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
*resid = clanhe_("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 CHPT01 */
} /* chpt01_ */
/* Subroutine */ int cppt02_(char *uplo, integer *n, integer *nrhs, complex *
a, complex *x, integer *ldx, complex *b, integer *ldb, real *rwork,
real *resid)
{
/* System generated locals */
integer 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;
real xnorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPPT02 computes the residual in the solution of a Hermitian system */
/* of linear equations A*x = b when packed storage is used for the */
/* coefficient matrix. The ratio computed is */
/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS), */
/* where EPS is the machine precision. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian 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 (N*(N+1)/2) */
/* The original Hermitian matrix A, stored as a packed */
/* triangular matrix. */
/* 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;
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 = clanhp_("1", uplo, n, &a[1], &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Compute B - A*X for the matrix of right hand sides B. */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
q__1.r = -1.f, q__1.i = -0.f;
chpmv_(uplo, n, &q__1, &a[1], &x[j * x_dim1 + 1], &c__1, &c_b1, &b[j *
b_dim1 + 1], &c__1);
/* L10: */
}
/* Compute the maximum over the number of right hand sides of */
/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
*resid = 0.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);
}
/* L20: */
}
return 0;
/* End of CPPT02 */
} /* cppt02_ */
/* Subroutine */ int cppt03_(char *uplo, integer *n, complex *a, complex *
ainv, complex *work, integer *ldwork, real *rwork, real *rcond, real *
resid)
{
/* System generated locals */
integer work_dim1, work_offset, i__1, i__2, i__3;
complex q__1;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j, jj;
real eps;
extern logical lsame_(char *, char *);
real anorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), chpmv_(char *, integer *, complex *,
complex *, complex *, integer *, complex *, complex *, integer *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), clanhp_(char *, char *, integer *,
complex *, real *), slamch_(char *);
real ainvnm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPPT03 computes the residual for a Hermitian packed 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 */
/* Hermitian 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 (N*(N+1)/2) */
/* The original Hermitian matrix A, stored as a packed */
/* triangular matrix. */
/* AINV (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The (Hermitian) inverse of the matrix A, stored as a packed */
/* triangular matrix. */
/* 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 */
/* ( 1/norm(A) ) / norm(AINV). */
/* RESID (output) REAL */
/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
--a;
--ainv;
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 = clanhp_("1", uplo, n, &a[1], &rwork[1]);
ainvnm = clanhp_("1", uplo, n, &ainv[1], &rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
*rcond = 0.f;
*resid = 1.f / eps;
return 0;
}
*rcond = 1.f / anorm / ainvnm;
/* UPLO = 'U': */
/* Copy the leading N-1 x N-1 submatrix of AINV to WORK(1:N,2:N) and */
/* expand it to a full matrix, then multiply by A one column at a */
/* time, moving the result one column to the left. */
if (lsame_(uplo, "U")) {
/* Copy AINV */
jj = 1;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
ccopy_(&j, &ainv[jj], &c__1, &work[(j + 1) * work_dim1 + 1], &
c__1);
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + (i__ + 1) * work_dim1;
r_cnjg(&q__1, &ainv[jj + i__ - 1]);
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L10: */
}
jj += j;
/* L20: */
}
jj = (*n - 1) * *n / 2 + 1;
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n + (i__ + 1) * work_dim1;
r_cnjg(&q__1, &ainv[jj + i__ - 1]);
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L30: */
}
/* Multiply by A */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
q__1.r = -1.f, q__1.i = -0.f;
chpmv_("Upper", n, &q__1, &a[1], &work[(j + 1) * work_dim1 + 1], &
c__1, &c_b1, &work[j * work_dim1 + 1], &c__1);
/* L40: */
}
q__1.r = -1.f, q__1.i = -0.f;
chpmv_("Upper", n, &q__1, &a[1], &ainv[jj], &c__1, &c_b1, &work[*n *
work_dim1 + 1], &c__1);
/* UPLO = 'L': */
/* Copy the trailing N-1 x N-1 submatrix of AINV to WORK(1:N,1:N-1) */
/* and multiply by A, moving each column to the right. */
} else {
/* Copy AINV */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ * work_dim1 + 1;
r_cnjg(&q__1, &ainv[i__ + 1]);
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L50: */
}
jj = *n + 1;
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
i__2 = *n - j + 1;
ccopy_(&i__2, &ainv[jj], &c__1, &work[j + (j - 1) * work_dim1], &
c__1);
i__2 = *n - j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + (j + i__ - 1) * work_dim1;
r_cnjg(&q__1, &ainv[jj + i__]);
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L60: */
}
jj = jj + *n - j + 1;
/* L70: */
}
/* Multiply by A */
for (j = *n; j >= 2; --j) {
q__1.r = -1.f, q__1.i = -0.f;
chpmv_("Lower", n, &q__1, &a[1], &work[(j - 1) * work_dim1 + 1], &
c__1, &c_b1, &work[j * work_dim1 + 1], &c__1);
/* L80: */
}
q__1.r = -1.f, q__1.i = -0.f;
chpmv_("Lower", n, &q__1, &a[1], &ainv[1], &c__1, &c_b1, &work[
work_dim1 + 1], &c__1);
}
/* 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;
/* L90: */
}
/* 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 CPPT03 */
} /* cppt03_ */
/* Subroutine */ int chpev_(char *jobz, char *uplo, integer *n, complex *ap,
real *w, complex *z, integer *ldz, complex *work, real *rwork,
integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
CHPEV computes all the eigenvalues and, optionally, eigenvectors of a
complex Hermitian matrix in packed storage.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the Hermitian matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
On exit, AP is overwritten by values generated during the
reduction to tridiagonal form. If UPLO = 'U', the diagonal
and first superdiagonal of the tridiagonal matrix T overwrite
the corresponding elements of A, and if UPLO = 'L', the
diagonal and first subdiagonal of T overwrite the
corresponding elements of A.
W (output) REAL array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
Z (output) COMPLEX array, dimension (LDZ, N)
If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
eigenvectors of the matrix A, with the i-th column of Z
holding the eigenvector associated with W(i).
If JOBZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
WORK (workspace) COMPLEX array, dimension (max(1, 2*N-1))
RWORK (workspace) REAL array, dimension (max(1, 3*N-2))
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = i, the algorithm failed to converge; i
off-diagonal elements of an intermediate tridiagonal
form did not converge to zero.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer z_dim1, z_offset, i__1;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer inde;
static real anrm;
static integer imax;
static real rmin, rmax, sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static logical wantz;
static integer iscale;
extern doublereal clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
static integer indtau;
extern /* Subroutine */ int chptrd_(char *, integer *, complex *, real *,
real *, complex *, integer *);
static integer indrwk, indwrk;
extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
complex *, integer *, real *, integer *), cupgtr_(char *,
integer *, complex *, complex *, complex *, integer *, complex *,
integer *), ssterf_(integer *, real *, real *, integer *);
static real smlnum, eps;
#define AP(I) ap[(I)-1]
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
wantz = lsame_(jobz, "V");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lsame_(uplo, "L") || lsame_(uplo, "U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPEV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
W(1) = AP(1).r;
RWORK(1) = 1.f;
if (wantz) {
i__1 = z_dim1 + 1;
Z(1,1).r = 1.f, Z(1,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);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = clanhp_("M", uplo, n, &AP(1), &RWORK(1));
iscale = 0;
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
i__1 = *n * (*n + 1) / 2;
csscal_(&i__1, &sigma, &AP(1), &c__1);
}
/* Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form.
*/
inde = 1;
indtau = 1;
chptrd_(uplo, n, &AP(1), &W(1), &RWORK(inde), &WORK(indtau), &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, first call
CUPGTR to generate the orthogonal matrix, then call CSTEQR. */
if (! wantz) {
ssterf_(n, &W(1), &RWORK(inde), info);
} else {
indwrk = indtau + *n;
cupgtr_(uplo, n, &AP(1), &WORK(indtau), &Z(1,1), ldz, &WORK(
indwrk), &iinfo);
indrwk = inde + *n;
csteqr_(jobz, n, &W(1), &RWORK(inde), &Z(1,1), ldz, &RWORK(
indrwk), info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &W(1), &c__1);
}
return 0;
/* End of CHPEV */
} /* chpev_ */
/* Subroutine */
int chpevd_(char *jobz, char *uplo, integer *n, complex *ap, real *w, complex *z__, integer *ldz, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real eps;
integer inde;
real anrm;
integer imax;
real rmin, rmax, sigma;
extern logical lsame_(char *, char *);
integer iinfo;
extern /* Subroutine */
int sscal_(integer *, real *, real *, integer *);
integer lwmin, llrwk, llwrk;
logical wantz;
integer iscale;
extern real clanhp_(char *, char *, integer *, complex *, real *);
extern /* Subroutine */
int cstedc_(char *, integer *, real *, real *, complex *, integer *, complex *, integer *, real *, integer *, integer *, integer *, integer *);
extern real slamch_(char *);
extern /* Subroutine */
int csscal_(integer *, real *, complex *, integer *);
real safmin;
extern /* Subroutine */
int xerbla_(char *, integer *);
real bignum;
integer indtau;
extern /* Subroutine */
int chptrd_(char *, integer *, complex *, real *, real *, complex *, integer *);
integer indrwk, indwrk, liwmin;
extern /* Subroutine */
int ssterf_(integer *, real *, real *, integer *);
integer lrwmin;
extern /* Subroutine */
int cupmtr_(char *, char *, char *, integer *, integer *, complex *, complex *, complex *, integer *, complex *, integer *);
real smlnum;
logical lquery;
/* -- LAPACK driver routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
*info = 0;
if (! (wantz || lsame_(jobz, "N")))
{
*info = -1;
}
else if (! (lsame_(uplo, "L") || lsame_(uplo, "U")))
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
else if (*ldz < 1 || wantz && *ldz < *n)
{
*info = -7;
}
if (*info == 0)
{
if (*n <= 1)
{
lwmin = 1;
liwmin = 1;
lrwmin = 1;
}
else
{
if (wantz)
{
lwmin = *n << 1;
/* Computing 2nd power */
i__1 = *n;
lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
liwmin = *n * 5 + 3;
}
else
{
lwmin = *n;
lrwmin = *n;
liwmin = 1;
}
}
work[1].r = (real) lwmin;
work[1].i = 0.f; // , expr subst
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery)
{
*info = -9;
}
else if (*lrwork < lrwmin && ! lquery)
{
*info = -11;
}
else if (*liwork < liwmin && ! lquery)
{
*info = -13;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CHPEVD", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
if (*n == 1)
{
w[1] = ap[1].r;
if (wantz)
{
i__1 = z_dim1 + 1;
z__[i__1].r = 1.f;
z__[i__1].i = 0.f; // , expr subst
}
return 0;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = clanhp_("M", uplo, n, &ap[1], &rwork[1]);
iscale = 0;
if (anrm > 0.f && anrm < rmin)
{
iscale = 1;
sigma = rmin / anrm;
}
else if (anrm > rmax)
{
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1)
{
i__1 = *n * (*n + 1) / 2;
csscal_(&i__1, &sigma, &ap[1], &c__1);
}
/* Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form. */
inde = 1;
indtau = 1;
indrwk = inde + *n;
indwrk = indtau + *n;
llwrk = *lwork - indwrk + 1;
llrwk = *lrwork - indrwk + 1;
chptrd_(uplo, n, &ap[1], &w[1], &rwork[inde], &work[indtau], &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, first call */
/* CUPGTR to generate the orthogonal matrix, then call CSTEDC. */
if (! wantz)
{
ssterf_(n, &w[1], &rwork[inde], info);
}
else
{
cstedc_("I", n, &w[1], &rwork[inde], &z__[z_offset], ldz, &work[ indwrk], &llwrk, &rwork[indrwk], &llrwk, &iwork[1], liwork, info);
cupmtr_("L", uplo, "N", n, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[indwrk], &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1)
{
if (*info == 0)
{
imax = *n;
}
else
{
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &w[1], &c__1);
}
work[1].r = (real) lwmin;
work[1].i = 0.f; // , expr subst
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
return 0;
/* End of CHPEVD */
}
/* Subroutine */ int cdrvpp_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, real *thresh, logical *tsterr, integer *nmax, complex *
a, complex *afac, complex *asav, complex *b, complex *bsav, complex *
x, complex *xact, real *s, complex *work, real *rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char facts[1*3] = "F" "N" "E";
static char packs[1*2] = "C" "R";
static char equeds[1*2] = "N" "Y";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9997[] = "(1x,a6,\002, FACT='\002,a1,\002', UPLO='\002,a"
"1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,\002"
", test(\002,i1,\002)=\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,i1,\002, test(\002,i1,\002)"
"=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[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;
static real amax;
static char path[3];
static integer imat, info;
static char dist[1], uplo[1], type__[1];
static integer nrun, i__, k, n, ifact;
extern /* Subroutine */ int cget04_(integer *, integer *, complex *,
integer *, complex *, integer *, real *, real *);
static integer nfail, iseed[4], nfact;
extern logical lsame_(char *, char *);
static char equed[1];
static real roldc, rcond, scond;
extern /* Subroutine */ int cppt01_(char *, integer *, complex *, complex
*, real *, real *);
static integer nimat;
extern doublereal sget06_(real *, real *);
extern /* Subroutine */ int cppt02_(char *, integer *, integer *, complex
*, complex *, integer *, complex *, integer *, real *, real *), cppt05_(char *, integer *, integer *, complex *, complex
*, integer *, complex *, integer *, complex *, integer *, real *,
real *, real *);
static real anorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
static logical equil;
static integer iuplo, izero, nerrs;
extern /* Subroutine */ int cppsv_(char *, integer *, integer *, complex *
, complex *, integer *, integer *);
static integer k1;
static logical zerot;
static char xtype[1];
extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), aladhd_(integer *, char *);
static integer in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *), claipd_(integer *, complex *, integer *, integer *);
static logical prefac;
static integer ku, nt;
extern doublereal clanhp_(char *, char *, integer *, complex *, real *);
static real rcondc;
extern /* Subroutine */ int claqhp_(char *, integer *, complex *, real *,
real *, real *, char *);
static logical nofact;
static char packit[1];
static integer iequed;
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 /* Subroutine */ int cppequ_(char *, integer *, complex *, real *,
real *, real *, integer *), cpptrf_(char *, integer *,
complex *, integer *), cpptri_(char *, integer *, complex
*, integer *), cerrvx_(char *, integer *);
static real result[6];
extern /* Subroutine */ int cppsvx_(char *, char *, integer *, integer *,
complex *, complex *, char *, real *, complex *, integer *,
complex *, integer *, real *, real *, real *, complex *, real *,
integer *);
static integer lda, npp;
/* Fortran I/O blocks */
static cilist io___49 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___53 = { 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
June 30, 1999
Purpose
=======
CDRVPP tests the driver routines CPPSV 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+1)/2)
AFAC (workspace) COMPLEX array, dimension (NMAX*(NMAX+1)/2)
ASAV (workspace) COMPLEX array, dimension (NMAX*(NMAX+1)/2)
B (workspace) COMPLEX array, dimension (NMAX*NRHS)
BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS)
X (workspace) COMPLEX array, dimension (NMAX*NRHS)
XACT (workspace) COMPLEX array, dimension (NMAX*NRHS)
S (workspace) REAL array, dimension (NMAX)
WORK (workspace) COMPLEX array, dimension
(NMAX*max(3,NRHS))
RWORK (workspace) REAL array, dimension (NMAX+2*NRHS)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--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, "PP", (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) {
cerrvx_(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);
npp = n * (n + 1) / 2;
*(unsigned char *)xtype = 'N';
nimat = 9;
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 L130;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L130;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
*(unsigned char *)packit = *(unsigned char *)&packs[iuplo - 1]
;
/* Set up parameters with CLATB4 and generate a test matrix
with CLATMS. */
clatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
rcondc = 1.f / cndnum;
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)6, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, packit, &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 L120;
}
/* For types 3-5, zero one row and column 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;
}
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
ioff = (izero - 1) * izero / 2;
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 += i__;
/* 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 = ioff + n - i__;
/* 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 {
izero = 0;
}
/* Set the imaginary part of the diagonals. */
if (iuplo == 1) {
claipd_(&n, &a[1], &c__2, &c__1);
} else {
claipd_(&n, &a[1], &n, &c_n1);
}
/* Save a copy of the matrix A in ASAV. */
ccopy_(&npp, &a[1], &c__1, &asav[1], &c__1);
for (iequed = 1; iequed <= 2; ++iequed) {
*(unsigned char *)equed = *(unsigned char *)&equeds[
iequed - 1];
if (iequed == 1) {
nfact = 3;
} else {
nfact = 1;
}
i__3 = nfact;
for (ifact = 1; ifact <= i__3; ++ifact) {
*(unsigned char *)fact = *(unsigned char *)&facts[
ifact - 1];
prefac = lsame_(fact, "F");
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (zerot) {
if (prefac) {
goto L100;
}
rcondc = 0.f;
} else if (! lsame_(fact, "N"))
{
/* Compute the condition number for comparison with
the value returned by CPPSVX (FACT = 'N' reuses
the condition number from the previous iteration
with FACT = 'F'). */
ccopy_(&npp, &asav[1], &c__1, &afac[1], &c__1);
if (equil || iequed > 1) {
/* Compute row and column scale factors to
equilibrate the matrix A. */
cppequ_(uplo, &n, &afac[1], &s[1], &scond, &
amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.f;
}
/* Equilibrate the matrix. */
claqhp_(uplo, &n, &afac[1], &s[1], &scond,
&amax, equed);
}
}
/* Save the condition number of the
non-equilibrated system for use in CGET04. */
if (equil) {
roldc = rcondc;
}
/* Compute the 1-norm of A. */
anorm = clanhp_("1", uplo, &n, &afac[1], &rwork[1]
);
/* Factor the matrix A. */
cpptrf_(uplo, &n, &afac[1], &info);
/* Form the inverse of A. */
ccopy_(&npp, &afac[1], &c__1, &a[1], &c__1);
cpptri_(uplo, &n, &a[1], &info);
/* Compute the 1-norm condition number of A. */
ainvnm = clanhp_("1", uplo, &n, &a[1], &rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
}
/* Restore the matrix A. */
ccopy_(&npp, &asav[1], &c__1, &a[1], &c__1);
/* 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';
clacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
if (nofact) {
/* --- Test CPPSV ---
Compute the L*L' or U'*U factorization of the
matrix and solve the system. */
ccopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "CPPSV ", (ftnlen)6, (
ftnlen)6);
cppsv_(uplo, &n, nrhs, &afac[1], &x[1], &lda, &
info);
/* Check error code from CPPSV . */
if (info != izero) {
alaerh_(path, "CPPSV ", &info, &izero, uplo, &
n, &n, &c_n1, &c_n1, nrhs, &imat, &
nfail, &nerrs, nout);
goto L70;
} else if (info != 0) {
goto L70;
}
/* Reconstruct matrix from factors and compute
residual. */
cppt01_(uplo, &n, &a[1], &afac[1], &rwork[1],
result);
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
cppt02_(uplo, &n, nrhs, &a[1], &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__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, "CPPSV ", (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;
}
/* L60: */
}
nrun += nt;
L70:
;
}
/* --- Test CPPSVX --- */
if (! prefac && npp > 0) {
claset_("Full", &npp, &c__1, &c_b63, &c_b63, &
afac[1], &npp);
}
claset_("Full", &n, nrhs, &c_b63, &c_b63, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and
EQUED='Y'. */
claqhp_(uplo, &n, &a[1], &s[1], &scond, &amax,
equed);
}
/* Solve the system and compute the condition number
and error bounds using CPPSVX. */
s_copy(srnamc_1.srnamt, "CPPSVX", (ftnlen)6, (ftnlen)
6);
cppsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], equed,
&s[1], &b[1], &lda, &x[1], &lda, &rcond, &
rwork[1], &rwork[*nrhs + 1], &work[1], &rwork[
(*nrhs << 1) + 1], &info);
/* Check the error code from CPPSVX. */
if (info != izero) {
/* Writing concatenation */
i__5[0] = 1, a__1[0] = fact;
i__5[1] = 1, a__1[1] = uplo;
s_cat(ch__1, a__1, i__5, &c__2, (ftnlen)2);
alaerh_(path, "CPPSVX", &info, &izero, ch__1, &n,
&n, &c_n1, &c_n1, nrhs, &imat, &nfail, &
nerrs, nout);
goto L90;
}
if (info == 0) {
if (! prefac) {
/* Reconstruct matrix from factors and compute
residual. */
cppt01_(uplo, &n, &a[1], &afac[1], &rwork[(*
nrhs << 1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
cppt02_(uplo, &n, nrhs, &asav[1], &x[1], &lda, &
work[1], &lda, &rwork[(*nrhs << 1) + 1], &
result[1]);
/* Check solution from generated exact solution. */
if (nofact || prefac && lsame_(equed, "N")) {
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
/* Check the error bounds from iterative
refinement. */
cppt05_(uplo, &n, nrhs, &asav[1], &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &
rwork[*nrhs + 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from CPPSVX 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);
}
if (prefac) {
io___52.ciunit = *nout;
s_wsfe(&io___52);
do_fio(&c__1, "CPPSVX", (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, equed, (ftnlen)1);
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();
} else {
io___53.ciunit = *nout;
s_wsfe(&io___53);
do_fio(&c__1, "CPPSVX", (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;
}
/* L80: */
}
nrun = nrun + 7 - k1;
L90:
L100:
;
}
/* L110: */
}
L120:
;
}
L130:
;
}
/* L140: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CDRVPP */
} /* cdrvpp_ */
/* Subroutine */ int chpevx_(char *jobz, char *range, char *uplo, integer *n,
complex *ap, real *vl, real *vu, integer *il, integer *iu, real *
abstol, integer *m, real *w, complex *z__, integer *ldz, complex *
work, real *rwork, integer *iwork, integer *ifail, integer *info)
{
/* -- LAPACK driver 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
=======
CHPEVX computes selected eigenvalues and, optionally, eigenvectors
of a complex Hermitian matrix A in packed storage.
Eigenvalues/vectors can be selected by specifying either a range of
values or a range of indices for the desired eigenvalues.
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.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the Hermitian matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
On exit, AP is overwritten by values generated during the
reduction to tridiagonal form. If UPLO = 'U', the diagonal
and first superdiagonal of the tridiagonal matrix T overwrite
the corresponding elements of A, and if UPLO = 'L', the
diagonal and first subdiagonal of T overwrite the
corresponding elements of A.
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 AP to tridiagonal form.
Eigenvalues will be computed most accurately when ABSTOL is
set to twice the underflow threshold 2*SLAMCH('S'), not zero.
If this routine returns with INFO>0, indicating that some
eigenvectors did not converge, try setting ABSTOL to
2*SLAMCH('S').
See "Computing Small Singular Values of Bidiagonal Matrices
with Guaranteed High Relative Accuracy," by Demmel and
Kahan, LAPACK Working Note #3.
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)
If INFO = 0, 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 an eigenvector fails to converge, then that column of Z
contains the latest approximation to the eigenvector, and
the index of the eigenvector is returned in IFAIL.
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).
WORK (workspace) COMPLEX array, dimension (2*N)
RWORK (workspace) REAL array, dimension (7*N)
IWORK (workspace) INTEGER array, dimension (5*N)
IFAIL (output) INTEGER array, dimension (N)
If JOBZ = 'V', then if INFO = 0, the first M elements of
IFAIL are zero. If INFO > 0, then IFAIL contains the
indices of the eigenvectors that failed to converge.
If JOBZ = 'N', then IFAIL is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, then i eigenvectors failed to converge.
Their indices are stored in array IFAIL.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer indd, inde;
static real anrm;
static integer imax;
static real rmin, rmax;
static integer itmp1, i__, j, indee;
static real sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static char order[1];
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *), scopy_(integer *, real *, integer *, real *
, integer *);
static logical wantz;
static integer jj;
static logical alleig, indeig;
static integer iscale, indibl;
extern doublereal clanhp_(char *, char *, integer *, complex *, real *);
static logical valeig;
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real abstll, bignum;
static integer indiwk, indisp, indtau;
extern /* Subroutine */ int chptrd_(char *, integer *, complex *, real *,
real *, complex *, integer *), cstein_(integer *, real *,
real *, integer *, real *, integer *, integer *, complex *,
integer *, real *, integer *, integer *, integer *);
static integer indrwk, indwrk;
extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
complex *, integer *, real *, integer *), cupgtr_(char *,
integer *, complex *, complex *, complex *, integer *, complex *,
integer *), ssterf_(integer *, real *, real *, integer *);
static integer nsplit;
extern /* Subroutine */ int cupmtr_(char *, char *, char *, integer *,
integer *, complex *, complex *, complex *, integer *, complex *,
integer *);
static real smlnum;
extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
real *, integer *, integer *, real *, real *, real *, integer *,
integer *, real *, integer *, integer *, real *, integer *,
integer *);
static real eps, vll, vuu, tmp1;
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
--ap;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lsame_(uplo, "L") || lsame_(uplo,
"U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -7;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -8;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -9;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -14;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPEVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
w[1] = ap[1].r;
} else {
if (*vl < ap[1].r && *vu >= ap[1].r) {
*m = 1;
w[1] = ap[1].r;
}
}
if (wantz) {
i__1 = z___subscr(1, 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;
} else {
vll = 0.f;
vuu = 0.f;
}
anrm = clanhp_("M", uplo, n, &ap[1], &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) {
i__1 = *n * (*n + 1) / 2;
csscal_(&i__1, &sigma, &ap[1], &c__1);
if (*abstol > 0.f) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indrwk = inde + *n;
indtau = 1;
indwrk = indtau + *n;
chptrd_(uplo, n, &ap[1], &rwork[indd], &rwork[inde], &work[indtau], &
iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal
to zero, then call SSTERF or CUPGTR and CSTEQR. If this fails
for some eigenvalue, then try SSTEBZ. */
if ((alleig || indeig && *il == 1 && *iu == *n) && *abstol <= 0.f) {
scopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
indee = indrwk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
ssterf_(n, &w[1], &rwork[indee], info);
} else {
cupgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &
work[indwrk], &iinfo);
i__1 = *n - 1;
scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
csteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, &
rwork[indrwk], info);
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
ifail[i__] = 0;
/* L10: */
}
}
}
if (*info == 0) {
*m = *n;
goto L20;
}
*info = 0;
}
/* Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwk = indisp + *n;
sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], &
rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &
rwork[indrwk], &iwork[indiwk], info);
if (wantz) {
cstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], &
iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
indiwk], &ifail[1], info);
/* Apply unitary matrix used in reduction to tridiagonal
form to eigenvectors returned by CSTEIN. */
indwrk = indtau + *n;
cupmtr_("L", uplo, "N", n, m, &ap[1], &work[indtau], &z__[z_offset],
ldz, &work[indwrk], info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L20:
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];
}
/* L30: */
}
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___ref(1, i__), &c__1, &z___ref(1, j), &c__1);
if (*info != 0) {
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L40: */
}
}
return 0;
/* End of CHPEVX */
} /* chpevx_ */
/* Subroutine */ int cppsvx_(char *fact, char *uplo, integer *n, integer *
nrhs, complex *ap, complex *afp, char *equed, real *s, complex *b,
integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real
*berr, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
complex q__1;
/* Local variables */
integer i__, j;
real amax, smin, smax;
real scond, anorm;
logical equil, rcequ;
logical nofact;
real bignum;
integer infequ;
real smlnum;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to */
/* compute the solution to a complex system of linear equations */
/* A * X = B, */
/* where A is an N-by-N Hermitian positive definite matrix stored in */
/* packed format 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 = 'E', real scaling factors are computed to equilibrate */
/* the system: */
/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
/* Whether or not the system will be equilibrated depends on the */
/* scaling of the matrix A, but if equilibration is used, A is */
/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
/* factor the matrix A (after equilibration if FACT = 'E') as */
/* A = U'* U , if UPLO = 'U', or */
/* A = L * L', if UPLO = 'L', */
/* where U is an upper triangular matrix, L is a lower triangular */
/* matrix, and ' indicates conjugate transpose. */
/* 3. If the leading i-by-i principal minor is not positive definite, */
/* 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. */
/* 4. The system of equations is solved for X using the factored form */
/* of A. */
/* 5. Iterative refinement is applied to improve the computed solution */
/* matrix and calculate error bounds and backward error estimates */
/* for it. */
/* 6. If equilibration was used, the matrix X is premultiplied by */
/* diag(S) so that it solves the original system before */
/* equilibration. */
/* Arguments */
/* ========= */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of the matrix A is */
/* supplied on entry, and if not, whether the matrix A should be */
/* equilibrated before it is factored. */
/* = 'F': On entry, AFP contains the factored form of A. */
/* If EQUED = 'Y', the matrix A has been equilibrated */
/* with scaling factors given by S. AP and AFP will not */
/* be modified. */
/* = 'N': The matrix A will be copied to AFP and factored. */
/* = 'E': The matrix A will be equilibrated if necessary, then */
/* copied to AFP 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. */
/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array, except if FACT = 'F' */
/* and EQUED = 'Y', then A must contain the equilibrated matrix */
/* diag(S)*A*diag(S). The j-th column of A is stored in the */
/* array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* See below for further details. A is not modified if */
/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
/* diag(S)*A*diag(S). */
/* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2) */
/* If FACT = 'F', then AFP is an input argument and on entry */
/* contains the triangular factor U or L from the Cholesky */
/* factorization A = U**H*U or A = L*L**H, in the same storage */
/* format as A. If EQUED .ne. 'N', then AFP is the factored */
/* form of the equilibrated matrix A. */
/* If FACT = 'N', then AFP is an output argument and on exit */
/* returns the triangular factor U or L from the Cholesky */
/* factorization A = U**H*U or A = L*L**H of the original */
/* matrix A. */
/* If FACT = 'E', then AFP is an output argument and on exit */
/* returns the triangular factor U or L from the Cholesky */
/* factorization A = U**H*U or A = L*L**H of the equilibrated */
/* matrix A (see the description of AP for the form of the */
/* equilibrated matrix). */
/* EQUED (input or output) CHARACTER*1 */
/* Specifies the form of equilibration that was done. */
/* = 'N': No equilibration (always true if FACT = 'N'). */
/* = 'Y': Equilibration was done, i.e., A has been replaced by */
/* diag(S) * A * diag(S). */
/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
/* output argument. */
/* S (input or output) REAL array, dimension (N) */
/* The scale factors for A; not accessed if EQUED = 'N'. 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. */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS right hand side matrix B. */
/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
/* B is overwritten by diag(S) * 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 to */
/* the original system of equations. Note that if EQUED = 'Y', */
/* A and B are modified on exit, and the solution to the */
/* equilibrated system is inv(diag(S))*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 after equilibration (if done). 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) COMPLEX array, dimension (2*N) */
/* 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: the leading minor of order i of A is */
/* not positive definite, so the factorization */
/* could not be completed, and the solution has not */
/* been computed. RCOND = 0 is returned. */
/* = N+1: U 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. */
/* Further Details */
/* =============== */
/* The packed storage scheme is illustrated by the following example */
/* when N = 4, UPLO = 'U': */
/* Two-dimensional storage of the Hermitian matrix A: */
/* a11 a12 a13 a14 */
/* a22 a23 a24 */
/* a33 a34 (aij = conjg(aji)) */
/* a44 */
/* Packed storage of the upper triangle of A: */
/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
/* ===================================================================== */
/* Parameter adjustments */
--ap;
--afp;
--s;
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");
equil = lsame_(fact, "E");
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rcequ = FALSE_;
} else {
rcequ = lsame_(equed, "Y");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
}
/* Test the input parameters. */
if (! nofact && ! equil && ! 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 (lsame_(fact, "F") && ! (rcequ || lsame_(
equed, "N"))) {
*info = -7;
} else {
if (rcequ) {
smin = bignum;
smax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
r__1 = smin, r__2 = s[j];
smin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = smax, r__2 = s[j];
smax = dmax(r__1,r__2);
}
if (smin <= 0.f) {
*info = -8;
} else if (*n > 0) {
scond = dmax(smin,smlnum) / dmin(smax,bignum);
} else {
scond = 1.f;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPPSVX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
cppequ_(uplo, n, &ap[1], &s[1], &scond, &amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
claqhp_(uplo, n, &ap[1], &s[1], &scond, &amax, equed);
rcequ = lsame_(equed, "Y");
}
}
/* Scale the right-hand side. */
if (rcequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
i__4 = i__;
i__5 = i__ + j * b_dim1;
q__1.r = s[i__4] * b[i__5].r, q__1.i = s[i__4] * b[i__5].i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
}
}
}
if (nofact || equil) {
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
i__1 = *n * (*n + 1) / 2;
ccopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
cpptrf_(uplo, n, &afp[1], info);
/* Return if INFO is non-zero. */
if (*info > 0) {
*rcond = 0.f;
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = clanhp_("I", uplo, n, &ap[1], &rwork[1]);
/* Compute the reciprocal of the condition number of A. */
cppcon_(uplo, n, &afp[1], &anorm, rcond, &work[1], &rwork[1], info);
/* Compute the solution matrix X. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
cpptrs_(uplo, n, nrhs, &afp[1], &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solution and */
/* compute error bounds and backward error estimates for it. */
cpprfs_(uplo, n, nrhs, &ap[1], &afp[1], &b[b_offset], ldb, &x[x_offset],
ldx, &ferr[1], &berr[1], &work[1], &rwork[1], info);
/* Transform the solution matrix X to a solution of the original */
/* system. */
if (rcequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * x_dim1;
i__4 = i__;
i__5 = i__ + j * x_dim1;
q__1.r = s[i__4] * x[i__5].r, q__1.i = s[i__4] * x[i__5].i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= scond;
}
}
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon")) {
*info = *n + 1;
}
return 0;
/* End of CPPSVX */
} /* cppsvx_ */
/* Subroutine */ int chpsvx_(char *fact, char *uplo, integer *n, integer *
nrhs, complex *ap, complex *afp, integer *ipiv, complex *b, integer *
ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr,
complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *);
real anorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
extern doublereal clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *);
logical nofact;
extern /* Subroutine */ int chpcon_(char *, integer *, complex *, integer
*, real *, real *, complex *, integer *), clacpy_(char *,
integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *), chprfs_(char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *, complex *, integer *, real *, real *, complex *, real *
, integer *), chptrf_(char *, integer *, complex *,
integer *, integer *), chptrs_(char *, integer *, integer
*, complex *, 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 */
/* ======= */
/* CHPSVX uses the diagonal pivoting factorization A = U*D*U**H or */
/* A = L*D*L**H to compute the solution to a complex system of linear */
/* equations A * X = B, where A is an N-by-N Hermitian matrix stored */
/* in packed format 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 as */
/* A = U * D * U**H, if UPLO = 'U', or */
/* A = L * D * L**H, if UPLO = 'L', */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices and D is Hermitian 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, AFP and IPIV contain the factored form of */
/* A. AFP and IPIV will not be modified. */
/* = 'N': The matrix A will be copied to AFP 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. */
/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The upper or lower triangle of the Hermitian matrix A, packed */
/* columnwise in a linear array. The j-th column of A is stored */
/* in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* See below for further details. */
/* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2) */
/* If FACT = 'F', then AFP 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**H or A = L*D*L**H as computed by CHPTRF, stored as */
/* a packed triangular matrix in the same storage format as A. */
/* If FACT = 'N', then AFP is an output argument and on exit */
/* contains the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L from the factorization */
/* A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as */
/* a packed triangular matrix in the same storage format as A. */
/* 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 CHPTRF. */
/* 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 CHPTRF. */
/* 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) COMPLEX array, dimension (2*N) */
/* 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. */
/* Further Details */
/* =============== */
/* The packed storage scheme is illustrated by the following example */
/* when N = 4, UPLO = 'U': */
/* Two-dimensional storage of the Hermitian matrix A: */
/* a11 a12 a13 a14 */
/* a22 a23 a24 */
/* a33 a34 (aij = conjg(aji)) */
/* a44 */
/* Packed storage of the upper triangle of A: */
/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--afp;
--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");
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 (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldx < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPSVX", &i__1);
return 0;
}
if (nofact) {
/* Compute the factorization A = U*D*U' or A = L*D*L'. */
i__1 = *n * (*n + 1) / 2;
ccopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
chptrf_(uplo, n, &afp[1], &ipiv[1], info);
/* Return if INFO is non-zero. */
if (*info > 0) {
*rcond = 0.f;
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = clanhp_("I", uplo, n, &ap[1], &rwork[1]);
/* Compute the reciprocal of the condition number of A. */
chpcon_(uplo, n, &afp[1], &ipiv[1], &anorm, rcond, &work[1], info);
/* Compute the solution vectors X. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
chptrs_(uplo, n, nrhs, &afp[1], &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. */
chprfs_(uplo, n, nrhs, &ap[1], &afp[1], &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;
}
return 0;
/* End of CHPSVX */
} /* chpsvx_ */
/* Subroutine */ int chpev_(char *jobz, char *uplo, integer *n, complex *ap,
real *w, complex *z__, integer *ldz, complex *work, real *rwork,
integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real eps;
integer inde;
real anrm;
integer imax;
real rmin, rmax, sigma;
extern logical lsame_(char *, char *);
integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
logical wantz;
integer iscale;
extern doublereal clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
real bignum;
integer indtau;
extern /* Subroutine */ int chptrd_(char *, integer *, complex *, real *,
real *, complex *, integer *);
integer indrwk, indwrk;
extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
complex *, integer *, real *, integer *), cupgtr_(char *,
integer *, complex *, complex *, complex *, integer *, complex *,
integer *), ssterf_(integer *, real *, real *, integer *);
real smlnum;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHPEV computes all the eigenvalues and, optionally, eigenvectors of a */
/* complex Hermitian matrix in packed storage. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, AP is overwritten by values generated during the */
/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
/* and first superdiagonal of the tridiagonal matrix T overwrite */
/* the corresponding elements of A, and if UPLO = 'L', the */
/* diagonal and first subdiagonal of T overwrite the */
/* corresponding elements of A. */
/* W (output) REAL array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) COMPLEX array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
/* eigenvectors of the matrix A, with the i-th column of Z */
/* holding the eigenvector associated with W(i). */
/* If JOBZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* WORK (workspace) COMPLEX array, dimension (max(1, 2*N-1)) */
/* RWORK (workspace) REAL array, dimension (max(1, 3*N-2)) */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the algorithm failed to converge; i */
/* off-diagonal elements of an intermediate tridiagonal */
/* form did not converge to zero. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
wantz = lsame_(jobz, "V");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lsame_(uplo, "L") || lsame_(uplo,
"U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPEV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
w[1] = ap[1].r;
rwork[1] = 1.f;
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);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = clanhp_("M", uplo, n, &ap[1], &rwork[1]);
iscale = 0;
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
i__1 = *n * (*n + 1) / 2;
csscal_(&i__1, &sigma, &ap[1], &c__1);
}
/* Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form. */
inde = 1;
indtau = 1;
chptrd_(uplo, n, &ap[1], &w[1], &rwork[inde], &work[indtau], &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, first call */
/* CUPGTR to generate the orthogonal matrix, then call CSTEQR. */
if (! wantz) {
ssterf_(n, &w[1], &rwork[inde], info);
} else {
indwrk = indtau + *n;
cupgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[
indwrk], &iinfo);
indrwk = inde + *n;
csteqr_(jobz, n, &w[1], &rwork[inde], &z__[z_offset], ldz, &rwork[
indrwk], info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &w[1], &c__1);
}
return 0;
/* End of CHPEV */
} /* chpev_ */
/* Subroutine */ int chpevd_(char *jobz, char *uplo, integer *n, complex *ap,
real *w, complex *z__, integer *ldz, complex *work, integer *lwork,
real *rwork, integer *lrwork, integer *iwork, integer *liwork,
integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real eps;
integer inde;
real anrm;
integer imax;
real rmin, rmax, sigma;
extern logical lsame_(char *, char *);
integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
integer lwmin, llrwk, llwrk;
logical wantz;
integer iscale;
extern doublereal clanhp_(char *, char *, integer *, complex *, real *);
extern /* Subroutine */ int cstedc_(char *, integer *, real *, real *,
complex *, integer *, complex *, integer *, real *, integer *,
integer *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
real bignum;
integer indtau;
extern /* Subroutine */ int chptrd_(char *, integer *, complex *, real *,
real *, complex *, integer *);
integer indrwk, indwrk, liwmin;
extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
integer lrwmin;
extern /* Subroutine */ int cupmtr_(char *, char *, char *, integer *,
integer *, complex *, complex *, complex *, integer *, complex *,
integer *);
real smlnum;
logical lquery;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHPEVD computes all the eigenvalues and, optionally, eigenvectors of */
/* a complex Hermitian matrix A in packed storage. If eigenvectors are */
/* desired, it uses a divide and conquer algorithm. */
/* The divide and conquer algorithm makes very mild assumptions about */
/* floating point arithmetic. It will work on machines with a guard */
/* digit in add/subtract, or on those binary machines without guard */
/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, AP is overwritten by values generated during the */
/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
/* and first superdiagonal of the tridiagonal matrix T overwrite */
/* the corresponding elements of A, and if UPLO = 'L', the */
/* diagonal and first subdiagonal of T overwrite the */
/* corresponding elements of A. */
/* W (output) REAL array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) COMPLEX array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
/* eigenvectors of the matrix A, with the i-th column of Z */
/* holding the eigenvector associated with W(i). */
/* If JOBZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the required LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of array WORK. */
/* If N <= 1, LWORK must be at least 1. */
/* If JOBZ = 'N' and N > 1, LWORK must be at least N. */
/* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the required 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 required LRWORK. */
/* LRWORK (input) INTEGER */
/* The dimension of array RWORK. */
/* If N <= 1, LRWORK must be at least 1. */
/* If JOBZ = 'N' and N > 1, LRWORK must be at least N. */
/* If JOBZ = 'V' and N > 1, LRWORK must be at least */
/* 1 + 5*N + 2*N**2. */
/* If LRWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the required 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 required LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of array IWORK. */
/* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */
/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the required 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: if INFO = i, the algorithm failed to converge; i */
/* off-diagonal elements of an intermediate tridiagonal */
/* form did not converge to zero. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lsame_(uplo, "L") || lsame_(uplo,
"U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -7;
}
if (*info == 0) {
if (*n <= 1) {
lwmin = 1;
liwmin = 1;
lrwmin = 1;
} else {
if (wantz) {
lwmin = *n << 1;
/* Computing 2nd power */
i__1 = *n;
lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
liwmin = *n * 5 + 3;
} else {
lwmin = *n;
lrwmin = *n;
liwmin = 1;
}
}
work[1].r = (real) lwmin, work[1].i = 0.f;
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -9;
} else if (*lrwork < lrwmin && ! lquery) {
*info = -11;
} else if (*liwork < liwmin && ! lquery) {
*info = -13;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPEVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
w[1] = ap[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);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = clanhp_("M", uplo, n, &ap[1], &rwork[1]);
iscale = 0;
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
i__1 = *n * (*n + 1) / 2;
csscal_(&i__1, &sigma, &ap[1], &c__1);
}
/* Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form. */
inde = 1;
indtau = 1;
indrwk = inde + *n;
indwrk = indtau + *n;
llwrk = *lwork - indwrk + 1;
llrwk = *lrwork - indrwk + 1;
chptrd_(uplo, n, &ap[1], &w[1], &rwork[inde], &work[indtau], &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, first call */
/* CUPGTR to generate the orthogonal matrix, then call CSTEDC. */
if (! wantz) {
ssterf_(n, &w[1], &rwork[inde], info);
} else {
cstedc_("I", n, &w[1], &rwork[inde], &z__[z_offset], ldz, &work[
indwrk], &llwrk, &rwork[indrwk], &llrwk, &iwork[1], liwork,
info);
cupmtr_("L", uplo, "N", n, n, &ap[1], &work[indtau], &z__[z_offset],
ldz, &work[indwrk], &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &w[1], &c__1);
}
work[1].r = (real) lwmin, work[1].i = 0.f;
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
return 0;
/* End of CHPEVD */
} /* chpevd_ */
/* Subroutine */ int cdrvhp_(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 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];
extern /* Subroutine */ int chpt01_(char *, integer *, complex *, complex
*, integer *, complex *, integer *, real *, real *);
static integer nbmin;
static real rcond;
static integer nimat;
extern doublereal sget06_(real *, real *);
extern /* Subroutine */ int cppt02_(char *, integer *, integer *, complex
*, complex *, integer *, complex *, integer *, real *, real *), cppt05_(char *, integer *, integer *, complex *, complex
*, integer *, complex *, integer *, complex *, integer *, real *,
real *, real *);
static real anorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), chpsv_(char *, integer *, integer *,
complex *, integer *, complex *, integer *, integer *);
static integer iuplo, izero, i1, i2, k1, nerrs;
static logical zerot;
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 *), claipd_(integer *, complex *, integer *, integer *);
static integer ku, nt;
extern doublereal clanhp_(char *, char *, integer *, complex *, real *);
static real rcondc;
static char packit[1];
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 *), chptrf_(char *, integer *, complex *, integer *,
integer *);
static real ainvnm;
extern /* Subroutine */ int chptri_(char *, integer *, complex *, integer
*, complex *, integer *), xlaenv_(integer *, integer *),
cerrvx_(char *, integer *), chpsvx_(char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *, complex *, integer *, real *, real *, real *, complex *
, real *, integer *);
static real result[6];
static integer lda, npp;
/* 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
=======
CDRVHP tests the driver routines CHPSV 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+1)/2)
AFAC (workspace) COMPLEX array, dimension
(NMAX*(NMAX+1)/2)
AINV (workspace) COMPLEX array, dimension
(NMAX*(NMAX+1)/2)
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. */
*(unsigned char *)path = 'C';
s_copy(path + 1, "HP", (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) {
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);
npp = n * (n + 1) / 2;
*(unsigned char *)xtype = 'N';
nimat = 10;
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) {
if (iuplo == 1) {
*(unsigned char *)uplo = 'U';
*(unsigned char *)packit = 'C';
} else {
*(unsigned char *)uplo = 'L';
*(unsigned char *)packit = 'R';
}
/* 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, packit, &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) * izero / 2;
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 += i__;
/* 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 = ioff + n - i__;
/* 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 {
ioff = 0;
if (iuplo == 1) {
/* Set the first IZERO rows and columns to zero. */
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 += j;
/* L70: */
}
} else {
/* Set the last IZERO rows and columns to zero. */
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 = ioff + n - j;
/* L90: */
}
}
}
} else {
izero = 0;
}
/* Set the imaginary part of the diagonals. */
if (iuplo == 1) {
claipd_(&n, &a[1], &c__2, &c__1);
} else {
claipd_(&n, &a[1], &n, &c_n1);
}
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 CHPSVX. */
if (zerot) {
if (ifact == 1) {
goto L150;
}
rcondc = 0.f;
} else if (ifact == 1) {
/* Compute the 1-norm of A. */
anorm = clanhp_("1", uplo, &n, &a[1], &rwork[1]);
/* Factor the matrix A. */
ccopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
chptrf_(uplo, &n, &afac[1], &iwork[1], &info);
/* Compute inv(A) and take its norm. */
ccopy_(&npp, &afac[1], &c__1, &ainv[1], &c__1);
chptri_(uplo, &n, &ainv[1], &iwork[1], &work[1], &
info);
ainvnm = clanhp_("1", uplo, &n, &ainv[1], &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 CHPSV --- */
if (ifact == 2) {
ccopy_(&npp, &a[1], &c__1, &afac[1], &c__1);
clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &lda);
/* Factor the matrix and solve the system using CHPSV. */
s_copy(srnamc_1.srnamt, "CHPSV ", (ftnlen)6, (ftnlen)
6);
chpsv_(uplo, &n, nrhs, &afac[1], &iwork[1], &x[1], &
lda, &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 CHPSV . */
if (info != k) {
alaerh_(path, "CHPSV ", &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. */
chpt01_(uplo, &n, &a[1], &afac[1], &iwork[1], &ainv[1]
, &lda, &rwork[1], result);
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &lda);
cppt02_(uplo, &n, nrhs, &a[1], &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, "CHPSV ", (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 CHPSVX --- */
if (ifact == 2 && npp > 0) {
claset_("Full", &npp, &c__1, &c_b64, &c_b64, &afac[1],
&npp);
}
claset_("Full", &n, nrhs, &c_b64, &c_b64, &x[1], &lda);
/* Solve the system and compute the condition number and
error bounds using CHPSVX. */
s_copy(srnamc_1.srnamt, "CHPSVX", (ftnlen)6, (ftnlen)6);
chpsvx_(fact, uplo, &n, nrhs, &a[1], &afac[1], &iwork[1],
&b[1], &lda, &x[1], &lda, &rcond, &rwork[1], &
rwork[*nrhs + 1], &work[1], &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 CHPSVX. */
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, "CHPSVX", &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. */
chpt01_(uplo, &n, &a[1], &afac[1], &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);
cppt02_(uplo, &n, nrhs, &a[1], &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. */
cppt05_(uplo, &n, nrhs, &a[1], &b[1], &lda, &x[1], &
lda, &xact[1], &lda, &rwork[1], &rwork[*nrhs
+ 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from CHPSVX 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, "CHPSVX", (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 CDRVHP */
} /* cdrvhp_ */
/* Subroutine */ int cppt01_(char *uplo, integer *n, complex *a, complex *
afac, real *rwork, real *resid)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
integer i__, k, kc;
complex tc;
real tr, eps;
extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *,
integer *, complex *), cscal_(integer *, complex *,
complex *, integer *);
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
real anorm;
extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *,
complex *, complex *, integer *);
extern doublereal clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPPT01 reconstructs a Hermitian positive definite packed matrix A */
/* from its L*L' or U'*U factorization and computes the residual */
/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon, L' is the conjugate transpose of */
/* L, and U' is the conjugate transpose of U. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian 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 (N*(N+1)/2) */
/* The original Hermitian matrix A, stored as a packed */
/* triangular matrix. */
/* AFAC (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the factor L or U from the L*L' or U'*U */
/* factorization of A, stored as a packed triangular matrix. */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference L*L' - A (or U'*U - A). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 */
/* Parameter adjustments */
--rwork;
--afac;
--a;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = clanhp_("1", uplo, n, &a[1], &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Check the imaginary parts of the diagonal elements and return with */
/* an error code if any are nonzero. */
kc = 1;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (r_imag(&afac[kc]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
kc = kc + k + 1;
/* L10: */
}
} else {
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
if (r_imag(&afac[kc]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
kc = kc + *n - k + 1;
/* L20: */
}
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
kc = *n * (*n - 1) / 2 + 1;
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
cdotc_(&q__1, &k, &afac[kc], &c__1, &afac[kc], &c__1);
tr = q__1.r;
i__1 = kc + k - 1;
afac[i__1].r = tr, afac[i__1].i = 0.f;
/* Compute the rest of column K. */
if (k > 1) {
i__1 = k - 1;
ctpmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[1], &
afac[kc], &c__1);
kc -= k - 1;
}
/* L30: */
}
/* Compute the difference L*L' - A */
kc = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = kc + i__ - 1;
i__4 = kc + i__ - 1;
i__5 = kc + i__ - 1;
q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L40: */
}
i__2 = kc + k - 1;
i__3 = kc + k - 1;
i__4 = kc + k - 1;
r__1 = a[i__4].r;
q__1.r = afac[i__3].r - r__1, q__1.i = afac[i__3].i;
afac[i__2].r = q__1.r, afac[i__2].i = q__1.i;
kc += k;
/* L50: */
}
/* Compute the product L*L', overwriting L. */
} else {
kc = *n * (*n + 1) / 2;
for (k = *n; k >= 1; --k) {
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (k < *n) {
i__1 = *n - k;
chpr_("Lower", &i__1, &c_b19, &afac[kc + 1], &c__1, &afac[kc
+ *n - k + 1]);
}
/* Scale column K by the diagonal element. */
i__1 = kc;
tc.r = afac[i__1].r, tc.i = afac[i__1].i;
i__1 = *n - k + 1;
cscal_(&i__1, &tc, &afac[kc], &c__1);
kc -= *n - k + 2;
/* L60: */
}
/* Compute the difference U'*U - A */
kc = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = kc;
i__3 = kc;
i__4 = kc;
r__1 = a[i__4].r;
q__1.r = afac[i__3].r - r__1, q__1.i = afac[i__3].i;
afac[i__2].r = q__1.r, afac[i__2].i = q__1.i;
i__2 = *n;
for (i__ = k + 1; i__ <= i__2; ++i__) {
i__3 = kc + i__ - k;
i__4 = kc + i__ - k;
i__5 = kc + i__ - k;
q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L70: */
}
kc = kc + *n - k + 1;
/* L80: */
}
}
/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
*resid = clanhp_("1", uplo, n, &afac[1], &rwork[1]);
*resid = *resid / (real) (*n) / anorm / eps;
return 0;
/* End of CPPT01 */
} /* cppt01_ */
/* Subroutine */
int chpsvx_(char *fact, char *uplo, integer *n, integer * nrhs, complex *ap, complex *afp, integer *ipiv, complex *b, integer * ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *);
real anorm;
extern /* Subroutine */
int ccopy_(integer *, complex *, integer *, complex *, integer *);
extern real clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *);
logical nofact;
extern /* Subroutine */
int chpcon_(char *, integer *, complex *, integer *, real *, real *, complex *, integer *), clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *), chprfs_(char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, integer *, real *, real *, complex *, real * , integer *), chptrf_(char *, integer *, complex *, integer *, integer *), chptrs_(char *, integer *, integer *, complex *, 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 */
--ap;
--afp;
--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");
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 (*ldb < max(1,*n))
{
*info = -9;
}
else if (*ldx < max(1,*n))
{
*info = -11;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CHPSVX", &i__1);
return 0;
}
if (nofact)
{
/* Compute the factorization A = U*D*U**H or A = L*D*L**H. */
i__1 = *n * (*n + 1) / 2;
ccopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
chptrf_(uplo, n, &afp[1], &ipiv[1], info);
/* Return if INFO is non-zero. */
if (*info > 0)
{
*rcond = 0.f;
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = clanhp_("I", uplo, n, &ap[1], &rwork[1]);
/* Compute the reciprocal of the condition number of A. */
chpcon_(uplo, n, &afp[1], &ipiv[1], &anorm, rcond, &work[1], info);
/* Compute the solution vectors X. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
chptrs_(uplo, n, nrhs, &afp[1], &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. */
chprfs_(uplo, n, nrhs, &ap[1], &afp[1], &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;
}
return 0;
/* End of CHPSVX */
}
