INT16 dlm_cholfC(COMPLEX64* Z, const COMPLEX64* A, INT32 nXD) {
integer info = 0;
integer n = (integer) nXD;
char uplo[1] = { 'U' };
#ifdef __MAX_TYPE_32BIT
extern int clacpy_(char*,integer*,integer*,complex*,integer*,complex*,integer *ldb);
extern int cpotrf_(char*,integer*,complex*,integer*,integer*);
#else
extern int zlacpy_(char*,integer*,integer*,doublecomplex*,integer*,doublecomplex*,integer *ldb);
extern int zpotrf_(char*,integer*,doublecomplex*,integer*,integer*);
#endif
/* Declare variables */
DLPASSERT(Z != A); /* Assert input is not output */
DLPASSERT(dlp_size(Z) >= nXD * nXD * sizeof(FLOAT64)); /* Check size of output buffer */
DLPASSERT(dlp_size(A) >= nXD * nXD * sizeof(FLOAT64)); /* Check size of input buffer */
/* ... computation ... *//* --------------------------------- */
#ifdef __MAX_TYPE_32BIT
cpotrf_(uplo, &n, (complex*)A, &n, &info);
clacpy_(uplo, &n, &n, (complex*)A, &n, (complex*)Z, &n);
#else
zpotrf_(uplo, &n, (doublecomplex*)A, &n, &info);
zlacpy_(uplo, &n, &n, (doublecomplex*)A, &n, (doublecomplex*)Z, &n);
#endif
return (info == 0) ? O_K : NOT_EXEC; /* All done successfully */
}
DLLEXPORT MKL_INT c_cholesky_factor(MKL_INT n, MKL_Complex8 a[]){
char uplo = 'L';
MKL_INT info = 0;
MKL_Complex8 zero = {0.0f, 0.0f};
cpotrf_(&uplo, &n, a, &n, &info);
for (MKL_INT i = 0; i < n; ++i)
{
MKL_INT index = i * n;
for (MKL_INT j = 0; j < n && i > j; ++j)
{
a[index + j] = zero;
}
}
return info;
}
DLLEXPORT int c_cholesky_factor(int n, complex a[]){
char uplo = 'L';
int info = 0;
complex zero = {0.0f, 0.0f};
cpotrf_(&uplo, &n, a, &n, &info);
for (int i = 0; i < n; ++i)
{
int index = i * n;
for (int j = 0; j < n && i > j; ++j)
{
a[index + j] = zero;
}
}
return info;
}
DLLEXPORT int c_cholesky_solve(int n, int nrhs, complex a[], complex b[])
{
complex* clone = new complex[n*n];
memcpy(clone, a, n*n*sizeof(complex));
char uplo = 'L';
int info = 0;
cpotrf_(&uplo, &n, clone, &n, &info);
if (info != 0){
delete[] clone;
return info;
}
cpotrs_(&uplo, &n, &nrhs, clone, &n, b, &n, &info);
return info;
}
DLLEXPORT MKL_INT c_cholesky_solve(MKL_INT n, MKL_INT nrhs, MKL_Complex8 a[], MKL_Complex8 b[])
{
MKL_Complex8* clone = new MKL_Complex8[n*n];
std::memcpy(clone, a, n*n*sizeof(MKL_Complex8));
char uplo = 'L';
MKL_INT info = 0;
cpotrf_(&uplo, &n, clone, &n, &info);
if (info != 0){
delete[] clone;
return info;
}
cpotrs_(&uplo, &n, &nrhs, clone, &n, b, &n, &info);
delete[] clone;
return info;
}
/* Subroutine */ int cdrvpo_(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 equeds[1*2] = "N" "Y";
/* Format strings */
static char fmt_9999[] = "(1x,a,\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,a,\002, FACT='\002,a1,\002', UPLO='\002,"
"a1,\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,a,\002, FACT='\002,a1,\002', UPLO='\002,"
"a1,\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];
/* Local variables */
integer i__, k, n;
real *errbnds_c__, *errbnds_n__;
integer k1, nb, in, kl, ku, nt, n_err_bnds__, lda;
char fact[1];
integer ioff, mode;
real amax;
char path[3];
integer imat, info;
real *berr;
char dist[1];
real rpvgrw_svxx__;
char uplo[1], type__[1];
integer nrun, ifact;
integer nfail, iseed[4], nfact;
char equed[1];
integer nbmin;
real rcond, roldc, scond;
integer nimat;
real anorm;
logical equil;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
logical prefac;
real rcondc;
logical nofact;
integer iequed;
real cndnum;
real ainvnm;
real result[6];
/* Fortran I/O blocks */
static cilist io___48 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CDRVPO tests the driver routines CPOSV, -SVX, and -SVXX. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* ASAV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--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, "PO", (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);
*(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 L120;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L120;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[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);
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L110;
}
/* 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;
}
ioff = (izero - 1) * lda;
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0.f, a[i__4].i = 0.f;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0.f, a[i__4].i = 0.f;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L50: */
}
}
} else {
izero = 0;
}
/* Set the imaginary part of the diagonals. */
i__3 = lda + 1;
claipd_(&n, &a[1], &i__3, &c__0);
/* Save a copy of the matrix A in ASAV. */
clacpy_(uplo, &n, &n, &a[1], &lda, &asav[1], &lda);
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) {
for (i__ = 1; i__ <= 6; ++i__) {
result[i__ - 1] = 0.f;
}
*(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 L90;
}
rcondc = 0.f;
} else if (! lsame_(fact, "N"))
{
/* Compute the condition number for comparison with */
/* the value returned by CPOSVX (FACT = 'N' reuses */
/* the condition number from the previous iteration */
/* with FACT = 'F'). */
clacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &
lda);
if (equil || iequed > 1) {
/* Compute row and column scale factors to */
/* equilibrate the matrix A. */
cpoequ_(&n, &afac[1], &lda, &s[1], &scond, &
amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.f;
}
/* Equilibrate the matrix. */
claqhe_(uplo, &n, &afac[1], &lda, &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 = clanhe_("1", uplo, &n, &afac[1], &lda, &
rwork[1]);
/* Factor the matrix A. */
cpotrf_(uplo, &n, &afac[1], &lda, &info);
/* Form the inverse of A. */
clacpy_(uplo, &n, &n, &afac[1], &lda, &a[1], &lda);
cpotri_(uplo, &n, &a[1], &lda, &info);
/* Compute the 1-norm condition number of A. */
ainvnm = clanhe_("1", uplo, &n, &a[1], &lda, &
rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondc = 1.f;
} else {
rcondc = 1.f / anorm / ainvnm;
}
}
/* Restore the matrix A. */
clacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (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 CPOSV --- */
/* Compute the L*L' or U'*U factorization of the */
/* matrix and solve the system. */
clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
clacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "CPOSV ", (ftnlen)32, (
ftnlen)6);
cposv_(uplo, &n, nrhs, &afac[1], &lda, &x[1], &
lda, &info);
/* Check error code from CPOSV . */
if (info != izero) {
alaerh_(path, "CPOSV ", &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. */
cpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
rwork[1], result);
/* Compute residual of the computed solution. */
clacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
cpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda,
&work[1], &lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
cget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[2]);
nt = 3;
/* Print information about the tests that did not */
/* pass the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
aladhd_(nout, path);
}
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, "CPOSV ", (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 CPOSVX --- */
if (! prefac) {
claset_(uplo, &n, &n, &c_b51, &c_b51, &afac[1], &
lda);
}
claset_("Full", &n, nrhs, &c_b51, &c_b51, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and */
/* EQUED='Y'. */
claqhe_(uplo, &n, &a[1], &lda, &s[1], &scond, &
amax, equed);
}
/* Solve the system and compute the condition number */
/* and error bounds using CPOSVX. */
s_copy(srnamc_1.srnamt, "CPOSVX", (ftnlen)32, (ftnlen)
6);
cposvx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1], &
lda, 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 CPOSVX. */
if (info == n + 1) {
goto L90;
}
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, "CPOSVX", &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. */
cpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
&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);
cpot02_(uplo, &n, nrhs, &asav[1], &lda, &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. */
cpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &rwork[*nrhs + 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from CPOSVX 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___51.ciunit = *nout;
s_wsfe(&io___51);
do_fio(&c__1, "CPOSVX", (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___52.ciunit = *nout;
s_wsfe(&io___52);
do_fio(&c__1, "CPOSVX", (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;
/* --- Test CPOSVXX --- */
/* Restore the matrices A and B. */
clacpy_("Full", &n, &n, &asav[1], &lda, &a[1], &lda);
clacpy_("Full", &n, nrhs, &bsav[1], &lda, &b[1], &lda);
if (! prefac) {
claset_(uplo, &n, &n, &c_b51, &c_b51, &afac[1], &
lda);
}
claset_("Full", &n, nrhs, &c_b51, &c_b51, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and */
/* EQUED='Y'. */
claqhe_(uplo, &n, &a[1], &lda, &s[1], &scond, &
amax, equed);
}
/* Solve the system and compute the condition number */
/* and error bounds using CPOSVXX. */
s_copy(srnamc_1.srnamt, "CPOSVXX", (ftnlen)32, (
ftnlen)7);
salloc3();
cposvxx_(fact, uplo, &n, nrhs, &a[1], &lda, &afac[1],
&lda, equed, &s[1], &b[1], &lda, &x[1], &lda,
&rcond, &rpvgrw_svxx__, berr, &n_err_bnds__,
errbnds_n__, errbnds_c__, &c__0, &c_b94, &
work[1], &rwork[(*nrhs << 1) + 1], &info);
free3();
/* Check the error code from CPOSVXX. */
if (info == n + 1) {
goto L90;
}
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, "CPOSVXX", &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. */
cpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
&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);
cpot02_(uplo, &n, nrhs, &asav[1], &lda, &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. */
cpot05_(uplo, &n, nrhs, &asav[1], &lda, &b[1], &
lda, &x[1], &lda, &xact[1], &lda, &rwork[
1], &rwork[*nrhs + 1], &result[3]);
} else {
k1 = 6;
}
/* Compare RCOND from CPOSVXX 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___58.ciunit = *nout;
s_wsfe(&io___58);
do_fio(&c__1, "CPOSVXX", (ftnlen)7);
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___59.ciunit = *nout;
s_wsfe(&io___59);
do_fio(&c__1, "CPOSVXX", (ftnlen)7);
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;
}
/* L85: */
}
nrun = nrun + 7 - k1;
L90:
;
}
/* L100: */
}
L110:
;
}
L120:
;
}
/* L130: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
/* Test Error Bounds for CGESVXX */
cebchvxx_(thresh, path);
return 0;
/* End of CDRVPO */
} /* cdrvpo_ */
/* Subroutine */ int cchkpo_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval, real *
thresh, logical *tsterr, integer *nmax, complex *a, complex *afac,
complex *ainv, complex *b, complex *x, complex *xact, complex *work,
real *rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"=\002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, k, n, nb, in, kl, ku, lda, inb, ioff, mode, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
integer nfail, iseed[4];
real rcond;
integer nimat;
real anorm;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
real rcondc;
real cndnum;
real result[8];
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKPO tests CPOTRF, -TRI, -TRS, -RFS, and -CON */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the blocksize NB. */
/* NNS (input) INTEGER */
/* The number of values of NRHS contained in the vector NSVAL. */
/* NSVAL (input) INTEGER array, dimension (NNS) */
/* The values of the number of right hand sides NRHS. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for N, used in dimensioning the */
/* work arrays. */
/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* B (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) */
/* WORK (workspace) COMPLEX array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) REAL array, dimension */
/* (NMAX+2*NSMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "PO", (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) {
cerrpo_(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 = 9;
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 L110;
}
/* Skip types 3, 4, or 5 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 5;
if (zerot && n < imat - 2) {
goto L110;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[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);
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)32, (ftnlen)6);
clatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L100;
}
/* 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;
}
ioff = (izero - 1) * lda;
/* Set row and column IZERO of A to 0. */
if (iuplo == 1) {
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0.f, a[i__4].i = 0.f;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0.f, a[i__4].i = 0.f;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0.f, a[i__4].i = 0.f;
/* L50: */
}
}
} else {
izero = 0;
}
/* Set the imaginary part of the diagonals. */
i__3 = lda + 1;
claipd_(&n, &a[1], &i__3, &c__0);
/* Do for each value of NB in NBVAL */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
/* Compute the L*L' or U'*U factorization of the matrix. */
clacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
s_copy(srnamc_1.srnamt, "CPOTRF", (ftnlen)32, (ftnlen)6);
cpotrf_(uplo, &n, &afac[1], &lda, &info);
/* Check error code from CPOTRF. */
if (info != izero) {
alaerh_(path, "CPOTRF", &info, &izero, uplo, &n, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
goto L90;
}
/* Skip the tests if INFO is not 0. */
if (info != 0) {
goto L90;
}
/* + TEST 1 */
/* Reconstruct matrix from factors and compute residual. */
clacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
cpot01_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &rwork[1],
result);
/* + TEST 2 */
/* Form the inverse and compute the residual. */
clacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "CPOTRI", (ftnlen)32, (ftnlen)6);
cpotri_(uplo, &n, &ainv[1], &lda, &info);
/* Check error code from CPOTRI. */
if (info != 0) {
alaerh_(path, "CPOTRI", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
cpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[1], &
lda, &rwork[1], &rcondc, &result[1]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 2; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += 2;
/* Skip the rest of the tests unless this is the first */
/* blocksize. */
if (inb != 1) {
goto L90;
}
i__4 = *nns;
for (irhs = 1; irhs <= i__4; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 3 */
/* Solve and compute residual for A * X = B . */
s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)32, (ftnlen)
6);
clarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
clacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "CPOTRS", (ftnlen)32, (ftnlen)
6);
cpotrs_(uplo, &n, &nrhs, &afac[1], &lda, &x[1], &lda,
&info);
/* Check error code from CPOTRS. */
if (info != 0) {
alaerh_(path, "CPOTRS", &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);
cpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[3]);
/* + TESTS 5, 6, and 7 */
/* Use iterative refinement to improve the solution. */
s_copy(srnamc_1.srnamt, "CPORFS", (ftnlen)32, (ftnlen)
6);
cporfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
&b[1], &lda, &x[1], &lda, &rwork[1], &rwork[
nrhs + 1], &work[1], &rwork[(nrhs << 1) + 1],
&info);
/* Check error code from CPORFS. */
if (info != 0) {
alaerh_(path, "CPORFS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
cget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
cpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &rwork[
nrhs + 1], &result[5]);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(real));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* + TEST 8 */
/* Get an estimate of RCOND = 1/CNDNUM. */
anorm = clanhe_("1", uplo, &n, &a[1], &lda, &rwork[1]);
s_copy(srnamc_1.srnamt, "CPOCON", (ftnlen)32, (ftnlen)6);
cpocon_(uplo, &n, &afac[1], &lda, &anorm, &rcond, &work[1]
, &rwork[1], &info);
/* Check error code from CPOCON. */
if (info != 0) {
alaerh_(path, "CPOCON", &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___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 *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(real)
);
e_wsfe();
++nfail;
}
++nrun;
L90:
;
}
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CCHKPO */
} /* cchkpo_ */
/* Subroutine */ int cposv_(char *uplo, integer *n, integer *nrhs, complex *a,
integer *lda, complex *b, integer *ldb, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *);
extern /* Subroutine */ int xerbla_(char *, integer *), cpotrf_(
char *, integer *, complex *, integer *, integer *),
cpotrs_(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 */
/* ======= */
/* CPOSV computes the solution to a complex system of linear equations */
/* A * X = B, */
/* where A is an N-by-N Hermitian positive definite matrix and X and B */
/* are N-by-NRHS matrices. */
/* The Cholesky decomposition is used to factor A as */
/* A = U**H* U, if UPLO = 'U', or */
/* A = L * L**H, if UPLO = 'L', */
/* where U is an upper triangular matrix and L is a lower triangular */
/* matrix. The factored form of A is then used to solve the system of */
/* equations A * X = B. */
/* Arguments */
/* ========= */
/* 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 matrix B. NRHS >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */
/* N-by-N upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading N-by-N lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if INFO = 0, the factor U or L from the Cholesky */
/* factorization A = U**H*U or A = L*L**H. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS right hand side matrix B. */
/* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, 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. */
/* ===================================================================== */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPOSV ", &i__1);
return 0;
}
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
cpotrf_(uplo, n, &a[a_offset], lda, info);
if (*info == 0) {
/* Solve the system A*X = B, overwriting B with X. */
cpotrs_(uplo, n, nrhs, &a[a_offset], lda, &b[b_offset], ldb, info);
}
return 0;
/* End of CPOSV */
} /* cposv_ */
/* Subroutine */ int cposvx_(char *fact, char *uplo, integer *n, integer *
nrhs, complex *a, integer *lda, complex *af, integer *ldaf, char *
equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx,
real *rcond, real *ferr, real *berr, complex *work, real *rwork,
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
=======
CPOSVX 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 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**H* U, if UPLO = 'U', or
A = L * L**H, if UPLO = 'L',
where U is an upper triangular matrix and L is a lower triangular
matrix.
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, AF contains the factored form of A.
If EQUED = 'Y', the matrix A has been equilibrated
with scaling factors given by S. A and AF will not
be modified.
= 'N': The matrix A will be copied to AF and factored.
= 'E': The matrix A will be equilibrated if necessary, then
copied to AF and factored.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The number of linear equations, i.e., the order of the
matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the Hermitian matrix A, except if FACT = 'F' and
EQUED = 'Y', then A must contain the equilibrated matrix
diag(S)*A*diag(S). If UPLO = 'U', the leading
N-by-N upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading N-by-N lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced. 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).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
AF (input or output) COMPLEX array, dimension (LDAF,N)
If FACT = 'F', then AF is an input argument and on entry
contains the 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 AF is the factored form
of the equilibrated matrix diag(S)*A*diag(S).
If FACT = 'N', then AF 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 AF 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 A for the form of the
equilibrated matrix).
LDAF (input) INTEGER
The leading dimension of the array AF. LDAF >= max(1,N).
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 righthand 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.
=====================================================================
Parameter adjustments */
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, 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 */
static real amax, smin, smax;
static integer i__, j;
extern logical lsame_(char *, char *);
static real scond, anorm;
static logical equil, rcequ;
extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
real *);
extern /* Subroutine */ int claqhe_(char *, integer *, complex *, integer
*, real *, real *, real *, char *);
extern doublereal slamch_(char *);
static logical nofact;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), xerbla_(char *,
integer *);
static real bignum;
extern /* Subroutine */ int cpocon_(char *, integer *, complex *, integer
*, real *, real *, complex *, real *, integer *);
static integer infequ;
extern /* Subroutine */ int cpoequ_(integer *, complex *, integer *, real
*, real *, real *, integer *), cporfs_(char *, integer *, integer
*, complex *, integer *, complex *, integer *, complex *, integer
*, complex *, integer *, real *, real *, complex *, real *,
integer *), cpotrf_(char *, integer *, complex *, integer
*, integer *), cpotrs_(char *, integer *, integer *,
complex *, integer *, complex *, integer *, integer *);
static real smlnum;
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
--s;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
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 (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (lsame_(fact, "F") && ! (rcequ || lsame_(
equed, "N"))) {
*info = -9;
} 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);
/* L10: */
}
if (smin <= 0.f) {
*info = -10;
} else if (*n > 0) {
scond = dmax(smin,smlnum) / dmin(smax,bignum);
} else {
scond = 1.f;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -12;
} else if (*ldx < max(1,*n)) {
*info = -14;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPOSVX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
cpoequ_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
claqhe_(uplo, n, &a[a_offset], lda, &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 = b_subscr(i__, j);
i__4 = i__;
i__5 = b_subscr(i__, j);
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;
/* L20: */
}
/* L30: */
}
}
if (nofact || equil) {
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
cpotrf_(uplo, n, &af[af_offset], ldaf, info);
/* Return if INFO is non-zero. */
if (*info != 0) {
if (*info > 0) {
*rcond = 0.f;
}
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
/* Compute the reciprocal of the condition number of A. */
cpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1],
info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon")) {
*info = *n + 1;
}
/* Compute the solution matrix X. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
cpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solution and
compute error bounds and backward error estimates for it. */
cporfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &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 = x_subscr(i__, j);
i__4 = i__;
i__5 = x_subscr(i__, j);
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;
/* L40: */
}
/* L50: */
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= scond;
/* L60: */
}
}
return 0;
/* End of CPOSVX */
} /* cposvx_ */
/* Subroutine */ int cposvxx_(char *fact, char *uplo, integer *n, integer *
nrhs, complex *a, integer *lda, complex *af, integer *ldaf, char *
equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx,
real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds__, real *
err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real *
params, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
real r__1, r__2;
/* Local variables */
integer j;
real amax, smin, smax;
extern doublereal cla_porpvgrw__(char *, integer *, complex *, integer *,
complex *, integer *, real *, ftnlen);
extern logical lsame_(char *, char *);
real scond;
logical equil, rcequ;
extern /* Subroutine */ int claqhe_(char *, integer *, complex *, integer
*, real *, real *, real *, char *);
extern doublereal slamch_(char *);
logical nofact;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), xerbla_(char *,
integer *);
real bignum;
integer infequ;
extern /* Subroutine */ int cpotrf_(char *, integer *, complex *, integer
*, integer *), cpotrs_(char *, integer *, integer *,
complex *, integer *, complex *, integer *, integer *);
real smlnum;
extern /* Subroutine */ int clascl2_(integer *, integer *, real *,
complex *, integer *), cpoequb_(integer *, complex *, integer *,
real *, real *, real *, integer *), cporfsx_(char *, char *,
integer *, integer *, complex *, integer *, complex *, integer *,
real *, complex *, integer *, complex *, integer *, real *, real *
, integer *, real *, real *, integer *, real *, complex *, real *,
integer *);
/* -- LAPACK driver routine (version 3.2.1) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- April 2009 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T */
/* to compute the solution to a complex system of linear equations */
/* A * X = B, where A is an N-by-N symmetric positive definite matrix */
/* and X and B are N-by-NRHS matrices. */
/* If requested, both normwise and maximum componentwise error bounds */
/* are returned. CPOSVXX will return a solution with a tiny */
/* guaranteed error (O(eps) where eps is the working machine */
/* precision) unless the matrix is very ill-conditioned, in which */
/* case a warning is returned. Relevant condition numbers also are */
/* calculated and returned. */
/* CPOSVXX accepts user-provided factorizations and equilibration */
/* factors; see the definitions of the FACT and EQUED options. */
/* Solving with refinement and using a factorization from a previous */
/* CPOSVXX call will also produce a solution with either O(eps) */
/* errors or warnings, but we cannot make that claim for general */
/* user-provided factorizations and equilibration factors if they */
/* differ from what CPOSVXX would itself produce. */
/* 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**T* U, if UPLO = 'U', or */
/* A = L * L**T, if UPLO = 'L', */
/* where U is an upper triangular matrix and L is a lower triangular */
/* matrix. */
/* 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 (see argument RCOND). If the reciprocal of the condition number */
/* is less than machine precision, 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. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
/* the routine will use iterative refinement to try to get a small */
/* error and error bounds. Refinement calculates the residual to at */
/* least twice the working precision. */
/* 6. If equilibration was used, the matrix X is premultiplied by */
/* diag(S) so that it solves the original system before */
/* equilibration. */
/* Arguments */
/* ========= */
/* Some optional parameters are bundled in the PARAMS array. These */
/* settings determine how refinement is performed, but often the */
/* defaults are acceptable. If the defaults are acceptable, users */
/* can pass NPARAMS = 0 which prevents the source code from accessing */
/* the PARAMS argument. */
/* 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, AF contains the factored form of A. */
/* If EQUED is not 'N', the matrix A has been */
/* equilibrated with scaling factors given by S. */
/* A and AF are not modified. */
/* = 'N': The matrix A will be copied to AF and factored. */
/* = 'E': The matrix A will be equilibrated if necessary, then */
/* copied to AF and factored. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED = */
/* 'Y', then A must contain the equilibrated matrix */
/* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper */
/* triangular part of A contains the upper triangular part of the */
/* matrix A, and the strictly lower triangular part of A is not */
/* referenced. If UPLO = 'L', the leading N-by-N lower triangular */
/* part of A contains the lower triangular part of the matrix A, and */
/* the strictly upper triangular part of A is not referenced. 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). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input or output) COMPLEX array, dimension (LDAF,N) */
/* If FACT = 'F', then AF is an input argument and on entry */
/* contains the triangular factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T, in the same storage */
/* format as A. If EQUED .ne. 'N', then AF is the factored */
/* form of the equilibrated matrix diag(S)*A*diag(S). */
/* If FACT = 'N', then AF is an output argument and on exit */
/* returns the triangular factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T of the original */
/* matrix A. */
/* If FACT = 'E', then AF is an output argument and on exit */
/* returns the triangular factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T of the equilibrated */
/* matrix A (see the description of A for the form of the */
/* equilibrated matrix). */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* EQUED (input or output) CHARACTER*1 */
/* Specifies the form of equilibration that was done. */
/* = 'N': No equilibration (always true if FACT = 'N'). */
/* = 'Y': Both row and column equilibration, 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 row scale factors for A. If EQUED = 'Y', A is multiplied on */
/* the left and right by diag(S). S is an input argument if FACT = */
/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
/* = 'Y', each element of S must be positive. If S is output, each */
/* element of S is a power of the radix. If S is input, each element */
/* of S should be a power of the radix to ensure a reliable solution */
/* and error estimates. Scaling by powers of the radix does not cause */
/* rounding errors unless the result underflows or overflows. */
/* Rounding errors during scaling lead to refining with a matrix that */
/* is not equivalent to the input matrix, producing error estimates */
/* that may not be reliable. */
/* B (input/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, the N-by-NRHS solution matrix X to the original */
/* system of equations. Note that A and B are modified on exit if */
/* EQUED .ne. 'N', 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 */
/* Reciprocal scaled condition number. This is an estimate of the */
/* reciprocal Skeel condition number of the matrix A after */
/* equilibration (if done). If this is less than the machine */
/* precision (in particular, if it is zero), the matrix is singular */
/* to working precision. Note that the error may still be small even */
/* if this number is very small and the matrix appears ill- */
/* conditioned. */
/* RPVGRW (output) REAL */
/* Reciprocal pivot growth. On exit, this contains the reciprocal */
/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
/* norm is used. If this is much less than 1, then the stability of */
/* the LU factorization of the (equilibrated) matrix A could be poor. */
/* This also means that the solution X, estimated condition numbers, */
/* and error bounds could be unreliable. If factorization fails with */
/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
/* for the leading INFO columns of A. */
/* BERR (output) REAL array, dimension (NRHS) */
/* Componentwise relative backward error. This is the */
/* componentwise relative backward error of each solution vector X(j) */
/* (i.e., the smallest relative change in any element of A or B that */
/* makes X(j) an exact solution). */
/* N_ERR_BNDS (input) INTEGER */
/* Number of error bounds to return for each right hand side */
/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
/* ERR_BNDS_COMP below. */
/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* normwise relative error, which is defined as follows: */
/* Normwise relative error in the ith solution vector: */
/* max_j (abs(XTRUE(j,i) - X(j,i))) */
/* ------------------------------ */
/* max_j abs(X(j,i)) */
/* The array is indexed by the type of error information as described */
/* below. There currently are up to three pieces of information */
/* returned. */
/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_NORM(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated normwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*A, where S scales each row by a power of the */
/* radix so all absolute row sums of Z are approximately 1. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* componentwise relative error, which is defined as follows: */
/* Componentwise relative error in the ith solution vector: */
/* abs(XTRUE(j,i) - X(j,i)) */
/* max_j ---------------------- */
/* abs(X(j,i)) */
/* The array is indexed by the right-hand side i (on which the */
/* componentwise relative error depends), and the type of error */
/* information as described below. There currently are up to three */
/* pieces of information returned for each right-hand side. If */
/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
/* the first (:,N_ERR_BNDS) entries are returned. */
/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_COMP(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated componentwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*(A*diag(x)), where x is the solution for the */
/* current right-hand side and S scales each row of */
/* A*diag(x) by a power of the radix so all absolute row */
/* sums of Z are approximately 1. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* NPARAMS (input) INTEGER */
/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
/* PARAMS array is never referenced and default values are used. */
/* PARAMS (input / output) REAL array, dimension NPARAMS */
/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
/* that entry will be filled with default value used for that */
/* parameter. Only positions up to NPARAMS are accessed; defaults */
/* are used for higher-numbered parameters. */
/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
/* refinement or not. */
/* Default: 1.0 */
/* = 0.0 : No refinement is performed, and no error bounds are */
/* computed. */
/* = 1.0 : Use the double-precision refinement algorithm, */
/* possibly with doubled-single computations if the */
/* compilation environment does not support DOUBLE */
/* PRECISION. */
/* (other values are reserved for future use) */
/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
/* computations allowed for refinement. */
/* Default: 10 */
/* Aggressive: Set to 100 to permit convergence using approximate */
/* factorizations or factorizations other than LU. If */
/* the factorization uses a technique other than */
/* Gaussian elimination, the guarantees in */
/* err_bnds_norm and err_bnds_comp may no longer be */
/* trustworthy. */
/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
/* will attempt to find a solution with small componentwise */
/* relative error in the double-precision algorithm. Positive */
/* is true, 0.0 is false. */
/* Default: 1.0 (attempt componentwise convergence) */
/* WORK (workspace) COMPLEX array, dimension (2*N) */
/* RWORK (workspace) REAL array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: Successful exit. The solution to every right-hand side is */
/* guaranteed. */
/* < 0: If INFO = -i, the i-th argument had an illegal value */
/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly singular, so */
/* the solution and error bounds could not be computed. RCOND = 0 */
/* is returned. */
/* = N+J: The solution corresponding to the Jth right-hand side is */
/* not guaranteed. The solutions corresponding to other right- */
/* hand sides K with K > J may not be guaranteed as well, but */
/* only the first such right-hand side is reported. If a small */
/* componentwise error is not requested (PARAMS(3) = 0.0) then */
/* the Jth right-hand side is the first with a normwise error */
/* bound that is not guaranteed (the smallest J such */
/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
/* the Jth right-hand side is the first with either a normwise or */
/* componentwise error bound that is not guaranteed (the smallest */
/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
/* about all of the right-hand sides check ERR_BNDS_NORM or */
/* ERR_BNDS_COMP. */
/* ================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
err_bnds_comp_dim1 = *nrhs;
err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
err_bnds_comp__ -= err_bnds_comp_offset;
err_bnds_norm_dim1 = *nrhs;
err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
err_bnds_norm__ -= err_bnds_norm_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--s;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--berr;
--params;
--work;
--rwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rcequ = FALSE_;
} else {
rcequ = lsame_(equed, "Y");
}
/* Default is failure. If an input parameter is wrong or */
/* factorization fails, make everything look horrible. Only the */
/* pivot growth is set here, the rest is initialized in CPORFSX. */
*rpvgrw = 0.f;
/* Test the input parameters. PARAMS is not tested until CPORFSX. */
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 (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (lsame_(fact, "F") && ! (rcequ || lsame_(
equed, "N"))) {
*info = -9;
} 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);
/* L10: */
}
if (smin <= 0.f) {
*info = -10;
} else if (*n > 0) {
scond = dmax(smin,smlnum) / dmin(smax,bignum);
} else {
scond = 1.f;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -12;
} else if (*ldx < max(1,*n)) {
*info = -14;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPOSVXX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
cpoequb_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
claqhe_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
rcequ = lsame_(equed, "Y");
}
}
/* Scale the right-hand side. */
if (rcequ) {
clascl2_(n, nrhs, &s[1], &b[b_offset], ldb);
}
if (nofact || equil) {
/* Compute the LU factorization of A. */
clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
cpotrf_(uplo, n, &af[af_offset], ldaf, info);
/* Return if INFO is non-zero. */
if (*info > 0) {
/* Pivot in column INFO is exactly 0 */
/* Compute the reciprocal pivot growth factor of the */
/* leading rank-deficient INFO columns of A. */
*rpvgrw = cla_porpvgrw__(uplo, n, &a[a_offset], lda, &af[
af_offset], ldaf, &rwork[1], (ftnlen)1);
return 0;
}
}
/* Compute the reciprocal pivot growth factor RPVGRW. */
*rpvgrw = cla_porpvgrw__(uplo, n, &a[a_offset], lda, &af[af_offset], ldaf,
&rwork[1], (ftnlen)1);
/* Compute the solution matrix X. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
cpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solution and */
/* compute error bounds and backward error estimates for it. */
cporfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &berr[1],
n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], &
err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[
1], &rwork[1], info);
/* Scale solutions. */
if (rcequ) {
clascl2_(n, nrhs, &s[1], &x[x_offset], ldx);
}
return 0;
/* End of CPOSVXX */
} /* cposvxx_ */
/* Subroutine */ int chegv_(integer *itype, char *jobz, char *uplo, integer *
n, complex *a, integer *lda, complex *b, integer *ldb, real *w,
complex *work, integer *lwork, real *rwork, 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
=======
CHEGV computes all the eigenvalues, and optionally, the eigenvectors
of a complex generalized Hermitian-definite eigenproblem, of the form
A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
Here A and B are assumed to be Hermitian and B is also
positive definite.
Arguments
=========
ITYPE (input) INTEGER
Specifies the problem type to be solved:
= 1: A*x = (lambda)*B*x
= 2: A*B*x = (lambda)*x
= 3: B*A*x = (lambda)*x
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangles of A and B are stored;
= 'L': Lower triangles of A and B are stored.
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) COMPLEX array, dimension (LDA, N)
On entry, the Hermitian matrix A. If UPLO = 'U', the
leading N-by-N upper triangular part of A contains the
upper triangular part of the matrix A. If UPLO = 'L',
the leading N-by-N lower triangular part of A contains
the lower triangular part of the matrix A.
On exit, if JOBZ = 'V', then if INFO = 0, A contains the
matrix Z of eigenvectors. The eigenvectors are normalized
as follows:
if ITYPE = 1 or 2, Z**H*B*Z = I;
if ITYPE = 3, Z**H*inv(B)*Z = I.
If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
or the lower triangle (if UPLO='L') of A, including the
diagonal, is destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) COMPLEX array, dimension (LDB, N)
On entry, the Hermitian positive definite matrix B.
If UPLO = 'U', the leading N-by-N upper triangular part of B
contains the upper triangular part of the matrix B.
If UPLO = 'L', the leading N-by-N lower triangular part of B
contains the lower triangular part of the matrix B.
On exit, if INFO <= N, the part of B containing the matrix is
overwritten by the triangular factor U or L from the Cholesky
factorization B = U**H*U or B = L*L**H.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
W (output) REAL array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of the array WORK. LWORK >= max(1,2*N-1).
For optimal efficiency, LWORK >= (NB+1)*N,
where NB is the blocksize for CHETRD returned by ILAENV.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
RWORK (workspace) REAL array, dimension (max(1, 3*N-2))
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: CPOTRF or CHEEV returned an error code:
<= N: if INFO = i, CHEEV failed to converge;
i off-diagonal elements of an intermediate
tridiagonal form did not converge to zero;
> N: if INFO = N + i, for 1 <= i <= N, then the leading
minor of order i of B is not positive definite.
The factorization of B could not be completed and
no eigenvalues or eigenvectors were computed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
static integer c_n1 = -1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
static integer neig;
extern /* Subroutine */ int cheev_(char *, char *, integer *, complex *,
integer *, real *, complex *, integer *, real *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
static char trans[1];
extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
static logical upper, wantz;
static integer nb;
extern /* Subroutine */ int chegst_(integer *, char *, integer *, complex
*, integer *, complex *, integer *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *), cpotrf_(
char *, integer *, complex *, integer *, integer *);
static integer lwkopt;
static logical lquery;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--w;
--work;
--rwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1;
*info = 0;
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 1) - 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -11;
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
lwkopt = (nb + 1) * *n;
work[1].r = (real) lwkopt, work[1].i = 0.f;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEGV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
cpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
chegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
cheev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[1]
, info);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'C';
}
ctrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
b_offset], ldb, &a[a_offset], lda);
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x;
backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'C';
} else {
*(unsigned char *)trans = 'N';
}
ctrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
b_offset], ldb, &a[a_offset], lda);
}
}
work[1].r = (real) lwkopt, work[1].i = 0.f;
return 0;
/* End of CHEGV */
} /* chegv_ */
/* Subroutine */
int cposvxx_(char *fact, char *uplo, integer *n, integer * nrhs, complex *a, integer *lda, complex *af, integer *ldaf, char * equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds__, real * err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real * params, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
real r__1, r__2;
/* Local variables */
integer j;
real amax, smin, smax;
extern real cla_porpvgrw_(char *, integer *, complex *, integer *, complex *, integer *, real *);
extern logical lsame_(char *, char *);
real scond;
logical equil, rcequ;
extern /* Subroutine */
int claqhe_(char *, integer *, complex *, integer *, real *, real *, real *, char *);
extern real slamch_(char *);
logical nofact;
extern /* Subroutine */
int clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *);
real bignum;
integer infequ;
extern /* Subroutine */
int cpotrf_(char *, integer *, complex *, integer *, integer *), cpotrs_(char *, integer *, integer *, complex *, integer *, complex *, integer *, integer *);
real smlnum;
extern /* Subroutine */
int clascl2_(integer *, integer *, real *, complex *, integer *), cpoequb_(integer *, complex *, integer *, real *, real *, real *, integer *), cporfsx_(char *, char *, integer *, integer *, complex *, integer *, complex *, integer *, real *, complex *, integer *, complex *, integer *, real *, real * , integer *, real *, real *, integer *, real *, complex *, real *, 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 .. */
/* Parameter adjustments */
err_bnds_comp_dim1 = *nrhs;
err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
err_bnds_comp__ -= err_bnds_comp_offset;
err_bnds_norm_dim1 = *nrhs;
err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
err_bnds_norm__ -= err_bnds_norm_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--s;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--berr;
--params;
--work;
--rwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
if (nofact || equil)
{
*(unsigned char *)equed = 'N';
rcequ = FALSE_;
}
else
{
rcequ = lsame_(equed, "Y");
}
/* Default is failure. If an input parameter is wrong or */
/* factorization fails, make everything look horrible. Only the */
/* pivot growth is set here, the rest is initialized in CPORFSX. */
*rpvgrw = 0.f;
/* Test the input parameters. PARAMS is not tested until CPORFSX. */
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 (*lda < max(1,*n))
{
*info = -6;
}
else if (*ldaf < max(1,*n))
{
*info = -8;
}
else if (lsame_(fact, "F") && ! (rcequ || lsame_( equed, "N")))
{
*info = -9;
}
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]; // , expr subst
smin = min(r__1,r__2);
/* Computing MAX */
r__1 = smax;
r__2 = s[j]; // , expr subst
smax = max(r__1,r__2);
/* L10: */
}
if (smin <= 0.f)
{
*info = -10;
}
else if (*n > 0)
{
scond = max(smin,smlnum) / min(smax,bignum);
}
else
{
scond = 1.f;
}
}
if (*info == 0)
{
if (*ldb < max(1,*n))
{
*info = -12;
}
else if (*ldx < max(1,*n))
{
*info = -14;
}
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CPOSVXX", &i__1);
return 0;
}
if (equil)
{
/* Compute row and column scalings to equilibrate the matrix A. */
cpoequb_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
if (infequ == 0)
{
/* Equilibrate the matrix. */
claqhe_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
rcequ = lsame_(equed, "Y");
}
}
/* Scale the right-hand side. */
if (rcequ)
{
clascl2_(n, nrhs, &s[1], &b[b_offset], ldb);
}
if (nofact || equil)
{
/* Compute the Cholesky factorization of A. */
clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
cpotrf_(uplo, n, &af[af_offset], ldaf, info);
/* Return if INFO is non-zero. */
if (*info > 0)
{
/* Pivot in column INFO is exactly 0 */
/* Compute the reciprocal pivot growth factor of the */
/* leading rank-deficient INFO columns of A. */
*rpvgrw = cla_porpvgrw_(uplo, n, &a[a_offset], lda, &af[ af_offset], ldaf, &rwork[1]);
return 0;
}
}
/* Compute the reciprocal pivot growth factor RPVGRW. */
*rpvgrw = cla_porpvgrw_(uplo, n, &a[a_offset], lda, &af[af_offset], ldaf, &rwork[1]);
/* Compute the solution matrix X. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
cpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solution and */
/* compute error bounds and backward error estimates for it. */
cporfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, & s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &berr[1], n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], & err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[ 1], &rwork[1], info);
/* Scale solutions. */
if (rcequ)
{
clascl2_(n, nrhs, &s[1], &x[x_offset], ldx);
}
return 0;
/* End of CPOSVXX */
}
/* Subroutine */ int chegvx_(integer *itype, char *jobz, char *range, char *
uplo, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *
m, real *w, complex *z__, integer *ldz, complex *work, integer *lwork,
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
=======
CHEGVX computes selected eigenvalues, and optionally, eigenvectors
of a complex generalized Hermitian-definite eigenproblem, of the form
A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
B are assumed to be Hermitian and B is also positive definite.
Eigenvalues and eigenvectors can be selected by specifying either a
range of values or a range of indices for the desired eigenvalues.
Arguments
=========
ITYPE (input) INTEGER
Specifies the problem type to be solved:
= 1: A*x = (lambda)*B*x
= 2: A*B*x = (lambda)*x
= 3: B*A*x = (lambda)*x
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 triangles of A and B are stored;
= 'L': Lower triangles of A and B are stored.
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) COMPLEX array, dimension (LDA, N)
On entry, the Hermitian matrix A. If UPLO = 'U', the
leading N-by-N upper triangular part of A contains the
upper triangular part of the matrix A. If UPLO = 'L',
the leading N-by-N lower triangular part of A contains
the lower triangular part of the matrix A.
On exit, the lower triangle (if UPLO='L') or the upper
triangle (if UPLO='U') of A, including the diagonal, is
destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) COMPLEX array, dimension (LDB, N)
On entry, the Hermitian matrix B. If UPLO = 'U', the
leading N-by-N upper triangular part of B contains the
upper triangular part of the matrix B. If UPLO = 'L',
the leading N-by-N lower triangular part of B contains
the lower triangular part of the matrix B.
On exit, if INFO <= N, the part of B containing the matrix is
overwritten by the triangular factor U or L from the Cholesky
factorization B = U**H*U or B = L*L**H.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
VL (input) REAL
VU (input) REAL
If RANGE='V', the lower and upper bounds of the interval to
be searched for eigenvalues. VL < VU.
Not referenced if RANGE = 'A' or 'I'.
IL (input) INTEGER
IU (input) INTEGER
If RANGE='I', the indices (in ascending order) of the
smallest and largest eigenvalues to be returned.
1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
Not referenced if RANGE = 'A' or 'V'.
ABSTOL (input) REAL
The absolute error tolerance for the eigenvalues.
An approximate eigenvalue is accepted as converged
when it is determined to lie in an interval [a,b]
of width less than or equal to
ABSTOL + EPS * max( |a|,|b| ) ,
where EPS is the machine precision. If ABSTOL is less than
or equal to zero, then EPS*|T| will be used in its place,
where |T| is the 1-norm of the tridiagonal matrix obtained
by reducing A to tridiagonal form.
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').
M (output) INTEGER
The total number of eigenvalues found. 0 <= M <= N.
If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
W (output) REAL array, dimension (N)
The first M elements contain the selected
eigenvalues in ascending order.
Z (output) COMPLEX array, dimension (LDZ, max(1,M))
If JOBZ = 'N', then Z is not referenced.
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).
The eigenvectors are normalized as follows:
if ITYPE = 1 or 2, Z**T*B*Z = I;
if ITYPE = 3, Z**T*inv(B)*Z = 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.
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/output) COMPLEX array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of the array WORK. LWORK >= max(1,2*N-1).
For optimal efficiency, LWORK >= (NB+1)*N,
where NB is the blocksize for CHETRD returned by ILAENV.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
RWORK (workspace) REAL array, dimension (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: CPOTRF or CHEEVX returned an error code:
<= N: if INFO = i, CHEEVX failed to converge;
i eigenvectors failed to converge. Their indices
are stored in array IFAIL.
> N: if INFO = N + i, for 1 <= i <= N, then the leading
minor of order i of B is not positive definite.
The factorization of B could not be completed and
no eigenvalues or eigenvectors were computed.
Further Details
===============
Based on contributions by
Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
static integer c_n1 = -1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2;
/* Local variables */
static integer lopt;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
static char trans[1];
extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
static logical upper, wantz;
static integer nb;
static logical alleig, indeig, valeig;
extern /* Subroutine */ int chegst_(integer *, char *, integer *, complex
*, integer *, complex *, integer *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *), cheevx_(
char *, char *, char *, integer *, complex *, integer *, real *,
real *, integer *, integer *, real *, integer *, real *, complex *
, integer *, complex *, integer *, real *, integer *, integer *,
integer *), cpotrf_(char *, integer *,
complex *, integer *, integer *);
static integer lwkopt;
static logical lquery;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1;
*info = 0;
if (*itype < 0 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (alleig || valeig || indeig)) {
*info = -3;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (valeig && *n > 0) {
if (*vu <= *vl) {
*info = -11;
}
} else if (indeig && *il < 1) {
*info = -12;
} else if (indeig && (*iu < min(*n,*il) || *iu > *n)) {
*info = -13;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -18;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 1) - 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -20;
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
lwkopt = (nb + 1) * *n;
work[1].r = (real) lwkopt, work[1].i = 0.f;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEGVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
work[1].r = 1.f, work[1].i = 0.f;
return 0;
}
/* Form a Cholesky factorization of B. */
cpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
chegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
cheevx_(jobz, range, uplo, n, &a[a_offset], lda, vl, vu, il, iu, abstol,
m, &w[1], &z__[z_offset], ldz, &work[1], lwork, &rwork[1], &iwork[
1], &ifail[1], info);
lopt = work[1].r;
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
if (*info > 0) {
*m = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'C';
}
ctrsm_("Left", uplo, trans, "Non-unit", n, m, &c_b1, &b[b_offset],
ldb, &z__[z_offset], ldz);
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x;
backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'C';
} else {
*(unsigned char *)trans = 'N';
}
ctrmm_("Left", uplo, trans, "Non-unit", n, m, &c_b1, &b[b_offset],
ldb, &z__[z_offset], ldz);
}
}
/* Set WORK(1) to optimal complex workspace size. */
work[1].r = (real) lwkopt, work[1].i = 0.f;
return 0;
/* End of CHEGVX */
} /* chegvx_ */
/* Subroutine */ int cposv_(char *uplo, integer *n, integer *nrhs, complex *a,
integer *lda, complex *b, integer *ldb, 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
March 31, 1993
Purpose
=======
CPOSV computes the solution to a complex system of linear equations
A * X = B,
where A is an N-by-N Hermitian positive definite matrix and X and B
are N-by-NRHS matrices.
The Cholesky decomposition is used to factor A as
A = U**H* U, if UPLO = 'U', or
A = L * L**H, if UPLO = 'L',
where U is an upper triangular matrix and L is a lower triangular
matrix. The factored form of A is then used to solve the system of
equations A * X = B.
Arguments
=========
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 matrix B. NRHS >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the Hermitian matrix A. If UPLO = 'U', the leading
N-by-N upper triangular part of A contains the upper
triangular part of the matrix A, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading N-by-N lower triangular part of A contains the lower
triangular part of the matrix A, and the strictly upper
triangular part of A is not referenced.
On exit, if INFO = 0, the factor U or L from the Cholesky
factorization A = U**H*U or A = L*L**H.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) COMPLEX array, dimension (LDB,NRHS)
On entry, the N-by-NRHS right hand side matrix B.
On exit, if INFO = 0, the N-by-NRHS solution matrix X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, 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.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *);
extern /* Subroutine */ int xerbla_(char *, integer *), cpotrf_(
char *, integer *, complex *, integer *, integer *),
cpotrs_(char *, integer *, integer *, complex *, integer *,
complex *, integer *, integer *);
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPOSV ", &i__1);
return 0;
}
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
cpotrf_(uplo, n, &a[a_offset], lda, info);
if (*info == 0) {
/* Solve the system A*X = B, overwriting B with X. */
cpotrs_(uplo, n, nrhs, &a[a_offset], lda, &b[b_offset], ldb, info);
}
return 0;
/* End of CPOSV */
} /* cposv_ */
/* Subroutine */ int chegvd_(integer *itype, char *jobz, char *uplo, integer *
n, complex *a, integer *lda, complex *b, integer *ldb, real *w,
complex *work, integer *lwork, real *rwork, integer *lrwork, integer *
iwork, integer *liwork, 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
=======
CHEGVD computes all the eigenvalues, and optionally, the eigenvectors
of a complex generalized Hermitian-definite eigenproblem, of the form
A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
B are assumed to be Hermitian and B is also positive definite.
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
=========
ITYPE (input) INTEGER
Specifies the problem type to be solved:
= 1: A*x = (lambda)*B*x
= 2: A*B*x = (lambda)*x
= 3: B*A*x = (lambda)*x
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangles of A and B are stored;
= 'L': Lower triangles of A and B are stored.
N (input) INTEGER
The order of the matrices A and B. N >= 0.
A (input/output) COMPLEX array, dimension (LDA, N)
On entry, the Hermitian matrix A. If UPLO = 'U', the
leading N-by-N upper triangular part of A contains the
upper triangular part of the matrix A. If UPLO = 'L',
the leading N-by-N lower triangular part of A contains
the lower triangular part of the matrix A.
On exit, if JOBZ = 'V', then if INFO = 0, A contains the
matrix Z of eigenvectors. The eigenvectors are normalized
as follows:
if ITYPE = 1 or 2, Z**H*B*Z = I;
if ITYPE = 3, Z**H*inv(B)*Z = I.
If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
or the lower triangle (if UPLO='L') of A, including the
diagonal, is destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) COMPLEX array, dimension (LDB, N)
On entry, the Hermitian matrix B. If UPLO = 'U', the
leading N-by-N upper triangular part of B contains the
upper triangular part of the matrix B. If UPLO = 'L',
the leading N-by-N lower triangular part of B contains
the lower triangular part of the matrix B.
On exit, if INFO <= N, the part of B containing the matrix is
overwritten by the triangular factor U or L from the Cholesky
factorization B = U**H*U or B = L*L**H.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
W (output) REAL array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of the array WORK.
If N <= 1, LWORK >= 1.
If JOBZ = 'N' and N > 1, LWORK >= N + 1.
If JOBZ = 'V' and N > 1, LWORK >= 2*N + N**2.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
RWORK (workspace/output) REAL array, dimension (LRWORK)
On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
LRWORK (input) INTEGER
The dimension of the array RWORK.
If N <= 1, LRWORK >= 1.
If JOBZ = 'N' and N > 1, LRWORK >= N.
If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.
If LRWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal size of the RWORK array,
returns this value as the first entry of the RWORK array, and
no error message related to LRWORK is issued by XERBLA.
IWORK (workspace/output) INTEGER array, dimension (LIWORK)
On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
LIWORK (input) INTEGER
The dimension of the array IWORK.
If N <= 1, LIWORK >= 1.
If JOBZ = 'N' and N > 1, LIWORK >= 1.
If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: CPOTRF or CHEEVD returned an error code:
<= N: if INFO = i, CHEEVD failed to converge;
i off-diagonal elements of an intermediate
tridiagonal form did not converge to zero;
> N: if INFO = N + i, for 1 <= i <= N, then the leading
minor of order i of B is not positive definite.
The factorization of B could not be completed and
no eigenvalues or eigenvectors were computed.
Further Details
===============
Based on contributions by
Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
real r__1, r__2;
/* Local variables */
static integer neig, lopt;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
static integer lwmin;
static char trans[1];
static integer liopt;
extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
static logical upper;
static integer lropt;
static logical wantz;
extern /* Subroutine */ int cheevd_(char *, char *, integer *, complex *,
integer *, real *, complex *, integer *, real *, integer *,
integer *, integer *, integer *), chegst_(integer
*, char *, integer *, complex *, integer *, complex *, integer *,
integer *), xerbla_(char *, integer *), cpotrf_(
char *, integer *, complex *, integer *, integer *);
static integer liwmin, lrwmin;
static logical lquery;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--w;
--work;
--rwork;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
*info = 0;
if (*n <= 1) {
lwmin = 1;
lrwmin = 1;
liwmin = 1;
lopt = lwmin;
lropt = lrwmin;
liopt = liwmin;
} else {
if (wantz) {
lwmin = (*n << 1) + *n * *n;
lrwmin = *n * 5 + 1 + (*n << 1) * *n;
liwmin = *n * 5 + 3;
} else {
lwmin = *n + 1;
lrwmin = *n;
liwmin = 1;
}
lopt = lwmin;
lropt = lrwmin;
liopt = liwmin;
}
if (*itype < 0 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*lwork < lwmin && ! lquery) {
*info = -11;
} else if (*lrwork < lrwmin && ! lquery) {
*info = -13;
} else if (*liwork < liwmin && ! lquery) {
*info = -15;
}
if (*info == 0) {
work[1].r = (real) lopt, work[1].i = 0.f;
rwork[1] = (real) lropt;
iwork[1] = liopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEGVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
cpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
chegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
cheevd_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[
1], lrwork, &iwork[1], liwork, info);
/* Computing MAX */
r__1 = (real) lopt, r__2 = work[1].r;
lopt = dmax(r__1,r__2);
/* Computing MAX */
r__1 = (real) lropt;
lropt = dmax(r__1,rwork[1]);
/* Computing MAX */
r__1 = (real) liopt, r__2 = (real) iwork[1];
liopt = dmax(r__1,r__2);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'C';
}
ctrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
b_offset], ldb, &a[a_offset], lda);
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x;
backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'C';
} else {
*(unsigned char *)trans = 'N';
}
ctrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
b_offset], ldb, &a[a_offset], lda);
}
}
work[1].r = (real) lopt, work[1].i = 0.f;
rwork[1] = (real) lropt;
iwork[1] = liopt;
return 0;
/* End of CHEGVD */
} /* chegvd_ */
/* Subroutine */ int chegvd_(integer *itype, char *jobz, char *uplo, integer *
n, complex *a, integer *lda, complex *b, integer *ldb, real *w,
complex *work, integer *lwork, real *rwork, integer *lrwork, integer *
iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1;
real r__1, r__2;
/* Local variables */
integer lopt;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
integer lwmin;
char trans[1];
integer liopt;
extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *);
logical upper;
integer lropt;
logical wantz;
extern /* Subroutine */ int cheevd_(char *, char *, integer *, complex *,
integer *, real *, complex *, integer *, real *, integer *,
integer *, integer *, integer *), chegst_(integer
*, char *, integer *, complex *, integer *, complex *, integer *,
integer *), xerbla_(char *, integer *), cpotrf_(
char *, integer *, complex *, integer *, integer *);
integer liwmin, lrwmin;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHEGVD computes all the eigenvalues, and optionally, the eigenvectors */
/* of a complex generalized Hermitian-definite eigenproblem, of the form */
/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */
/* B are assumed to be Hermitian and B is also positive definite. */
/* 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 */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the problem type to be solved: */
/* = 1: A*x = (lambda)*B*x */
/* = 2: A*B*x = (lambda)*x */
/* = 3: B*A*x = (lambda)*x */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangles of A and B are stored; */
/* = 'L': Lower triangles of A and B are stored. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA, N) */
/* On entry, the Hermitian matrix A. If UPLO = 'U', the */
/* leading N-by-N upper triangular part of A contains the */
/* upper triangular part of the matrix A. If UPLO = 'L', */
/* the leading N-by-N lower triangular part of A contains */
/* the lower triangular part of the matrix A. */
/* On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
/* matrix Z of eigenvectors. The eigenvectors are normalized */
/* as follows: */
/* if ITYPE = 1 or 2, Z**H*B*Z = I; */
/* if ITYPE = 3, Z**H*inv(B)*Z = I. */
/* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */
/* or the lower triangle (if UPLO='L') of A, including the */
/* diagonal, is destroyed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) COMPLEX array, dimension (LDB, N) */
/* On entry, the Hermitian matrix B. If UPLO = 'U', the */
/* leading N-by-N upper triangular part of B contains the */
/* upper triangular part of the matrix B. If UPLO = 'L', */
/* the leading N-by-N lower triangular part of B contains */
/* the lower triangular part of the matrix B. */
/* On exit, if INFO <= N, the part of B containing the matrix is */
/* overwritten by the triangular factor U or L from the Cholesky */
/* factorization B = U**H*U or B = L*L**H. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* W (output) REAL array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. */
/* If N <= 1, LWORK >= 1. */
/* If JOBZ = 'N' and N > 1, LWORK >= N + 1. */
/* If JOBZ = 'V' and N > 1, LWORK >= 2*N + N**2. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal sizes of the WORK, RWORK and */
/* IWORK arrays, returns these values as the first entries of */
/* the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK)) */
/* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */
/* LRWORK (input) INTEGER */
/* The dimension of the array RWORK. */
/* If N <= 1, LRWORK >= 1. */
/* If JOBZ = 'N' and N > 1, LRWORK >= N. */
/* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2. */
/* If LRWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK, RWORK */
/* and IWORK arrays, returns these values as the first entries */
/* of the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the array IWORK. */
/* If N <= 1, LIWORK >= 1. */
/* If JOBZ = 'N' and N > 1, LIWORK >= 1. */
/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK, RWORK */
/* and IWORK arrays, returns these values as the first entries */
/* of the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: CPOTRF or CHEEVD returned an error code: */
/* <= N: if INFO = i and JOBZ = 'N', then the algorithm */
/* failed to converge; i off-diagonal elements of an */
/* intermediate tridiagonal form did not converge to */
/* zero; */
/* if INFO = i and JOBZ = 'V', then the algorithm */
/* failed to compute an eigenvalue while working on */
/* the submatrix lying in rows and columns INFO/(N+1) */
/* through mod(INFO,N+1); */
/* > N: if INFO = N + i, for 1 <= i <= N, then the leading */
/* minor of order i of B is not positive definite. */
/* The factorization of B could not be completed and */
/* no eigenvalues or eigenvectors were computed. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
/* Modified so that no backsubstitution is performed if CHEEVD fails to */
/* converge (NEIG in old code could be greater than N causing out of */
/* bounds reference to A - reported by Ralf Meyer). Also corrected the */
/* description of INFO and the test on ITYPE. Sven, 16 Feb 05. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--w;
--work;
--rwork;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
*info = 0;
if (*n <= 1) {
lwmin = 1;
lrwmin = 1;
liwmin = 1;
} else if (wantz) {
lwmin = (*n << 1) + *n * *n;
lrwmin = *n * 5 + 1 + (*n << 1) * *n;
liwmin = *n * 5 + 3;
} else {
lwmin = *n + 1;
lrwmin = *n;
liwmin = 1;
}
lopt = lwmin;
lropt = lrwmin;
liopt = liwmin;
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info == 0) {
work[1].r = (real) lopt, work[1].i = 0.f;
rwork[1] = (real) lropt;
iwork[1] = liopt;
if (*lwork < lwmin && ! lquery) {
*info = -11;
} else if (*lrwork < lrwmin && ! lquery) {
*info = -13;
} else if (*liwork < liwmin && ! lquery) {
*info = -15;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEGVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
cpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
chegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
cheevd_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[
1], lrwork, &iwork[1], liwork, info);
/* Computing MAX */
r__1 = (real) lopt, r__2 = work[1].r;
lopt = dmax(r__1,r__2);
/* Computing MAX */
r__1 = (real) lropt;
lropt = dmax(r__1,rwork[1]);
/* Computing MAX */
r__1 = (real) liopt, r__2 = (real) iwork[1];
liopt = dmax(r__1,r__2);
if (wantz && *info == 0) {
/* Backtransform eigenvectors to the original problem. */
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'C';
}
ctrsm_("Left", uplo, trans, "Non-unit", n, n, &c_b1, &b[b_offset],
ldb, &a[a_offset], lda);
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x; */
/* backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'C';
} else {
*(unsigned char *)trans = 'N';
}
ctrmm_("Left", uplo, trans, "Non-unit", n, n, &c_b1, &b[b_offset],
ldb, &a[a_offset], lda);
}
}
work[1].r = (real) lopt, work[1].i = 0.f;
rwork[1] = (real) lropt;
iwork[1] = liopt;
return 0;
/* End of CHEGVD */
} /* chegvd_ */
/* Subroutine */ int cerrpo_(char *path, integer *nunit)
{
/* System generated locals */
integer i__1;
real r__1, r__2;
complex q__1;
/* Local variables */
complex a[16] /* was [4][4] */, b[4];
integer i__, j;
real r__[4];
complex w[8], x[4];
char c2[2];
real r1[4], r2[4];
complex af[16] /* was [4][4] */;
integer info;
real anrm, rcond;
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CERRPO tests the error exits for the COMPLEX routines */
/* for Hermitian positive definite matrices. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Set the variables to innocuous values. */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
i__1 = i__ + (j << 2) - 5;
r__1 = 1.f / (real) (i__ + j);
r__2 = -1.f / (real) (i__ + j);
q__1.r = r__1, q__1.i = r__2;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = i__ + (j << 2) - 5;
r__1 = 1.f / (real) (i__ + j);
r__2 = -1.f / (real) (i__ + j);
q__1.r = r__1, q__1.i = r__2;
af[i__1].r = q__1.r, af[i__1].i = q__1.i;
/* L10: */
}
i__1 = j - 1;
b[i__1].r = 0.f, b[i__1].i = 0.f;
r1[j - 1] = 0.f;
r2[j - 1] = 0.f;
i__1 = j - 1;
w[i__1].r = 0.f, w[i__1].i = 0.f;
i__1 = j - 1;
x[i__1].r = 0.f, x[i__1].i = 0.f;
/* L20: */
}
anrm = 1.f;
infoc_1.ok = TRUE_;
/* Test error exits of the routines that use the Cholesky */
/* decomposition of a Hermitian positive definite matrix. */
if (lsamen_(&c__2, c2, "PO")) {
/* CPOTRF */
s_copy(srnamc_1.srnamt, "CPOTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpotrf_("/", &c__0, a, &c__1, &info);
chkxer_("CPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpotrf_("U", &c_n1, a, &c__1, &info);
chkxer_("CPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cpotrf_("U", &c__2, a, &c__1, &info);
chkxer_("CPOTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPOTF2 */
s_copy(srnamc_1.srnamt, "CPOTF2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpotf2_("/", &c__0, a, &c__1, &info);
chkxer_("CPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpotf2_("U", &c_n1, a, &c__1, &info);
chkxer_("CPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cpotf2_("U", &c__2, a, &c__1, &info);
chkxer_("CPOTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPOTRI */
s_copy(srnamc_1.srnamt, "CPOTRI", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpotri_("/", &c__0, a, &c__1, &info);
chkxer_("CPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpotri_("U", &c_n1, a, &c__1, &info);
chkxer_("CPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cpotri_("U", &c__2, a, &c__1, &info);
chkxer_("CPOTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPOTRS */
s_copy(srnamc_1.srnamt, "CPOTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpotrs_("/", &c__0, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("CPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpotrs_("U", &c_n1, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("CPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cpotrs_("U", &c__0, &c_n1, a, &c__1, b, &c__1, &info);
chkxer_("CPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cpotrs_("U", &c__2, &c__1, a, &c__1, b, &c__2, &info);
chkxer_("CPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
cpotrs_("U", &c__2, &c__1, a, &c__2, b, &c__1, &info);
chkxer_("CPOTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPORFS */
s_copy(srnamc_1.srnamt, "CPORFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cporfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
r1, r2, w, r__, &info);
chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cporfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
r1, r2, w, r__, &info);
chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cporfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &c__1,
r1, r2, w, r__, &info);
chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cporfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &c__2,
r1, r2, w, r__, &info);
chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
cporfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &c__2,
r1, r2, w, r__, &info);
chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
cporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__1, x, &c__2,
r1, r2, w, r__, &info);
chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
cporfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, b, &c__2, x, &c__1,
r1, r2, w, r__, &info);
chkxer_("CPORFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPOCON */
s_copy(srnamc_1.srnamt, "CPOCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpocon_("/", &c__0, a, &c__1, &anrm, &rcond, w, r__, &info)
;
chkxer_("CPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpocon_("U", &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info)
;
chkxer_("CPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cpocon_("U", &c__2, a, &c__1, &anrm, &rcond, w, r__, &info)
;
chkxer_("CPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
r__1 = -anrm;
cpocon_("U", &c__1, a, &c__1, &r__1, &rcond, w, r__, &info)
;
chkxer_("CPOCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPOEQU */
s_copy(srnamc_1.srnamt, "CPOEQU", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpoequ_(&c_n1, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("CPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cpoequ_(&c__2, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("CPOEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Test error exits of the routines that use the Cholesky */
/* decomposition of a Hermitian positive definite packed matrix. */
} else if (lsamen_(&c__2, c2, "PP")) {
/* CPPTRF */
s_copy(srnamc_1.srnamt, "CPPTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpptrf_("/", &c__0, a, &info);
chkxer_("CPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpptrf_("U", &c_n1, a, &info);
chkxer_("CPPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPPTRI */
s_copy(srnamc_1.srnamt, "CPPTRI", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpptri_("/", &c__0, a, &info);
chkxer_("CPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpptri_("U", &c_n1, a, &info);
chkxer_("CPPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPPTRS */
s_copy(srnamc_1.srnamt, "CPPTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpptrs_("/", &c__0, &c__0, a, b, &c__1, &info);
chkxer_("CPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpptrs_("U", &c_n1, &c__0, a, b, &c__1, &info);
chkxer_("CPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cpptrs_("U", &c__0, &c_n1, a, b, &c__1, &info);
chkxer_("CPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
cpptrs_("U", &c__2, &c__1, a, b, &c__1, &info);
chkxer_("CPPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPPRFS */
s_copy(srnamc_1.srnamt, "CPPRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpprfs_("/", &c__0, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, r__,
&info);
chkxer_("CPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpprfs_("U", &c_n1, &c__0, a, af, b, &c__1, x, &c__1, r1, r2, w, r__,
&info);
chkxer_("CPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cpprfs_("U", &c__0, &c_n1, a, af, b, &c__1, x, &c__1, r1, r2, w, r__,
&info);
chkxer_("CPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
cpprfs_("U", &c__2, &c__1, a, af, b, &c__1, x, &c__2, r1, r2, w, r__,
&info);
chkxer_("CPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
cpprfs_("U", &c__2, &c__1, a, af, b, &c__2, x, &c__1, r1, r2, w, r__,
&info);
chkxer_("CPPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPPCON */
s_copy(srnamc_1.srnamt, "CPPCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cppcon_("/", &c__0, a, &anrm, &rcond, w, r__, &info);
chkxer_("CPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cppcon_("U", &c_n1, a, &anrm, &rcond, w, r__, &info);
chkxer_("CPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
r__1 = -anrm;
cppcon_("U", &c__1, a, &r__1, &rcond, w, r__, &info);
chkxer_("CPPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPPEQU */
s_copy(srnamc_1.srnamt, "CPPEQU", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cppequ_("/", &c__0, a, r1, &rcond, &anrm, &info);
chkxer_("CPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cppequ_("U", &c_n1, a, r1, &rcond, &anrm, &info);
chkxer_("CPPEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Test error exits of the routines that use the Cholesky */
/* decomposition of a Hermitian positive definite band matrix. */
} else if (lsamen_(&c__2, c2, "PB")) {
/* CPBTRF */
s_copy(srnamc_1.srnamt, "CPBTRF", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpbtrf_("/", &c__0, &c__0, a, &c__1, &info);
chkxer_("CPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpbtrf_("U", &c_n1, &c__0, a, &c__1, &info);
chkxer_("CPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cpbtrf_("U", &c__1, &c_n1, a, &c__1, &info);
chkxer_("CPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cpbtrf_("U", &c__2, &c__1, a, &c__1, &info);
chkxer_("CPBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPBTF2 */
s_copy(srnamc_1.srnamt, "CPBTF2", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpbtf2_("/", &c__0, &c__0, a, &c__1, &info);
chkxer_("CPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpbtf2_("U", &c_n1, &c__0, a, &c__1, &info);
chkxer_("CPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cpbtf2_("U", &c__1, &c_n1, a, &c__1, &info);
chkxer_("CPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cpbtf2_("U", &c__2, &c__1, a, &c__1, &info);
chkxer_("CPBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPBTRS */
s_copy(srnamc_1.srnamt, "CPBTRS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpbtrs_("/", &c__0, &c__0, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpbtrs_("U", &c_n1, &c__0, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cpbtrs_("U", &c__1, &c_n1, &c__0, a, &c__1, b, &c__1, &info);
chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cpbtrs_("U", &c__0, &c__0, &c_n1, a, &c__1, b, &c__1, &info);
chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
cpbtrs_("U", &c__2, &c__1, &c__1, a, &c__1, b, &c__1, &info);
chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
cpbtrs_("U", &c__2, &c__0, &c__1, a, &c__1, b, &c__1, &info);
chkxer_("CPBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPBRFS */
s_copy(srnamc_1.srnamt, "CPBRFS", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpbrfs_("/", &c__0, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, r__, &info);
chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpbrfs_("U", &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, r__, &info);
chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cpbrfs_("U", &c__1, &c_n1, &c__0, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, r__, &info);
chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
cpbrfs_("U", &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, b, &c__1, x, &
c__1, r1, r2, w, r__, &info);
chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
cpbrfs_("U", &c__2, &c__1, &c__1, a, &c__1, af, &c__2, b, &c__2, x, &
c__2, r1, r2, w, r__, &info);
chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
cpbrfs_("U", &c__2, &c__1, &c__1, a, &c__2, af, &c__1, b, &c__2, x, &
c__2, r1, r2, w, r__, &info);
chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
cpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__1, x, &
c__2, r1, r2, w, r__, &info);
chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
cpbrfs_("U", &c__2, &c__0, &c__1, a, &c__1, af, &c__1, b, &c__2, x, &
c__1, r1, r2, w, r__, &info);
chkxer_("CPBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPBCON */
s_copy(srnamc_1.srnamt, "CPBCON", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpbcon_("/", &c__0, &c__0, a, &c__1, &anrm, &rcond, w, r__, &info);
chkxer_("CPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpbcon_("U", &c_n1, &c__0, a, &c__1, &anrm, &rcond, w, r__, &info);
chkxer_("CPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cpbcon_("U", &c__1, &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info);
chkxer_("CPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cpbcon_("U", &c__2, &c__1, a, &c__1, &anrm, &rcond, w, r__, &info);
chkxer_("CPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
r__1 = -anrm;
cpbcon_("U", &c__1, &c__0, a, &c__1, &r__1, &rcond, w, r__, &info);
chkxer_("CPBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* CPBEQU */
s_copy(srnamc_1.srnamt, "CPBEQU", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
cpbequ_("/", &c__0, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("CPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
cpbequ_("U", &c_n1, &c__0, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("CPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
cpbequ_("U", &c__1, &c_n1, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("CPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
cpbequ_("U", &c__2, &c__1, a, &c__1, r1, &rcond, &anrm, &info);
chkxer_("CPBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of CERRPO */
} /* cerrpo_ */
