/* Subroutine */ int zdrvpo_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
doublecomplex *a, doublecomplex *afac, doublecomplex *asav,
doublecomplex *b, doublecomplex *bsav, doublecomplex *x,
doublecomplex *xact, doublereal *s, doublecomplex *work, doublereal *
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,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9997[] = "(1x,a6,\002, FACT='\002,a1,\002', UPLO='\002,a"
"1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,\002"
", test(\002,i1,\002) =\002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', UPLO='\002,a"
"1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
"=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
char ch__1[2];
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static char fact[1];
static integer ioff, mode;
static doublereal amax;
static char path[3];
static integer imat, info;
static char dist[1], uplo[1], type__[1];
static integer nrun, i__, k, n, ifact, nfail, iseed[4], nfact;
extern doublereal dget06_(doublereal *, doublereal *);
extern logical lsame_(char *, char *);
static char equed[1];
static integer nbmin;
static doublereal rcond, roldc, scond;
static integer nimat;
static doublereal anorm;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
);
static logical equil;
static integer iuplo, izero, nerrs, k1;
extern /* Subroutine */ int zpot01_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *), zpot02_(char *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *), zpot05_(char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *);
static logical zerot;
static char xtype[1];
extern /* Subroutine */ int zposv_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *), zlatb4_(char *, integer *, integer *, integer *, char *,
integer *, integer *, doublereal *, integer *, doublereal *,
char *), aladhd_(integer *, char *);
static integer nb, in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static logical prefac;
static integer ku, nt;
static doublereal rcondc;
static logical nofact;
static integer iequed;
extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
static doublereal cndnum;
extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
integer *), zlaqhe_(char *, integer *, doublecomplex *, integer *
, doublereal *, doublereal *, doublereal *, char *);
static doublereal ainvnm;
extern /* Subroutine */ int xlaenv_(integer *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *
, integer *), zlarhs_(char *, char *, char *, char *,
integer *, integer *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublecomplex *, integer *, doublecomplex *,
integer *);
static doublereal result[6];
extern /* Subroutine */ int zpoequ_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *, integer *), zpotrf_(
char *, integer *, doublecomplex *, integer *, integer *),
zpotri_(char *, integer *, doublecomplex *, integer *, integer *), zerrvx_(char *, integer *), zposvx_(char *,
char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, char *, doublereal *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
, doublereal *, doublecomplex *, doublereal *, integer *);
static integer lda;
/* 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 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZDRVPO tests the driver routines ZPOSV and -SVX.
Arguments
=========
DOTYPE (input) LOGICAL array, dimension (NTYPES)
The matrix types to be used for testing. Matrices of type j
(for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
.TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
NN (input) INTEGER
The number of values of N contained in the vector NVAL.
NVAL (input) INTEGER array, dimension (NN)
The values of the matrix dimension N.
NRHS (input) INTEGER
The number of right hand side vectors to be generated for
each linear system.
THRESH (input) DOUBLE PRECISION
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*16 array, dimension (NMAX*NMAX)
AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
ASAV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
S (workspace) DOUBLE PRECISION array, dimension (NMAX)
WORK (workspace) COMPLEX*16 array, dimension
(NMAX*max(3,NRHS))
RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--nval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Zomplex 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) {
zerrvx_(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 ZLATB4 and generate a test matrix
with ZLATMS. */
zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)6, (ftnlen)6);
zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &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., a[i__4].i = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0., a[i__4].i = 0.;
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., a[i__4].i = 0.;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L50: */
}
}
} else {
izero = 0;
}
/* Set the imaginary part of the diagonals. */
i__3 = lda + 1;
zlaipd_(&n, &a[1], &i__3, &c__0);
/* Save a copy of the matrix A in ASAV. */
zlacpy_(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) {
*(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.;
} else if (! lsame_(fact, "N"))
{
/* Compute the condition number for comparison with
the value returned by ZPOSVX (FACT = 'N' reuses
the condition number from the previous iteration
with FACT = 'F'). */
zlacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &
lda);
if (equil || iequed > 1) {
/* Compute row and column scale factors to
equilibrate the matrix A. */
zpoequ_(&n, &afac[1], &lda, &s[1], &scond, &
amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.;
}
/* Equilibrate the matrix. */
zlaqhe_(uplo, &n, &afac[1], &lda, &s[1], &
scond, &amax, equed);
}
}
/* Save the condition number of the
non-equilibrated system for use in ZGET04. */
if (equil) {
roldc = rcondc;
}
/* Compute the 1-norm of A. */
anorm = zlanhe_("1", uplo, &n, &afac[1], &lda, &
rwork[1]);
/* Factor the matrix A. */
zpotrf_(uplo, &n, &afac[1], &lda, &info);
/* Form the inverse of A. */
zlacpy_(uplo, &n, &n, &afac[1], &lda, &a[1], &lda);
zpotri_(uplo, &n, &a[1], &lda, &info);
/* Compute the 1-norm condition number of A. */
ainvnm = zlanhe_("1", uplo, &n, &a[1], &lda, &
rwork[1]);
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
}
/* Restore the matrix A. */
zlacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "ZLARHS", (ftnlen)6, (ftnlen)
6);
zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
*(unsigned char *)xtype = 'C';
zlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
if (nofact) {
/* --- Test ZPOSV ---
Compute the L*L' or U'*U factorization of the
matrix and solve the system. */
zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
zlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "ZPOSV ", (ftnlen)6, (
ftnlen)6);
zposv_(uplo, &n, nrhs, &afac[1], &lda, &x[1], &
lda, &info);
/* Check error code from ZPOSV . */
if (info != izero) {
alaerh_(path, "ZPOSV ", &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. */
zpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
rwork[1], result);
/* Compute residual of the computed solution. */
zlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
zpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda,
&work[1], &lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
zget04_(&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, "ZPOSV ", (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(doublereal));
e_wsfe();
++nfail;
}
/* L60: */
}
nrun += nt;
L70:
;
}
/* --- Test ZPOSVX --- */
if (! prefac) {
zlaset_(uplo, &n, &n, &c_b51, &c_b51, &afac[1], &
lda);
}
zlaset_("Full", &n, nrhs, &c_b51, &c_b51, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and
EQUED='Y'. */
zlaqhe_(uplo, &n, &a[1], &lda, &s[1], &scond, &
amax, equed);
}
/* Solve the system and compute the condition number
and error bounds using ZPOSVX. */
s_copy(srnamc_1.srnamt, "ZPOSVX", (ftnlen)6, (ftnlen)
6);
zposvx_(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 ZPOSVX. */
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, "ZPOSVX", &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. */
zpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
&rwork[(*nrhs << 1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
zlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
zpot02_(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")) {
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
zget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
/* Check the error bounds from iterative
refinement. */
zpot05_(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 ZPOSVX with the computed value
in RCONDC. */
result[5] = dget06_(&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, "ZPOSVX", (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(doublereal));
e_wsfe();
} else {
io___52.ciunit = *nout;
s_wsfe(&io___52);
do_fio(&c__1, "ZPOSVX", (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(doublereal));
e_wsfe();
}
++nfail;
}
/* L80: */
}
nrun = nrun + 7 - k1;
L90:
;
}
/* L100: */
}
L110:
;
}
L120:
;
}
/* L130: */
}
/* Print a summary of the results. */
alasvm_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZDRVPO */
} /* zdrvpo_ */
/* Subroutine */
int zposvx_(char *fact, char *uplo, integer *n, integer * nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer * ldaf, char *equed, doublereal *s, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer * info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
doublecomplex z__1;
/* Local variables */
integer i__, j;
doublereal amax, smin, smax;
extern logical lsame_(char *, char *);
doublereal scond, anorm;
logical equil, rcequ;
extern doublereal dlamch_(char *);
logical nofact;
extern /* Subroutine */
int xerbla_(char *, integer *);
doublereal bignum;
extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */
int zlaqhe_(char *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublereal *, char *);
integer infequ;
extern /* Subroutine */
int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zpocon_(char *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublecomplex *, doublereal *, integer *) ;
doublereal smlnum;
extern /* Subroutine */
int zpoequ_(integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublereal *, integer *), zporfs_( char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublecomplex *, doublereal *, integer *), zpotrf_(char *, integer *, doublecomplex *, integer *, integer *), zpotrs_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *);
/* -- LAPACK driver routine (version 3.4.1) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* April 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
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;
--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 = dlamch_("Safe minimum");
bignum = 1. / 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.;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
/* Computing MIN */
d__1 = smin;
d__2 = s[j]; // , expr subst
smin = min(d__1,d__2);
/* Computing MAX */
d__1 = smax;
d__2 = s[j]; // , expr subst
smax = max(d__1,d__2);
/* L10: */
}
if (smin <= 0.)
{
*info = -10;
}
else if (*n > 0)
{
scond = max(smin,smlnum) / min(smax,bignum);
}
else
{
scond = 1.;
}
}
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_("ZPOSVX", &i__1);
return 0;
}
if (equil)
{
/* Compute row and column scalings to equilibrate the matrix A. */
zpoequ_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
if (infequ == 0)
{
/* Equilibrate the matrix. */
zlaqhe_(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 = i__ + j * b_dim1;
i__4 = i__;
i__5 = i__ + j * b_dim1;
z__1.r = s[i__4] * b[i__5].r;
z__1.i = s[i__4] * b[i__5].i; // , expr subst
b[i__3].r = z__1.r;
b[i__3].i = z__1.i; // , expr subst
/* L20: */
}
/* L30: */
}
}
if (nofact || equil)
{
/* Compute the Cholesky factorization A = U**H *U or A = L*L**H. */
zlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
zpotrf_(uplo, n, &af[af_offset], ldaf, info);
/* Return if INFO is non-zero. */
if (*info > 0)
{
*rcond = 0.;
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = zlanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
/* Compute the reciprocal of the condition number of A. */
zpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1], info);
/* Compute the solution matrix X. */
zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
zpotrs_(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. */
zporfs_(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 = i__ + j * x_dim1;
i__4 = i__;
i__5 = i__ + j * x_dim1;
z__1.r = s[i__4] * x[i__5].r;
z__1.i = s[i__4] * x[i__5].i; // , expr subst
x[i__3].r = z__1.r;
x[i__3].i = z__1.i; // , expr subst
/* L40: */
}
/* L50: */
}
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
ferr[j] /= scond;
/* L60: */
}
}
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon"))
{
*info = *n + 1;
}
return 0;
/* End of ZPOSVX */
}
/* Subroutine */ int zdrvrf1_(integer *nout, integer *nn, integer *nval,
doublereal *thresh, doublecomplex *a, integer *lda, doublecomplex *
arf, doublereal *work)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char forms[1*2] = "N" "C";
static char norms[1*4] = "M" "1" "I" "F";
/* Format strings */
static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
"ing ZLANHF ***\002)";
static char fmt_9998[] = "(1x,\002 Error in \002,a6,\002 with UPLO="
"'\002,a1,\002', FORM='\002,a1,\002', N=\002,i5)";
static char fmt_9997[] = "(1x,\002 Failure in \002,a6,\002 N=\002,"
"i5,\002 TYPE=\002,i5,\002 UPLO='\002,a1,\002', FORM ='\002,a1"
",\002', NORM='\002,a1,\002', test=\002,g12.5)";
static char fmt_9996[] = "(1x,\002All tests for \002,a6,\002 auxiliary r"
"outine passed the \002,\002threshold (\002,i5,\002 tests run)"
"\002)";
static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
" of \002,i5,\002 tests failed to pass the threshold\002)";
static char fmt_9994[] = "(26x,i5,\002 error message recorded (\002,a6"
",\002)\002)";
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
do_fio(integer *, char *, ftnlen);
/* Local variables */
integer i__, j, n, iin, iit;
doublereal eps;
integer info;
char norm[1], uplo[1];
integer nrun, nfail;
doublereal large;
integer iseed[4];
char cform[1];
doublereal small;
integer iform;
doublereal norma;
integer inorm, iuplo, nerrs;
extern doublereal dlamch_(char *), zlanhe_(char *, char *,
integer *, doublecomplex *, integer *, doublereal *), zlanhf_(char *, char *, char *, integer *, doublecomplex
*, doublereal *);
extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
integer *);
doublereal result[1];
extern /* Subroutine */ int ztrttf_(char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
doublereal normarf;
/* Fortran I/O blocks */
static cilist io___22 = { 0, 0, 0, 0, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___30 = { 0, 0, 0, 0, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9994, 0 };
/* -- LAPACK test routine (version 3.2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZDRVRF1 tests the LAPACK RFP routines: */
/* ZLANHF.F */
/* Arguments */
/* ========= */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* 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. */
/* THRESH (input) DOUBLE PRECISION */
/* 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. */
/* A (workspace) COMPLEX*16 array, dimension (LDA,NMAX) */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,NMAX). */
/* ARF (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). */
/* WORK (workspace) DOUBLE PRECISION array, dimension ( NMAX ) */
/* ===================================================================== */
/* .. */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nval;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--arf;
--work;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
nrun = 0;
nfail = 0;
nerrs = 0;
info = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
eps = dlamch_("Precision");
small = dlamch_("Safe minimum");
large = 1. / small;
small = small * *lda * *lda;
large = large / *lda / *lda;
i__1 = *nn;
for (iin = 1; iin <= i__1; ++iin) {
n = nval[iin];
for (iit = 1; iit <= 3; ++iit) {
/* IIT = 1 : random matrix */
/* IIT = 2 : random matrix scaled near underflow */
/* IIT = 3 : random matrix scaled near overflow */
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
zlarnd_(&z__1, &c__4, iseed);
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
}
}
if (iit == 2) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
i__5 = i__ + j * a_dim1;
z__1.r = large * a[i__5].r, z__1.i = large * a[i__5]
.i;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
}
}
}
if (iit == 3) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
i__5 = i__ + j * a_dim1;
z__1.r = small * a[i__5].r, z__1.i = small * a[i__5]
.i;
a[i__4].r = z__1.r, a[i__4].i = z__1.i;
}
}
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Do first for CFORM = 'N', then for CFORM = 'C' */
for (iform = 1; iform <= 2; ++iform) {
*(unsigned char *)cform = *(unsigned char *)&forms[iform
- 1];
s_copy(srnamc_1.srnamt, "ZTRTTF", (ftnlen)32, (ftnlen)6);
ztrttf_(cform, uplo, &n, &a[a_offset], lda, &arf[1], &
info);
/* Check error code from ZTRTTF */
if (info != 0) {
if (nfail == 0 && nerrs == 0) {
io___22.ciunit = *nout;
s_wsle(&io___22);
e_wsle();
io___23.ciunit = *nout;
s_wsfe(&io___23);
e_wsfe();
}
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, srnamc_1.srnamt, (ftnlen)32);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, cform, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
e_wsfe();
++nerrs;
goto L100;
}
for (inorm = 1; inorm <= 4; ++inorm) {
/* Check all four norms: 'M', '1', 'I', 'F' */
*(unsigned char *)norm = *(unsigned char *)&norms[
inorm - 1];
normarf = zlanhf_(norm, cform, uplo, &n, &arf[1], &
work[1]);
norma = zlanhe_(norm, uplo, &n, &a[a_offset], lda, &
work[1]);
result[0] = (norma - normarf) / norma / eps;
++nrun;
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
io___30.ciunit = *nout;
s_wsle(&io___30);
e_wsle();
io___31.ciunit = *nout;
s_wsfe(&io___31);
e_wsfe();
}
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, "ZLANHF", (ftnlen)6);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iit, (ftnlen)sizeof(
integer));
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, cform, (ftnlen)1);
do_fio(&c__1, norm, (ftnlen)1);
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L90: */
}
L100:
;
}
/* L110: */
}
/* L120: */
}
/* L130: */
}
/* Print a summary of the results. */
if (nfail == 0) {
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, "ZLANHF", (ftnlen)6);
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, "ZLANHF", (ftnlen)6);
do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
e_wsfe();
}
if (nerrs != 0) {
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
do_fio(&c__1, "ZLANHF", (ftnlen)6);
e_wsfe();
}
return 0;
/* End of ZDRVRF1 */
} /* zdrvrf1_ */
/* Subroutine */ int zgrqts_(integer *m, integer *p, integer *n,
doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
r__, integer *lda, doublecomplex *taua, doublecomplex *b,
doublecomplex *bf, doublecomplex *z__, doublecomplex *t,
doublecomplex *bwk, integer *ldb, doublecomplex *taub, doublecomplex *
work, integer *lwork, doublereal *rwork, doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
bf_offset, bwk_dim1, bwk_offset, q_dim1, q_offset, r_dim1,
r_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1;
doublecomplex z__1;
/* Local variables */
static integer info;
static doublereal unfl, resid, anorm, bnorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *),
zlanhe_(char *, char *, integer *, doublecomplex *, integer *,
doublereal *);
extern /* Subroutine */ int zggrqf_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *)
, zlacpy_(char *, integer *, integer *, doublecomplex *, integer *
, doublecomplex *, integer *), zlaset_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *), zungqr_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *), zungrq_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
static doublereal ulp;
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define r___subscr(a_1,a_2) (a_2)*r_dim1 + a_1
#define r___ref(a_1,a_2) r__[r___subscr(a_1,a_2)]
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
#define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)]
#define bf_subscr(a_1,a_2) (a_2)*bf_dim1 + a_1
#define bf_ref(a_1,a_2) bf[bf_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZGRQTS tests ZGGRQF, which computes the GRQ factorization of an
M-by-N matrix A and a P-by-N matrix B: A = R*Q and B = Z*T*Q.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A. M >= 0.
P (input) INTEGER
The number of rows of the matrix B. P >= 0.
N (input) INTEGER
The number of columns of the matrices A and B. N >= 0.
A (input) COMPLEX*16 array, dimension (LDA,N)
The M-by-N matrix A.
AF (output) COMPLEX*16 array, dimension (LDA,N)
Details of the GRQ factorization of A and B, as returned
by ZGGRQF, see CGGRQF for further details.
Q (output) COMPLEX*16 array, dimension (LDA,N)
The N-by-N unitary matrix Q.
R (workspace) COMPLEX*16 array, dimension (LDA,MAX(M,N))
LDA (input) INTEGER
The leading dimension of the arrays A, AF, R and Q.
LDA >= max(M,N).
TAUA (output) COMPLEX*16 array, dimension (min(M,N))
The scalar factors of the elementary reflectors, as returned
by DGGQRC.
B (input) COMPLEX*16 array, dimension (LDB,N)
On entry, the P-by-N matrix A.
BF (output) COMPLEX*16 array, dimension (LDB,N)
Details of the GQR factorization of A and B, as returned
by ZGGRQF, see CGGRQF for further details.
Z (output) DOUBLE PRECISION array, dimension (LDB,P)
The P-by-P unitary matrix Z.
T (workspace) COMPLEX*16 array, dimension (LDB,max(P,N))
BWK (workspace) COMPLEX*16 array, dimension (LDB,N)
LDB (input) INTEGER
The leading dimension of the arrays B, BF, Z and T.
LDB >= max(P,N).
TAUB (output) COMPLEX*16 array, dimension (min(P,N))
The scalar factors of the elementary reflectors, as returned
by DGGRQF.
WORK (workspace) COMPLEX*16 array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK, LWORK >= max(M,P,N)**2.
RWORK (workspace) DOUBLE PRECISION array, dimension (M)
RESULT (output) DOUBLE PRECISION array, dimension (4)
The test ratios:
RESULT(1) = norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP)
RESULT(2) = norm( T*Q - Z'*B ) / (MAX(P,N)*norm(B)*ULP)
RESULT(3) = norm( I - Q'*Q ) / ( N*ULP )
RESULT(4) = norm( I - Z'*Z ) / ( P*ULP )
=====================================================================
Parameter adjustments */
r_dim1 = *lda;
r_offset = 1 + r_dim1 * 1;
r__ -= r_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--taua;
bwk_dim1 = *ldb;
bwk_offset = 1 + bwk_dim1 * 1;
bwk -= bwk_offset;
t_dim1 = *ldb;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
z_dim1 = *ldb;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
bf_dim1 = *ldb;
bf_offset = 1 + bf_dim1 * 1;
bf -= bf_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--taub;
--work;
--rwork;
--result;
/* Function Body */
ulp = dlamch_("Precision");
unfl = dlamch_("Safe minimum");
/* Copy the matrix A to the array AF. */
zlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
zlacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
/* Computing MAX */
d__1 = zlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
anorm = max(d__1,unfl);
/* Computing MAX */
d__1 = zlange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
bnorm = max(d__1,unfl);
/* Factorize the matrices A and B in the arrays AF and BF. */
zggrqf_(m, p, n, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, &
taub[1], &work[1], lwork, &info);
/* Generate the N-by-N matrix Q */
zlaset_("Full", n, n, &c_b3, &c_b3, &q[q_offset], lda);
if (*m <= *n) {
if (*m > 0 && *m < *n) {
i__1 = *n - *m;
zlacpy_("Full", m, &i__1, &af[af_offset], lda, &q_ref(*n - *m + 1,
1), lda);
}
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
zlacpy_("Lower", &i__1, &i__2, &af_ref(2, *n - *m + 1), lda, &
q_ref(*n - *m + 2, *n - *m + 1), lda);
}
} else {
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
zlacpy_("Lower", &i__1, &i__2, &af_ref(*m - *n + 2, 1), lda, &
q_ref(2, 1), lda);
}
}
i__1 = min(*m,*n);
zungrq_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
/* Generate the P-by-P matrix Z */
zlaset_("Full", p, p, &c_b3, &c_b3, &z__[z_offset], ldb);
if (*p > 1) {
i__1 = *p - 1;
zlacpy_("Lower", &i__1, n, &bf_ref(2, 1), ldb, &z___ref(2, 1), ldb);
}
i__1 = min(*p,*n);
zungqr_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
info);
/* Copy R */
zlaset_("Full", m, n, &c_b1, &c_b1, &r__[r_offset], lda);
if (*m <= *n) {
zlacpy_("Upper", m, m, &af_ref(1, *n - *m + 1), lda, &r___ref(1, *n -
*m + 1), lda);
} else {
i__1 = *m - *n;
zlacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset], lda);
zlacpy_("Upper", n, n, &af_ref(*m - *n + 1, 1), lda, &r___ref(*m - *n
+ 1, 1), lda);
}
/* Copy T */
zlaset_("Full", p, n, &c_b1, &c_b1, &t[t_offset], ldb);
zlacpy_("Upper", p, n, &bf[bf_offset], ldb, &t[t_offset], ldb);
/* Compute R - A*Q' */
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "Conjugate transpose", m, n, n, &z__1, &a[a_offset]
, lda, &q[q_offset], lda, &c_b2, &r__[r_offset], lda);
/* Compute norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP ) . */
resid = zlange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
if (anorm > 0.) {
/* Computing MAX */
i__1 = max(1,*m);
result[1] = resid / (doublereal) max(i__1,*n) / anorm / ulp;
} else {
result[1] = 0.;
}
/* Compute T*Q - Z'*B */
zgemm_("Conjugate transpose", "No transpose", p, n, p, &c_b2, &z__[
z_offset], ldb, &b[b_offset], ldb, &c_b1, &bwk[bwk_offset], ldb);
z__1.r = -1., z__1.i = 0.;
zgemm_("No transpose", "No transpose", p, n, n, &c_b2, &t[t_offset], ldb,
&q[q_offset], lda, &z__1, &bwk[bwk_offset], ldb);
/* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
resid = zlange_("1", p, n, &bwk[bwk_offset], ldb, &rwork[1]);
if (bnorm > 0.) {
/* Computing MAX */
i__1 = max(1,*p);
result[2] = resid / (doublereal) max(i__1,*m) / bnorm / ulp;
} else {
result[2] = 0.;
}
/* Compute I - Q*Q' */
zlaset_("Full", n, n, &c_b1, &c_b2, &r__[r_offset], lda);
zherk_("Upper", "No Transpose", n, n, &c_b34, &q[q_offset], lda, &c_b35, &
r__[r_offset], lda);
/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
resid = zlanhe_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
result[3] = resid / (doublereal) max(1,*n) / ulp;
/* Compute I - Z'*Z */
zlaset_("Full", p, p, &c_b1, &c_b2, &t[t_offset], ldb);
zherk_("Upper", "Conjugate transpose", p, p, &c_b34, &z__[z_offset], ldb,
&c_b35, &t[t_offset], ldb);
/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
resid = zlanhe_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
result[4] = resid / (doublereal) max(1,*p) / ulp;
return 0;
/* End of ZGRQTS */
} /* zgrqts_ */
/* Subroutine */ int zposvx_(char *fact, char *uplo, integer *n, integer *
nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
ldaf, char *equed, doublereal *s, doublecomplex *b, integer *ldb,
doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr,
doublereal *berr, doublecomplex *work, doublereal *rwork, integer *
info, ftnlen fact_len, ftnlen uplo_len, ftnlen equed_len)
{
/* 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;
doublereal d__1, d__2;
doublecomplex z__1;
/* Local variables */
static integer i__, j;
static doublereal amax, smin, smax;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static doublereal scond, anorm;
static logical equil, rcequ;
extern doublereal dlamch_(char *, ftnlen);
static logical nofact;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
static doublereal bignum;
extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *, ftnlen, ftnlen);
extern /* Subroutine */ int zlaqhe_(char *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublereal *, char *,
ftnlen, ftnlen);
static integer infequ;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen),
zpocon_(char *, integer *, doublecomplex *, integer *, doublereal
*, doublereal *, doublecomplex *, doublereal *, integer *, ftnlen)
;
static doublereal smlnum;
extern /* Subroutine */ int zpoequ_(integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *, integer *), zporfs_(
char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublereal *, doublereal *,
doublecomplex *, doublereal *, integer *, ftnlen), zpotrf_(char *,
integer *, doublecomplex *, integer *, integer *, ftnlen),
zpotrs_(char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, ftnlen);
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPOSVX 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*16 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*16 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) DOUBLE PRECISION 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*16 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*16 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) DOUBLE PRECISION */
/* 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
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;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N", (ftnlen)1, (ftnlen)1);
equil = lsame_(fact, "E", (ftnlen)1, (ftnlen)1);
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rcequ = FALSE_;
} else {
rcequ = lsame_(equed, "Y", (ftnlen)1, (ftnlen)1);
smlnum = dlamch_("Safe minimum", (ftnlen)12);
bignum = 1. / smlnum;
}
/* Test the input parameters. */
if (! nofact && ! equil && ! lsame_(fact, "F", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo,
"L", (ftnlen)1, (ftnlen)1)) {
*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", (ftnlen)1, (ftnlen)1) && ! (rcequ || lsame_(
equed, "N", (ftnlen)1, (ftnlen)1))) {
*info = -9;
} else {
if (rcequ) {
smin = bignum;
smax = 0.;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
d__1 = smin, d__2 = s[j];
smin = min(d__1,d__2);
/* Computing MAX */
d__1 = smax, d__2 = s[j];
smax = max(d__1,d__2);
/* L10: */
}
if (smin <= 0.) {
*info = -10;
} else if (*n > 0) {
scond = max(smin,smlnum) / min(smax,bignum);
} else {
scond = 1.;
}
}
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_("ZPOSVX", &i__1, (ftnlen)6);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
zpoequ_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
zlaqhe_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed, (
ftnlen)1, (ftnlen)1);
rcequ = lsame_(equed, "Y", (ftnlen)1, (ftnlen)1);
}
}
/* Scale the right hand side. */
if (rcequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
i__4 = i__;
i__5 = i__ + j * b_dim1;
z__1.r = s[i__4] * b[i__5].r, z__1.i = s[i__4] * b[i__5].i;
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/* L20: */
}
/* L30: */
}
}
if (nofact || equil) {
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
zlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf, (ftnlen)
1);
zpotrf_(uplo, n, &af[af_offset], ldaf, info, (ftnlen)1);
/* Return if INFO is non-zero. */
if (*info != 0) {
if (*info > 0) {
*rcond = 0.;
}
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = zlanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1], (ftnlen)1, (
ftnlen)1);
/* Compute the reciprocal of the condition number of A. */
zpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1],
info, (ftnlen)1);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon", (ftnlen)7)) {
*info = *n + 1;
}
/* Compute the solution matrix X. */
zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx, (ftnlen)4);
zpotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info, (
ftnlen)1);
/* Use iterative refinement to improve the computed solution and */
/* compute error bounds and backward error estimates for it. */
zporfs_(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, (ftnlen)1);
/* Transform the solution matrix X to a solution of the original */
/* system. */
if (rcequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * x_dim1;
i__4 = i__;
i__5 = i__ + j * x_dim1;
z__1.r = s[i__4] * x[i__5].r, z__1.i = s[i__4] * x[i__5].i;
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
/* L40: */
}
/* L50: */
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= scond;
/* L60: */
}
}
return 0;
/* End of ZPOSVX */
} /* zposvx_ */
/* Subroutine */ int zherfsx_(char *uplo, char *equed, integer *n, integer *
nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
ldaf, integer *ipiv, doublereal *s, doublecomplex *b, integer *ldb,
doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *berr,
integer *n_err_bnds__, doublereal *err_bnds_norm__, doublereal *
err_bnds_comp__, integer *nparams, doublereal *params, doublecomplex *
work, doublereal *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;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal illrcond_thresh__, unstable_thresh__, err_lbnd__;
integer ref_type__;
integer j;
doublereal rcond_tmp__;
integer prec_type__;
doublereal cwise_wrong__;
extern /* Subroutine */ int zla_herfsx_extended__(integer *, char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *, integer *, logical *, doublereal *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublecomplex *, doublereal *,
doublecomplex *, doublecomplex *, doublereal *, integer *,
doublereal *, doublereal *, logical *, integer *, ftnlen);
char norm[1];
logical ignore_cwise__;
extern logical lsame_(char *, char *);
doublereal anorm;
logical rcequ;
extern doublereal zla_hercond_c__(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, doublereal *,
logical *, integer *, doublecomplex *, doublereal *, ftnlen),
zla_hercond_x__(char *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublereal *, ftnlen), dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zhecon_(char *, integer *, doublecomplex *,
integer *, integer *, doublereal *, doublereal *, doublecomplex *,
integer *);
extern integer ilaprec_(char *);
integer ithresh, n_norms__;
doublereal rthresh;
/* -- LAPACK routine (version 3.2.1) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- April 2009 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* Purpose */
/* ======= */
/* ZHERFSX improves the computed solution to a system of linear */
/* equations when the coefficient matrix is Hermitian indefinite, and */
/* provides error bounds and backward error estimates for the */
/* solution. In addition to normwise error bound, the code provides */
/* maximum componentwise error bound if possible. See comments for */
/* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds. */
/* The original system of linear equations may have been equilibrated */
/* before calling this routine, as described by arguments EQUED and S */
/* below. In this case, the solution and error bounds returned are */
/* for the original unequilibrated system. */
/* Arguments */
/* ========= */
/* Some optional parameters are bundled in the PARAMS array. These */
/* settings determine how refinement is performed, but often the */
/* defaults are acceptable. If the defaults are acceptable, users */
/* can pass NPARAMS = 0 which prevents the source code from accessing */
/* the PARAMS argument. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* EQUED (input) CHARACTER*1 */
/* Specifies the form of equilibration that was done to A */
/* before calling this routine. This is needed to compute */
/* the solution and error bounds correctly. */
/* = 'N': No equilibration */
/* = 'Y': Both row and column equilibration, i.e., A has been */
/* replaced by diag(S) * A * diag(S). */
/* The right hand side B has been changed accordingly. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
/* upper triangular part of A contains the upper triangular */
/* part of the matrix A, and the strictly lower triangular */
/* part of A is not referenced. If UPLO = 'L', the leading */
/* N-by-N lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input) COMPLEX*16 array, dimension (LDAF,N) */
/* The factored form of the matrix A. AF contains the block */
/* diagonal matrix D and the multipliers used to obtain the */
/* factor U or L from the factorization A = U*D*U**T or A = */
/* L*D*L**T as computed by DSYTRF. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by DSYTRF. */
/* S (input or output) DOUBLE PRECISION array, dimension (N) */
/* The scale factors for A. If EQUED = 'Y', A is multiplied on */
/* the left and right by diag(S). S is an input argument if FACT = */
/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
/* = 'Y', each element of S must be positive. If S is output, each */
/* element of S is a power of the radix. If S is input, each element */
/* of S should be a power of the radix to ensure a reliable solution */
/* and error estimates. Scaling by powers of the radix does not cause */
/* rounding errors unless the result underflows or overflows. */
/* Rounding errors during scaling lead to refining with a matrix that */
/* is not equivalent to the input matrix, producing error estimates */
/* that may not be reliable. */
/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
/* The right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by DGETRS. */
/* On exit, the improved solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) DOUBLE PRECISION */
/* Reciprocal scaled condition number. This is an estimate of the */
/* reciprocal Skeel condition number of the matrix A after */
/* equilibration (if done). If this is less than the machine */
/* precision (in particular, if it is zero), the matrix is singular */
/* to working precision. Note that the error may still be small even */
/* if this number is very small and the matrix appears ill- */
/* conditioned. */
/* BERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) * dlamch('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) * dlamch('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) * dlamch('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) DOUBLE PRECISION 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) * dlamch('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) * dlamch('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) * dlamch('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) DOUBLE PRECISION 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.0D+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*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION 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 Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Check the input parameters. */
/* Parameter adjustments */
err_bnds_comp_dim1 = *nrhs;
err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
err_bnds_comp__ -= err_bnds_comp_offset;
err_bnds_norm_dim1 = *nrhs;
err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
err_bnds_norm__ -= err_bnds_norm_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
--s;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--berr;
--params;
--work;
--rwork;
/* Function Body */
*info = 0;
ref_type__ = 1;
if (*nparams >= 1) {
if (params[1] < 0.) {
params[1] = 1.;
} else {
ref_type__ = (integer) params[1];
}
}
/* Set default parameters. */
illrcond_thresh__ = (doublereal) (*n) * dlamch_("Epsilon");
ithresh = 10;
rthresh = .5;
unstable_thresh__ = .25;
ignore_cwise__ = FALSE_;
if (*nparams >= 2) {
if (params[2] < 0.) {
params[2] = (doublereal) ithresh;
} else {
ithresh = (integer) params[2];
}
}
if (*nparams >= 3) {
if (params[3] < 0.) {
if (ignore_cwise__) {
params[3] = 0.;
} else {
params[3] = 1.;
}
} else {
ignore_cwise__ = params[3] == 0.;
}
}
if (ref_type__ == 0 || *n_err_bnds__ == 0) {
n_norms__ = 0;
} else if (ignore_cwise__) {
n_norms__ = 1;
} else {
n_norms__ = 2;
}
rcequ = lsame_(equed, "Y");
/* Test input parameters. */
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! rcequ && ! lsame_(equed, "N")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (*ldb < max(1,*n)) {
*info = -11;
} else if (*ldx < max(1,*n)) {
*info = -13;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHERFSX", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || *nrhs == 0) {
*rcond = 1.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
berr[j] = 0.;
if (*n_err_bnds__ >= 1) {
err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
} else if (*n_err_bnds__ >= 2) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.;
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.;
} else if (*n_err_bnds__ >= 3) {
err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.;
err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.;
}
}
return 0;
}
/* Default to failure. */
*rcond = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
berr[j] = 1.;
if (*n_err_bnds__ >= 1) {
err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
} else if (*n_err_bnds__ >= 2) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
} else if (*n_err_bnds__ >= 3) {
err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.;
err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.;
}
}
/* Compute the norm of A and the reciprocal of the condition */
/* number of A. */
*(unsigned char *)norm = 'I';
anorm = zlanhe_(norm, uplo, n, &a[a_offset], lda, &rwork[1]);
zhecon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
info);
/* Perform refinement on each right-hand side */
if (ref_type__ != 0) {
prec_type__ = ilaprec_("E");
zla_herfsx_extended__(&prec_type__, uplo, n, nrhs, &a[a_offset], lda,
&af[af_offset], ldaf, &ipiv[1], &rcequ, &s[1], &b[b_offset],
ldb, &x[x_offset], ldx, &berr[1], &n_norms__, &
err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[
err_bnds_comp_offset], &work[1], &rwork[1], &work[*n + 1],
(doublecomplex *)(&rwork[1]), rcond, &ithresh, &rthresh, &unstable_thresh__, &
ignore_cwise__, info, (ftnlen)1);
}
/* Computing MAX */
d__1 = 10., d__2 = sqrt((doublereal) (*n));
err_lbnd__ = max(d__1,d__2) * dlamch_("Epsilon");
if (*n_err_bnds__ >= 1 && n_norms__ >= 1) {
/* Compute scaled normwise condition number cond(A*C). */
if (rcequ) {
rcond_tmp__ = zla_hercond_c__(uplo, n, &a[a_offset], lda, &af[
af_offset], ldaf, &ipiv[1], &s[1], &c_true, info, &work[1]
, &rwork[1], (ftnlen)1);
} else {
rcond_tmp__ = zla_hercond_c__(uplo, n, &a[a_offset], lda, &af[
af_offset], ldaf, &ipiv[1], &s[1], &c_false, info, &work[
1], &rwork[1], (ftnlen)1);
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Cap the error at 1.0. */
if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1
<< 1)] > 1.) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
}
/* Threshold the error (see LAWN). */
if (rcond_tmp__ < illrcond_thresh__) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
err_bnds_norm__[j + err_bnds_norm_dim1] = 0.;
if (*info <= *n) {
*info = *n + j;
}
} else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] <
err_lbnd__) {
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
}
/* Save the condition number. */
if (*n_err_bnds__ >= 3) {
err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
}
}
}
if (*n_err_bnds__ >= 1 && n_norms__ >= 2) {
/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
/* each right-hand side using the current solution as an estimate of */
/* the true solution. If the componentwise error estimate is too */
/* large, then the solution is a lousy estimate of truth and the */
/* estimated RCOND may be too optimistic. To avoid misleading users, */
/* the inverse condition number is set to 0.0 when the estimated */
/* cwise error is at least CWISE_WRONG. */
cwise_wrong__ = sqrt(dlamch_("Epsilon"));
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
cwise_wrong__) {
rcond_tmp__ = zla_hercond_x__(uplo, n, &a[a_offset], lda, &af[
af_offset], ldaf, &ipiv[1], &x[j * x_dim1 + 1], info,
&work[1], &rwork[1], (ftnlen)1);
} else {
rcond_tmp__ = 0.;
}
/* Cap the error at 1.0. */
if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1
<< 1)] > 1.) {
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
}
/* Threshold the error (see LAWN). */
if (rcond_tmp__ < illrcond_thresh__) {
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
err_bnds_comp__[j + err_bnds_comp_dim1] = 0.;
if (params[3] == 1. && *info < *n + j) {
*info = *n + j;
}
} else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] <
err_lbnd__) {
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
}
/* Save the condition number. */
if (*n_err_bnds__ >= 3) {
err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
}
}
}
return 0;
/* End of ZHERFSX */
} /* zherfsx_ */
int zheevd_(char *jobz, char *uplo, int *n,
doublecomplex *a, int *lda, double *w, doublecomplex *work,
int *lwork, double *rwork, int *lrwork, int *iwork,
int *liwork, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2;
double d__1;
/* Builtin functions */
double sqrt(double);
/* Local variables */
double eps;
int inde;
double anrm;
int imax;
double rmin, rmax;
int lopt;
extern int dscal_(int *, double *, double *,
int *);
double sigma;
extern int lsame_(char *, char *);
int iinfo, lwmin, liopt;
int lower;
int llrwk, lropt;
int wantz;
int indwk2, llwrk2;
extern double dlamch_(char *);
int iscale;
double safmin;
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
extern int xerbla_(char *, int *);
double bignum;
extern double zlanhe_(char *, char *, int *, doublecomplex *,
int *, double *);
int indtau;
extern int dsterf_(int *, double *, double *,
int *), zlascl_(char *, int *, int *, double *,
double *, int *, int *, doublecomplex *, int *,
int *), zstedc_(char *, int *, double *,
double *, doublecomplex *, int *, doublecomplex *,
int *, double *, int *, int *, int *, int
*);
int indrwk, indwrk, liwmin;
extern int zhetrd_(char *, int *, doublecomplex *,
int *, double *, double *, doublecomplex *,
doublecomplex *, int *, int *), zlacpy_(char *,
int *, int *, doublecomplex *, int *, doublecomplex *,
int *);
int lrwmin, llwork;
double smlnum;
int lquery;
extern int zunmtr_(char *, char *, char *, int *,
int *, doublecomplex *, int *, doublecomplex *,
doublecomplex *, int *, doublecomplex *, int *, int *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a */
/* complex Hermitian matrix A. If eigenvectors are desired, it uses a */
/* divide and conquer algorithm. */
/* The divide and conquer algorithm makes very mild assumptions about */
/* floating point arithmetic. It will work on machines with a guard */
/* digit in add/subtract, or on those binary machines without guard */
/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 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 */
/* orthonormal eigenvectors of the matrix A. */
/* If JOBZ = 'N', then 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). */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* WORK (workspace/output) COMPLEX*16 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 must be at least 1. */
/* If JOBZ = 'N' and N > 1, LWORK must be at least N + 1. */
/* If JOBZ = 'V' and N > 1, LWORK must be at least 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) DOUBLE PRECISION 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 must be at least 1. */
/* If JOBZ = 'N' and N > 1, LRWORK must be at least N. */
/* If JOBZ = 'V' and N > 1, LRWORK must be at least */
/* 1 + 5*N + 2*N**2. */
/* If LRWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the 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 must be at least 1. */
/* If JOBZ = 'N' and N > 1, LIWORK must be at least 1. */
/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the 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: 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). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Jeff Rutter, Computer Science Division, University of California */
/* at Berkeley, USA */
/* Modified description of INFO. 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;
--w;
--work;
--rwork;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
lower = lsame_(uplo, "L");
lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < MAX(1,*n)) {
*info = -5;
}
if (*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;
/* Computing 2nd power */
i__1 = *n;
lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
liwmin = *n * 5 + 3;
} else {
lwmin = *n + 1;
lrwmin = *n;
liwmin = 1;
}
/* Computing MAX */
i__1 = lwmin, i__2 = *n + ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1,
&c_n1, &c_n1);
lopt = MAX(i__1,i__2);
lropt = lrwmin;
liopt = liwmin;
}
work[1].r = (double) lopt, work[1].i = 0.;
rwork[1] = (double) lropt;
iwork[1] = liopt;
if (*lwork < lwmin && ! lquery) {
*info = -8;
} else if (*lrwork < lrwmin && ! lquery) {
*info = -10;
} else if (*liwork < liwmin && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHEEVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
i__1 = a_dim1 + 1;
w[1] = a[i__1].r;
if (wantz) {
i__1 = a_dim1 + 1;
a[i__1].r = 1., a[i__1].i = 0.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = zlanhe_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
iscale = 0;
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
zlascl_(uplo, &c__0, &c__0, &c_b18, &sigma, n, n, &a[a_offset], lda,
info);
}
/* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */
inde = 1;
indtau = 1;
indwrk = indtau + *n;
indrwk = inde + *n;
indwk2 = indwrk + *n * *n;
llwork = *lwork - indwrk + 1;
llwrk2 = *lwork - indwk2 + 1;
llrwk = *lrwork - indrwk + 1;
zhetrd_(uplo, n, &a[a_offset], lda, &w[1], &rwork[inde], &work[indtau], &
work[indwrk], &llwork, &iinfo);
/* For eigenvalues only, call DSTERF. For eigenvectors, first call */
/* ZSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */
/* tridiagonal matrix, then call ZUNMTR to multiply it to the */
/* Householder transformations represented as Householder vectors in */
/* A. */
if (! wantz) {
dsterf_(n, &w[1], &rwork[inde], info);
} else {
zstedc_("I", n, &w[1], &rwork[inde], &work[indwrk], n, &work[indwk2],
&llwrk2, &rwork[indrwk], &llrwk, &iwork[1], liwork, info);
zunmtr_("L", uplo, "N", n, n, &a[a_offset], lda, &work[indtau], &work[
indwrk], n, &work[indwk2], &llwrk2, &iinfo);
zlacpy_("A", n, n, &work[indwrk], n, &a[a_offset], lda);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &w[1], &c__1);
}
work[1].r = (double) lopt, work[1].i = 0.;
rwork[1] = (double) lropt;
iwork[1] = liopt;
return 0;
/* End of ZHEEVD */
} /* zheevd_ */
/* Subroutine */ int zheevd_(char *jobz, char *uplo, integer *n,
doublecomplex *a, integer *lda, doublereal *w, doublecomplex *work,
integer *lwork, doublereal *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
=======
ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a
complex Hermitian matrix A. If eigenvectors are desired, it uses a
divide and conquer algorithm.
The divide and conquer algorithm makes very mild assumptions about
floating point arithmetic. It will work on machines with a guard
digit in add/subtract, or on those binary machines without guard
digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
Cray-2. It could conceivably fail on hexadecimal or decimal machines
without guard digits, but we know of none.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX*16 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
orthonormal eigenvectors of the matrix A.
If JOBZ = 'N', then 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).
W (output) DOUBLE PRECISION array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
WORK (workspace/output) COMPLEX*16 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 must be at least 1.
If JOBZ = 'N' and N > 1, LWORK must be at least N + 1.
If JOBZ = 'V' and N > 1, LWORK must be at least 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) DOUBLE PRECISION 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 must be at least 1.
If JOBZ = 'N' and N > 1, LRWORK must be at least N.
If JOBZ = 'V' and N > 1, LRWORK must be at least
1 + 5*N + 2*N**2.
If LRWORK = -1, then a workspace query is assumed; the
routine only calculates the 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 must be at least 1.
If JOBZ = 'N' and N > 1, LIWORK must be at least 1.
If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
If LIWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal size of the IWORK array,
returns this value as the first entry of the IWORK array, and
no error message related to LIWORK is issued by XERBLA.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the algorithm failed to converge; i
off-diagonal elements of an intermediate tridiagonal
form did not converge to zero.
Further Details
===============
Based on contributions by
Jeff Rutter, Computer Science Division, University of California
at Berkeley, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__0 = 0;
static doublereal c_b13 = 1.;
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer inde;
static doublereal anrm;
static integer imax;
static doublereal rmin, rmax;
static integer lopt;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *);
static integer iinfo, lwmin, liopt;
static logical lower;
static integer llrwk, lropt;
static logical wantz;
static integer indwk2, llwrk2;
extern doublereal dlamch_(char *);
static integer iscale;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal bignum;
extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
static integer indtau;
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), zlascl_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, integer *, doublecomplex *, integer *,
integer *), zstedc_(char *, integer *, doublereal *,
doublereal *, doublecomplex *, integer *, doublecomplex *,
integer *, doublereal *, integer *, integer *, integer *, integer
*);
static integer indrwk, indwrk, liwmin;
extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublecomplex *,
doublecomplex *, integer *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
static integer lrwmin, llwork;
static doublereal smlnum;
static logical lquery;
extern /* Subroutine */ int zunmtr_(char *, char *, char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
static doublereal eps;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--w;
--work;
--rwork;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
lower = lsame_(uplo, "L");
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;
/* Computing 2nd power */
i__1 = *n;
lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
liwmin = *n * 5 + 3;
} else {
lwmin = *n + 1;
lrwmin = *n;
liwmin = 1;
}
lopt = lwmin;
lropt = lrwmin;
liopt = liwmin;
}
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*lwork < lwmin && ! lquery) {
*info = -8;
} else if (*lrwork < lrwmin && ! lquery) {
*info = -10;
} else if (*liwork < liwmin && ! lquery) {
*info = -12;
}
if (*info == 0) {
work[1].r = (doublereal) lopt, work[1].i = 0.;
rwork[1] = (doublereal) lropt;
iwork[1] = liopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHEEVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
i__1 = a_subscr(1, 1);
w[1] = a[i__1].r;
if (wantz) {
i__1 = a_subscr(1, 1);
a[i__1].r = 1., a[i__1].i = 0.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = zlanhe_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
iscale = 0;
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
zlascl_(uplo, &c__0, &c__0, &c_b13, &sigma, n, n, &a[a_offset], lda,
info);
}
/* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */
inde = 1;
indtau = 1;
indwrk = indtau + *n;
indrwk = inde + *n;
indwk2 = indwrk + *n * *n;
llwork = *lwork - indwrk + 1;
llwrk2 = *lwork - indwk2 + 1;
llrwk = *lrwork - indrwk + 1;
zhetrd_(uplo, n, &a[a_offset], lda, &w[1], &rwork[inde], &work[indtau], &
work[indwrk], &llwork, &iinfo);
/* Computing MAX */
i__1 = indwrk;
d__1 = (doublereal) lopt, d__2 = (doublereal) (*n) + work[i__1].r;
lopt = (integer) max(d__1,d__2);
/* For eigenvalues only, call DSTERF. For eigenvectors, first call
ZSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
tridiagonal matrix, then call ZUNMTR to multiply it to the
Householder transformations represented as Householder vectors in
A. */
if (! wantz) {
dsterf_(n, &w[1], &rwork[inde], info);
} else {
zstedc_("I", n, &w[1], &rwork[inde], &work[indwrk], n, &work[indwk2],
&llwrk2, &rwork[indrwk], &llrwk, &iwork[1], liwork, info);
zunmtr_("L", uplo, "N", n, n, &a[a_offset], lda, &work[indtau], &work[
indwrk], n, &work[indwk2], &llwrk2, &iinfo);
zlacpy_("A", n, n, &work[indwrk], n, &a[a_offset], lda);
/* Computing MAX
Computing 2nd power */
i__3 = *n;
i__4 = indwk2;
i__1 = lopt, i__2 = *n + i__3 * i__3 + (integer) work[i__4].r;
lopt = max(i__1,i__2);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &w[1], &c__1);
}
work[1].r = (doublereal) lopt, work[1].i = 0.;
rwork[1] = (doublereal) lropt;
iwork[1] = liopt;
return 0;
/* End of ZHEEVD */
} /* zheevd_ */
/* Subroutine */ int zhpt01_(char *uplo, integer *n, doublecomplex *a,
doublecomplex *afac, integer *ipiv, doublecomplex *c__, integer *ldc,
doublereal *rwork, doublereal *resid)
{
/* System generated locals */
integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
integer i__, j, jc;
doublereal eps;
integer info;
extern logical lsame_(char *, char *);
doublereal anorm;
extern doublereal dlamch_(char *), zlanhe_(char *, char *,
integer *, doublecomplex *, integer *, doublereal *), zlanhp_(char *, char *, integer *, doublecomplex *,
doublereal *);
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlavhp_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHPT01 reconstructs a Hermitian indefinite packed matrix A from its */
/* block L*D*L' or U*D*U' factorization and computes the residual */
/* norm( C - A ) / ( N * norm(A) * EPS ), */
/* where C is the reconstructed matrix, EPS is the machine epsilon, */
/* L' is the conjugate transpose of L, and U' is the conjugate transpose */
/* of U. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* The original Hermitian matrix A, stored as a packed */
/* triangular matrix. */
/* AFAC (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* The factored form of the matrix A, stored as a packed */
/* triangular matrix. AFAC contains the block diagonal matrix D */
/* and the multipliers used to obtain the factor L or U from the */
/* block L*D*L' or U*D*U' factorization as computed by ZHPTRF. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from ZHPTRF. */
/* C (workspace) COMPLEX*16 array, dimension (LDC,N) */
/* LDC (integer) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,N). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESID (output) DOUBLE PRECISION */
/* If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
--a;
--afac;
--ipiv;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.;
return 0;
}
/* Determine EPS and the norm of A. */
eps = dlamch_("Epsilon");
anorm = zlanhp_("1", uplo, n, &a[1], &rwork[1]);
/* Check the imaginary parts of the diagonal elements and return with */
/* an error code if any are nonzero. */
jc = 1;
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (d_imag(&afac[jc]) != 0.) {
*resid = 1. / eps;
return 0;
}
jc = jc + j + 1;
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (d_imag(&afac[jc]) != 0.) {
*resid = 1. / eps;
return 0;
}
jc = jc + *n - j + 1;
/* L20: */
}
}
/* Initialize C to the identity matrix. */
zlaset_("Full", n, n, &c_b1, &c_b2, &c__[c_offset], ldc);
/* Call ZLAVHP to form the product D * U' (or D * L' ). */
zlavhp_(uplo, "Conjugate", "Non-unit", n, n, &afac[1], &ipiv[1], &c__[
c_offset], ldc, &info);
/* Call ZLAVHP again to multiply by U ( or L ). */
zlavhp_(uplo, "No transpose", "Unit", n, n, &afac[1], &ipiv[1], &c__[
c_offset], ldc, &info);
/* Compute the difference C - A . */
if (lsame_(uplo, "U")) {
jc = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = jc + i__;
z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[
i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L30: */
}
i__2 = j + j * c_dim1;
i__3 = j + j * c_dim1;
i__4 = jc + j;
d__1 = a[i__4].r;
z__1.r = c__[i__3].r - d__1, z__1.i = c__[i__3].i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
jc += j;
/* L40: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * c_dim1;
i__3 = j + j * c_dim1;
i__4 = jc;
d__1 = a[i__4].r;
z__1.r = c__[i__3].r - d__1, z__1.i = c__[i__3].i;
c__[i__2].r = z__1.r, c__[i__2].i = z__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * c_dim1;
i__4 = i__ + j * c_dim1;
i__5 = jc + i__ - j;
z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[
i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L50: */
}
jc = jc + *n - j + 1;
/* L60: */
}
}
/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
*resid = zlanhe_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
if (anorm <= 0.) {
if (*resid != 0.) {
*resid = 1. / eps;
}
} else {
*resid = *resid / (doublereal) (*n) / anorm / eps;
}
return 0;
/* End of ZHPT01 */
} /* zhpt01_ */
/* Subroutine */ int zchkpo_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublecomplex *a,
doublecomplex *afac, doublecomplex *ainv, doublecomplex *b,
doublecomplex *x, doublecomplex *xact, doublecomplex *work,
doublereal *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];
doublereal rcond;
integer nimat;
doublereal anorm;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
doublereal rcondc;
doublereal cndnum;
doublereal 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 */
/* ======= */
/* ZCHKPO tests ZPOTRF, -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) DOUBLE PRECISION */
/* 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*16 array, dimension (NMAX*NMAX) */
/* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) */
/* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION 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, "Zomplex 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) {
zerrpo_(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 ZLATB4 and generate a test matrix */
/* with ZLATMS. */
zlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "ZLATMS", (ftnlen)32, (ftnlen)6);
zlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from ZLATMS. */
if (info != 0) {
alaerh_(path, "ZLATMS", &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., a[i__4].i = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff;
a[i__4].r = 0., a[i__4].i = 0.;
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., a[i__4].i = 0.;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
i__4 = ioff + i__;
a[i__4].r = 0., a[i__4].i = 0.;
/* L50: */
}
}
} else {
izero = 0;
}
/* Set the imaginary part of the diagonals. */
i__3 = lda + 1;
zlaipd_(&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. */
zlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
s_copy(srnamc_1.srnamt, "ZPOTRF", (ftnlen)32, (ftnlen)6);
zpotrf_(uplo, &n, &afac[1], &lda, &info);
/* Check error code from ZPOTRF. */
if (info != izero) {
alaerh_(path, "ZPOTRF", &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. */
zlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
zpot01_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &rwork[1],
result);
/* + TEST 2 */
/* Form the inverse and compute the residual. */
zlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "ZPOTRI", (ftnlen)32, (ftnlen)6);
zpotri_(uplo, &n, &ainv[1], &lda, &info);
/* Check error code from ZPOTRI. */
if (info != 0) {
alaerh_(path, "ZPOTRI", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
zpot03_(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(doublereal));
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, "ZLARHS", (ftnlen)32, (ftnlen)
6);
zlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "ZPOTRS", (ftnlen)32, (ftnlen)
6);
zpotrs_(uplo, &n, &nrhs, &afac[1], &lda, &x[1], &lda,
&info);
/* Check error code from ZPOTRS. */
if (info != 0) {
alaerh_(path, "ZPOTRS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
zlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
lda);
zpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
zget04_(&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, "ZPORFS", (ftnlen)32, (ftnlen)
6);
zporfs_(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 ZPORFS. */
if (info != 0) {
alaerh_(path, "ZPORFS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
zget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
zpot05_(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(doublereal));
e_wsfe();
++nfail;
}
/* L70: */
}
nrun += 5;
/* L80: */
}
/* + TEST 8 */
/* Get an estimate of RCOND = 1/CNDNUM. */
anorm = zlanhe_("1", uplo, &n, &a[1], &lda, &rwork[1]);
s_copy(srnamc_1.srnamt, "ZPOCON", (ftnlen)32, (ftnlen)6);
zpocon_(uplo, &n, &afac[1], &lda, &anorm, &rcond, &work[1]
, &rwork[1], &info);
/* Check error code from ZPOCON. */
if (info != 0) {
alaerh_(path, "ZPOCON", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
result[7] = dget06_(&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(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L90:
;
}
L100:
;
}
L110:
;
}
/* L120: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of ZCHKPO */
} /* zchkpo_ */
/* Subroutine */ int zpot02_(char *uplo, integer *n, integer *nrhs,
doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx,
doublecomplex *b, integer *ldb, doublereal *rwork, doublereal *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
doublereal d__1, d__2;
doublecomplex z__1;
/* Local variables */
integer j;
doublereal eps, anorm, bnorm;
extern /* Subroutine */ int zhemm_(char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
doublereal xnorm;
extern doublereal dlamch_(char *), zlanhe_(char *, char *,
integer *, doublecomplex *, integer *, doublereal *), dzasum_(integer *, doublecomplex *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPOT02 computes the residual for the solution of a Hermitian system */
/* of linear equations A*x = b: */
/* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of B, the matrix of right hand sides. */
/* NRHS >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The original Hermitian matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* X (input) COMPLEX*16 array, dimension (LDX,NRHS) */
/* The computed solution vectors for the system of linear */
/* equations. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
/* On entry, the right hand side vectors for the system of */
/* linear equations. */
/* On exit, B is overwritten with the difference B - A*X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESID (output) DOUBLE PRECISION */
/* The maximum over the number of right hand sides of */
/* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--rwork;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
anorm = zlanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Compute B - A*X */
z__1.r = -1., z__1.i = -0.;
zhemm_("Left", uplo, n, nrhs, &z__1, &a[a_offset], lda, &x[x_offset], ldx,
&c_b1, &b[b_offset], ldb);
/* Compute the maximum over the number of right hand sides of */
/* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) . */
*resid = 0.;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
bnorm = dzasum_(n, &b[j * b_dim1 + 1], &c__1);
xnorm = dzasum_(n, &x[j * x_dim1 + 1], &c__1);
if (xnorm <= 0.) {
*resid = 1. / eps;
} else {
/* Computing MAX */
d__1 = *resid, d__2 = bnorm / anorm / xnorm / eps;
*resid = max(d__1,d__2);
}
/* L10: */
}
return 0;
/* End of ZPOT02 */
} /* zpot02_ */
/* Subroutine */ int zgqrts_(integer *n, integer *m, integer *p,
doublecomplex *a, doublecomplex *af, doublecomplex *q, doublecomplex *
r__, integer *lda, doublecomplex *taua, doublecomplex *b,
doublecomplex *bf, doublecomplex *z__, doublecomplex *t,
doublecomplex *bwk, integer *ldb, doublecomplex *taub, doublecomplex *
work, integer *lwork, doublereal *rwork, doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, bf_dim1,
bf_offset, bwk_dim1, bwk_offset, q_dim1, q_offset, r_dim1,
r_offset, t_dim1, t_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1;
doublecomplex z__1;
/* Local variables */
doublereal ulp;
integer info;
doublereal unfl, resid, anorm, bnorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *), zherk_(char *, char *, integer *,
integer *, doublereal *, doublecomplex *, integer *, doublereal *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *), zlange_(char *, integer *,
integer *, doublecomplex *, integer *, doublereal *),
zlanhe_(char *, char *, integer *, doublecomplex *, integer *,
doublereal *);
extern /* Subroutine */ int zggqrf_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, integer *)
, zlacpy_(char *, integer *, integer *, doublecomplex *, integer *
, doublecomplex *, integer *), zlaset_(char *, integer *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
integer *), zungqr_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *), zungrq_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGQRTS tests ZGGQRF, which computes the GQR factorization of an */
/* N-by-M matrix A and a N-by-P matrix B: A = Q*R and B = Q*T*Z. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of rows of the matrices A and B. N >= 0. */
/* M (input) INTEGER */
/* The number of columns of the matrix A. M >= 0. */
/* P (input) INTEGER */
/* The number of columns of the matrix B. P >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,M) */
/* The N-by-M matrix A. */
/* AF (output) COMPLEX*16 array, dimension (LDA,N) */
/* Details of the GQR factorization of A and B, as returned */
/* by ZGGQRF, see CGGQRF for further details. */
/* Q (output) COMPLEX*16 array, dimension (LDA,N) */
/* The M-by-M unitary matrix Q. */
/* R (workspace) COMPLEX*16 array, dimension (LDA,MAX(M,N)) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, R and Q. */
/* LDA >= max(M,N). */
/* TAUA (output) COMPLEX*16 array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by ZGGQRF. */
/* B (input) COMPLEX*16 array, dimension (LDB,P) */
/* On entry, the N-by-P matrix A. */
/* BF (output) COMPLEX*16 array, dimension (LDB,N) */
/* Details of the GQR factorization of A and B, as returned */
/* by ZGGQRF, see CGGQRF for further details. */
/* Z (output) COMPLEX*16 array, dimension (LDB,P) */
/* The P-by-P unitary matrix Z. */
/* T (workspace) COMPLEX*16 array, dimension (LDB,max(P,N)) */
/* BWK (workspace) COMPLEX*16 array, dimension (LDB,N) */
/* LDB (input) INTEGER */
/* The leading dimension of the arrays B, BF, Z and T. */
/* LDB >= max(P,N). */
/* TAUB (output) COMPLEX*16 array, dimension (min(P,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by DGGRQF. */
/* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK, LWORK >= max(N,M,P)**2. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(N,M,P)) */
/* RESULT (output) DOUBLE PRECISION array, dimension (4) */
/* The test ratios: */
/* RESULT(1) = norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP) */
/* RESULT(2) = norm( T*Z - Q'*B ) / (MAX(P,N)*norm(B)*ULP) */
/* RESULT(3) = norm( I - Q'*Q ) / ( M*ULP ) */
/* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
r_dim1 = *lda;
r_offset = 1 + r_dim1;
r__ -= r_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--taua;
bwk_dim1 = *ldb;
bwk_offset = 1 + bwk_dim1;
bwk -= bwk_offset;
t_dim1 = *ldb;
t_offset = 1 + t_dim1;
t -= t_offset;
z_dim1 = *ldb;
z_offset = 1 + z_dim1;
z__ -= z_offset;
bf_dim1 = *ldb;
bf_offset = 1 + bf_dim1;
bf -= bf_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--taub;
--work;
--rwork;
--result;
/* Function Body */
ulp = dlamch_("Precision");
unfl = dlamch_("Safe minimum");
/* Copy the matrix A to the array AF. */
zlacpy_("Full", n, m, &a[a_offset], lda, &af[af_offset], lda);
zlacpy_("Full", n, p, &b[b_offset], ldb, &bf[bf_offset], ldb);
/* Computing MAX */
d__1 = zlange_("1", n, m, &a[a_offset], lda, &rwork[1]);
anorm = max(d__1,unfl);
/* Computing MAX */
d__1 = zlange_("1", n, p, &b[b_offset], ldb, &rwork[1]);
bnorm = max(d__1,unfl);
/* Factorize the matrices A and B in the arrays AF and BF. */
zggqrf_(n, m, p, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, &
taub[1], &work[1], lwork, &info);
/* Generate the N-by-N matrix Q */
zlaset_("Full", n, n, &c_b3, &c_b3, &q[q_offset], lda);
i__1 = *n - 1;
zlacpy_("Lower", &i__1, m, &af[af_dim1 + 2], lda, &q[q_dim1 + 2], lda);
i__1 = min(*n,*m);
zungqr_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
/* Generate the P-by-P matrix Z */
zlaset_("Full", p, p, &c_b3, &c_b3, &z__[z_offset], ldb);
if (*n <= *p) {
if (*n > 0 && *n < *p) {
i__1 = *p - *n;
zlacpy_("Full", n, &i__1, &bf[bf_offset], ldb, &z__[*p - *n + 1 +
z_dim1], ldb);
}
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
zlacpy_("Lower", &i__1, &i__2, &bf[(*p - *n + 1) * bf_dim1 + 2],
ldb, &z__[*p - *n + 2 + (*p - *n + 1) * z_dim1], ldb);
}
} else {
if (*p > 1) {
i__1 = *p - 1;
i__2 = *p - 1;
zlacpy_("Lower", &i__1, &i__2, &bf[*n - *p + 2 + bf_dim1], ldb, &
z__[z_dim1 + 2], ldb);
}
}
i__1 = min(*n,*p);
zungrq_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
info);
/* Copy R */
zlaset_("Full", n, m, &c_b1, &c_b1, &r__[r_offset], lda);
zlacpy_("Upper", n, m, &af[af_offset], lda, &r__[r_offset], lda);
/* Copy T */
zlaset_("Full", n, p, &c_b1, &c_b1, &t[t_offset], ldb);
if (*n <= *p) {
zlacpy_("Upper", n, n, &bf[(*p - *n + 1) * bf_dim1 + 1], ldb, &t[(*p
- *n + 1) * t_dim1 + 1], ldb);
} else {
i__1 = *n - *p;
zlacpy_("Full", &i__1, p, &bf[bf_offset], ldb, &t[t_offset], ldb);
zlacpy_("Upper", p, p, &bf[*n - *p + 1 + bf_dim1], ldb, &t[*n - *p +
1 + t_dim1], ldb);
}
/* Compute R - Q'*A */
z__1.r = -1., z__1.i = -0.;
zgemm_("Conjugate transpose", "No transpose", n, m, n, &z__1, &q[q_offset]
, lda, &a[a_offset], lda, &c_b2, &r__[r_offset], lda);
/* Compute norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP ) . */
resid = zlange_("1", n, m, &r__[r_offset], lda, &rwork[1]);
if (anorm > 0.) {
/* Computing MAX */
i__1 = max(1,*m);
result[1] = resid / (doublereal) max(i__1,*n) / anorm / ulp;
} else {
result[1] = 0.;
}
/* Compute T*Z - Q'*B */
zgemm_("No Transpose", "No transpose", n, p, p, &c_b2, &t[t_offset], ldb,
&z__[z_offset], ldb, &c_b1, &bwk[bwk_offset], ldb);
z__1.r = -1., z__1.i = -0.;
zgemm_("Conjugate transpose", "No transpose", n, p, n, &z__1, &q[q_offset]
, lda, &b[b_offset], ldb, &c_b2, &bwk[bwk_offset], ldb);
/* Compute norm( T*Z - Q'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
resid = zlange_("1", n, p, &bwk[bwk_offset], ldb, &rwork[1]);
if (bnorm > 0.) {
/* Computing MAX */
i__1 = max(1,*p);
result[2] = resid / (doublereal) max(i__1,*n) / bnorm / ulp;
} else {
result[2] = 0.;
}
/* Compute I - Q'*Q */
zlaset_("Full", n, n, &c_b1, &c_b2, &r__[r_offset], lda);
zherk_("Upper", "Conjugate transpose", n, n, &c_b34, &q[q_offset], lda, &
c_b35, &r__[r_offset], lda);
/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
resid = zlanhe_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
result[3] = resid / (doublereal) max(1,*n) / ulp;
/* Compute I - Z'*Z */
zlaset_("Full", p, p, &c_b1, &c_b2, &t[t_offset], ldb);
zherk_("Upper", "Conjugate transpose", p, p, &c_b34, &z__[z_offset], ldb,
&c_b35, &t[t_offset], ldb);
/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
resid = zlanhe_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
result[4] = resid / (doublereal) max(1,*p) / ulp;
return 0;
/* End of ZGQRTS */
} /* zgqrts_ */
/* Subroutine */ int zhesvx_(char *fact, char *uplo, integer *n, integer *
nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *
ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x,
integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr,
doublecomplex *work, integer *lwork, doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2;
/* Local variables */
integer nb;
extern logical lsame_(char *, char *);
doublereal anorm;
extern doublereal dlamch_(char *);
logical nofact;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zhecon_(char *, integer *, doublecomplex *,
integer *, integer *, doublereal *, doublereal *, doublecomplex *,
integer *), zherfs_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, doublereal *,
integer *), zhetrf_(char *, integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *), zhetrs_(char *,
integer *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, integer *);
integer lwkopt;
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 */
/* ======= */
/* ZHESVX uses the diagonal pivoting factorization to compute the */
/* solution to a complex system of linear equations A * X = B, */
/* where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS */
/* matrices. */
/* Error bounds on the solution and a condition estimate are also */
/* provided. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A. */
/* The form of the factorization is */
/* A = U * D * U**H, if UPLO = 'U', or */
/* A = L * D * L**H, if UPLO = 'L', */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, and D is Hermitian and block diagonal with */
/* 1-by-1 and 2-by-2 diagonal blocks. */
/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
/* returns with INFO = i. Otherwise, the factored form of A is used */
/* to estimate the condition number of the matrix A. If the */
/* reciprocal of the condition number is less than machine precision, */
/* INFO = N+1 is returned as a warning, but the routine still goes on */
/* to solve for X and compute error bounds as described below. */
/* 3. The system of equations is solved for X using the factored form */
/* of A. */
/* 4. Iterative refinement is applied to improve the computed solution */
/* matrix and calculate error bounds and backward error estimates */
/* for it. */
/* Arguments */
/* ========= */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of A has been */
/* supplied on entry. */
/* = 'F': On entry, AF and IPIV contain the factored form */
/* of A. A, AF and IPIV will not be modified. */
/* = 'N': The matrix A will be copied to AF and factored. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* 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. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input or output) COMPLEX*16 array, dimension (LDAF,N) */
/* If FACT = 'F', then AF is an input argument and on entry */
/* contains the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L from the factorization */
/* A = U*D*U**H or A = L*D*L**H as computed by ZHETRF. */
/* If FACT = 'N', then AF is an output argument and on exit */
/* returns the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L from the factorization */
/* A = U*D*U**H or A = L*D*L**H. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input or output) INTEGER array, dimension (N) */
/* If FACT = 'F', then IPIV is an input argument and on entry */
/* contains details of the interchanges and the block structure */
/* of D, as determined by ZHETRF. */
/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
/* If FACT = 'N', then IPIV is an output argument and on exit */
/* contains details of the interchanges and the block structure */
/* of D, as determined by ZHETRF. */
/* B (input) COMPLEX*16 array, dimension (LDB,NRHS) */
/* The N-by-NRHS right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) COMPLEX*16 array, dimension (LDX,NRHS) */
/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) DOUBLE PRECISION */
/* The estimate of the reciprocal condition number of the matrix */
/* A. If RCOND is less than the machine precision (in */
/* particular, if RCOND = 0), the matrix is singular to working */
/* precision. This condition is indicated by a return code of */
/* INFO > 0. */
/* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of WORK. LWORK >= max(1,2*N), and for best */
/* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where */
/* NB is the optimal blocksize for ZHETRF. */
/* 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) DOUBLE PRECISION array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, and i is */
/* <= N: D(i,i) is exactly zero. The factorization */
/* has been completed but the factor D is exactly */
/* singular, so the solution and error bounds could */
/* not be computed. RCOND = 0 is returned. */
/* = N+1: D is nonsingular, but RCOND is less than machine */
/* precision, meaning that the matrix is singular */
/* to working precision. Nevertheless, the */
/* solution and error bounds are computed because */
/* there are a number of situations where the */
/* computed solution can be more accurate than the */
/* value of RCOND would suggest. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
lquery = *lwork == -1;
if (! nofact && ! lsame_(fact, "F")) {
*info = -1;
} else if (! lsame_(uplo, "U") && ! lsame_(uplo,
"L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (*ldb < max(1,*n)) {
*info = -11;
} else if (*ldx < max(1,*n)) {
*info = -13;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -18;
}
}
if (*info == 0) {
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
lwkopt = max(i__1,i__2);
if (nofact) {
nb = ilaenv_(&c__1, "ZHETRF", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = lwkopt, i__2 = *n * nb;
lwkopt = max(i__1,i__2);
}
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHESVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
if (nofact) {
/* Compute the factorization A = U*D*U' or A = L*D*L'. */
zlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
zhetrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], lwork,
info);
/* Return if INFO is non-zero. */
if (*info > 0) {
*rcond = 0.;
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = zlanhe_("I", uplo, n, &a[a_offset], lda, &rwork[1]);
/* Compute the reciprocal of the condition number of A. */
zhecon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
info);
/* Compute the solution vectors X. */
zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
zhetrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
info);
/* Use iterative refinement to improve the computed solutions and */
/* compute error bounds and backward error estimates for them. */
zherfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1],
&b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1]
, &rwork[1], info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon")) {
*info = *n + 1;
}
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
return 0;
/* End of ZHESVX */
} /* zhesvx_ */
/* Subroutine */ int zhet21_(integer *itype, char *uplo, integer *n, integer *
kband, doublecomplex *a, integer *lda, doublereal *d__, doublereal *e,
doublecomplex *u, integer *ldu, doublecomplex *v, integer *ldv,
doublecomplex *tau, doublecomplex *work, doublereal *rwork,
doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
i__3, i__4, i__5, i__6;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3;
/* Local variables */
integer j, jr;
doublereal ulp;
integer jcol;
doublereal unfl;
extern /* Subroutine */ int zher_(char *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *);
integer jrow;
extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern logical lsame_(char *, char *);
integer iinfo;
doublereal anorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
char cuplo[1];
doublecomplex vsave;
logical lower;
doublereal wnorm;
extern /* Subroutine */ int zunm2l_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *), zlanhe_(char *, char *, integer
*, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *), zlarfy_(
char *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHET21 generally checks a decomposition of the form */
/* A = U S U* */
/* where * means conjugate transpose, A is hermitian, U is unitary, and */
/* S is diagonal (if KBAND=0) or (real) symmetric tridiagonal (if */
/* KBAND=1). */
/* If ITYPE=1, then U is represented as a dense matrix; otherwise U is */
/* expressed as a product of Householder transformations, whose vectors */
/* are stored in the array "V" and whose scaling constants are in "TAU". */
/* We shall use the letter "V" to refer to the product of Householder */
/* transformations (which should be equal to U). */
/* Specifically, if ITYPE=1, then: */
/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
/* RESULT(2) = | I - UU* | / ( n ulp ) */
/* If ITYPE=2, then: */
/* RESULT(1) = | A - V S V* | / ( |A| n ulp ) */
/* If ITYPE=3, then: */
/* RESULT(1) = | I - UV* | / ( n ulp ) */
/* For ITYPE > 1, the transformation U is expressed as a product */
/* V = H(1)...H(n-2), where H(j) = I - tau(j) v(j) v(j)* and each */
/* vector v(j) has its first j elements 0 and the remaining n-j elements */
/* stored in V(j+1:n,j). */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the type of tests to be performed. */
/* 1: U expressed as a dense unitary matrix: */
/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
/* RESULT(2) = | I - UU* | / ( n ulp ) */
/* 2: U expressed as a product V of Housholder transformations: */
/* RESULT(1) = | A - V S V* | / ( |A| n ulp ) */
/* 3: U expressed both as a dense unitary matrix and */
/* as a product of Housholder transformations: */
/* RESULT(1) = | I - UV* | / ( n ulp ) */
/* UPLO (input) CHARACTER */
/* If UPLO='U', the upper triangle of A and V will be used and */
/* the (strictly) lower triangle will not be referenced. */
/* If UPLO='L', the lower triangle of A and V will be used and */
/* the (strictly) upper triangle will not be referenced. */
/* N (input) INTEGER */
/* The size of the matrix. If it is zero, ZHET21 does nothing. */
/* It must be at least zero. */
/* KBAND (input) INTEGER */
/* The bandwidth of the matrix. It may only be zero or one. */
/* If zero, then S is diagonal, and E is not referenced. If */
/* one, then S is symmetric tri-diagonal. */
/* A (input) COMPLEX*16 array, dimension (LDA, N) */
/* The original (unfactored) matrix. It is assumed to be */
/* hermitian, and only the upper (UPLO='U') or only the lower */
/* (UPLO='L') will be referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of A. It must be at least 1 */
/* and at least N. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The diagonal of the (symmetric tri-) diagonal matrix. */
/* E (input) DOUBLE PRECISION array, dimension (N-1) */
/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
/* (3,2) element, etc. */
/* Not referenced if KBAND=0. */
/* U (input) COMPLEX*16 array, dimension (LDU, N) */
/* If ITYPE=1 or 3, this contains the unitary matrix in */
/* the decomposition, expressed as a dense matrix. If ITYPE=2, */
/* then it is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of U. LDU must be at least N and */
/* at least 1. */
/* V (input) COMPLEX*16 array, dimension (LDV, N) */
/* If ITYPE=2 or 3, the columns of this array contain the */
/* Householder vectors used to describe the unitary matrix */
/* in the decomposition. If UPLO='L', then the vectors are in */
/* the lower triangle, if UPLO='U', then in the upper */
/* triangle. */
/* *NOTE* If ITYPE=2 or 3, V is modified and restored. The */
/* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') */
/* is set to one, and later reset to its original value, during */
/* the course of the calculation. */
/* If ITYPE=1, then it is neither referenced nor modified. */
/* LDV (input) INTEGER */
/* The leading dimension of V. LDV must be at least N and */
/* at least 1. */
/* TAU (input) COMPLEX*16 array, dimension (N) */
/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
/* v(j) v(j)* in the Householder transformation H(j) of */
/* the product U = H(1)...H(n-2) */
/* If ITYPE < 2, then TAU is not referenced. */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N**2) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* The values computed by the two tests described above. The */
/* values are currently limited to 1/ulp, to avoid overflow. */
/* RESULT(1) is always modified. RESULT(2) is modified only */
/* if ITYPE=1. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
result[1] = 0.;
if (*itype == 1) {
result[2] = 0.;
}
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U")) {
lower = FALSE_;
*(unsigned char *)cuplo = 'U';
} else {
lower = TRUE_;
*(unsigned char *)cuplo = 'L';
}
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon") * dlamch_("Base");
/* Some Error Checks */
if (*itype < 1 || *itype > 3) {
result[1] = 10. / ulp;
return 0;
}
/* Do Test 1 */
/* Norm of A: */
if (*itype == 3) {
anorm = 1.;
} else {
/* Computing MAX */
d__1 = zlanhe_("1", cuplo, n, &a[a_offset], lda, &rwork[1]);
anorm = max(d__1,unfl);
}
/* Compute error matrix: */
if (*itype == 1) {
/* ITYPE=1: error = A - U S U* */
zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
zlacpy_(cuplo, n, n, &a[a_offset], lda, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
d__1 = -d__[j];
zher_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &work[1], n);
/* L10: */
}
if (*n > 1 && *kband == 1) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__2.r = e[i__2], z__2.i = 0.;
z__1.r = -z__2.r, z__1.i = -z__2.i;
zher2_(cuplo, n, &z__1, &u[j * u_dim1 + 1], &c__1, &u[(j - 1)
* u_dim1 + 1], &c__1, &work[1], n);
/* L20: */
}
}
wnorm = zlanhe_("1", cuplo, n, &work[1], n, &rwork[1]);
} else if (*itype == 2) {
/* ITYPE=2: error = V S V* - A */
zlaset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
if (lower) {
/* Computing 2nd power */
i__2 = *n;
i__1 = i__2 * i__2;
i__3 = *n;
work[i__1].r = d__[i__3], work[i__1].i = 0.;
for (j = *n - 1; j >= 1; --j) {
if (*kband == 1) {
i__1 = (*n + 1) * (j - 1) + 2;
i__2 = j;
z__2.r = 1. - tau[i__2].r, z__2.i = 0. - tau[i__2].i;
i__3 = j;
z__1.r = e[i__3] * z__2.r, z__1.i = e[i__3] * z__2.i;
work[i__1].r = z__1.r, work[i__1].i = z__1.i;
i__1 = *n;
for (jr = j + 2; jr <= i__1; ++jr) {
i__2 = (j - 1) * *n + jr;
i__3 = j;
z__3.r = -tau[i__3].r, z__3.i = -tau[i__3].i;
i__4 = j;
z__2.r = e[i__4] * z__3.r, z__2.i = e[i__4] * z__3.i;
i__5 = jr + j * v_dim1;
z__1.r = z__2.r * v[i__5].r - z__2.i * v[i__5].i,
z__1.i = z__2.r * v[i__5].i + z__2.i * v[i__5]
.r;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L30: */
}
}
i__1 = j + 1 + j * v_dim1;
vsave.r = v[i__1].r, vsave.i = v[i__1].i;
i__1 = j + 1 + j * v_dim1;
v[i__1].r = 1., v[i__1].i = 0.;
i__1 = *n - j;
/* Computing 2nd power */
i__2 = *n;
zlarfy_("L", &i__1, &v[j + 1 + j * v_dim1], &c__1, &tau[j], &
work[(*n + 1) * j + 1], n, &work[i__2 * i__2 + 1]);
i__1 = j + 1 + j * v_dim1;
v[i__1].r = vsave.r, v[i__1].i = vsave.i;
i__1 = (*n + 1) * (j - 1) + 1;
i__2 = j;
work[i__1].r = d__[i__2], work[i__1].i = 0.;
/* L40: */
}
} else {
work[1].r = d__[1], work[1].i = 0.;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
if (*kband == 1) {
i__2 = (*n + 1) * j;
i__3 = j;
z__2.r = 1. - tau[i__3].r, z__2.i = 0. - tau[i__3].i;
i__4 = j;
z__1.r = e[i__4] * z__2.r, z__1.i = e[i__4] * z__2.i;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
i__2 = j - 1;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = j * *n + jr;
i__4 = j;
z__3.r = -tau[i__4].r, z__3.i = -tau[i__4].i;
i__5 = j;
z__2.r = e[i__5] * z__3.r, z__2.i = e[i__5] * z__3.i;
i__6 = jr + (j + 1) * v_dim1;
z__1.r = z__2.r * v[i__6].r - z__2.i * v[i__6].i,
z__1.i = z__2.r * v[i__6].i + z__2.i * v[i__6]
.r;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L50: */
}
}
i__2 = j + (j + 1) * v_dim1;
vsave.r = v[i__2].r, vsave.i = v[i__2].i;
i__2 = j + (j + 1) * v_dim1;
v[i__2].r = 1., v[i__2].i = 0.;
/* Computing 2nd power */
i__2 = *n;
zlarfy_("U", &j, &v[(j + 1) * v_dim1 + 1], &c__1, &tau[j], &
work[1], n, &work[i__2 * i__2 + 1]);
i__2 = j + (j + 1) * v_dim1;
v[i__2].r = vsave.r, v[i__2].i = vsave.i;
i__2 = (*n + 1) * j + 1;
i__3 = j + 1;
work[i__2].r = d__[i__3], work[i__2].i = 0.;
/* L60: */
}
}
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
if (lower) {
i__2 = *n;
for (jrow = jcol; jrow <= i__2; ++jrow) {
i__3 = jrow + *n * (jcol - 1);
i__4 = jrow + *n * (jcol - 1);
i__5 = jrow + jcol * a_dim1;
z__1.r = work[i__4].r - a[i__5].r, z__1.i = work[i__4].i
- a[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L70: */
}
} else {
i__2 = jcol;
for (jrow = 1; jrow <= i__2; ++jrow) {
i__3 = jrow + *n * (jcol - 1);
i__4 = jrow + *n * (jcol - 1);
i__5 = jrow + jcol * a_dim1;
z__1.r = work[i__4].r - a[i__5].r, z__1.i = work[i__4].i
- a[i__5].i;
work[i__3].r = z__1.r, work[i__3].i = z__1.i;
/* L80: */
}
}
/* L90: */
}
wnorm = zlanhe_("1", cuplo, n, &work[1], n, &rwork[1]);
} else if (*itype == 3) {
/* ITYPE=3: error = U V* - I */
if (*n < 2) {
return 0;
}
zlacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
if (lower) {
i__1 = *n - 1;
i__2 = *n - 1;
/* Computing 2nd power */
i__3 = *n;
zunm2r_("R", "C", n, &i__1, &i__2, &v[v_dim1 + 2], ldv, &tau[1], &
work[*n + 1], n, &work[i__3 * i__3 + 1], &iinfo);
} else {
i__1 = *n - 1;
i__2 = *n - 1;
/* Computing 2nd power */
i__3 = *n;
zunm2l_("R", "C", n, &i__1, &i__2, &v[(v_dim1 << 1) + 1], ldv, &
tau[1], &work[1], n, &work[i__3 * i__3 + 1], &iinfo);
}
if (iinfo != 0) {
result[1] = 10. / ulp;
return 0;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = (*n + 1) * (j - 1) + 1;
i__3 = (*n + 1) * (j - 1) + 1;
z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i - 0.;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L100: */
}
wnorm = zlange_("1", n, n, &work[1], n, &rwork[1]);
}
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*n * ulp);
} else {
if (anorm < 1.) {
/* Computing MIN */
d__1 = wnorm, d__2 = *n * anorm;
result[1] = min(d__1,d__2) / anorm / (*n * ulp);
} else {
/* Computing MIN */
d__1 = wnorm / anorm, d__2 = (doublereal) (*n);
result[1] = min(d__1,d__2) / (*n * ulp);
}
}
/* Do Test 2 */
/* Compute UU* - I */
if (*itype == 1) {
zgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu,
&c_b1, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = (*n + 1) * (j - 1) + 1;
i__3 = (*n + 1) * (j - 1) + 1;
z__1.r = work[i__3].r - 1., z__1.i = work[i__3].i - 0.;
work[i__2].r = z__1.r, work[i__2].i = z__1.i;
/* L110: */
}
/* Computing MIN */
d__1 = zlange_("1", n, n, &work[1], n, &rwork[1]), d__2 = (
doublereal) (*n);
result[2] = min(d__1,d__2) / (*n * ulp);
}
return 0;
/* End of ZHET21 */
} /* zhet21_ */
/* Subroutine */ int zheev_(char *jobz, char *uplo, integer *n, doublecomplex
*a, integer *lda, doublereal *w, doublecomplex *work, integer *lwork,
doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* Local variables */
integer nb;
doublereal eps;
integer inde;
doublereal anrm;
integer imax;
doublereal rmin, rmax;
doublereal sigma;
integer iinfo;
logical lower, wantz;
integer iscale;
doublereal safmin;
doublereal bignum;
integer indtau;
integer indwrk;
integer llwork;
doublereal smlnum;
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZHEEV computes all eigenvalues and, optionally, eigenvectors of a */
/* complex Hermitian matrix A. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX*16 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 */
/* orthonormal eigenvectors of the matrix A. */
/* If JOBZ = 'N', then 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). */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= max(1,2*N-1). */
/* For optimal efficiency, LWORK >= (NB+1)*N, */
/* where NB is the blocksize for ZHETRD 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) DOUBLE PRECISION array, dimension (max(1, 3*N-2)) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the algorithm failed to converge; i */
/* off-diagonal elements of an intermediate tridiagonal */
/* form did not converge to zero. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
--work;
--rwork;
/* Function Body */
wantz = lsame_(jobz, "V");
lower = lsame_(uplo, "L");
lquery = *lwork == -1;
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info == 0) {
nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = 1, i__2 = (nb + 1) * *n;
lwkopt = max(i__1,i__2);
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
/* Computing MAX */
i__1 = 1, i__2 = (*n << 1) - 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -8;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHEEV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
i__1 = a_dim1 + 1;
w[1] = a[i__1].r;
work[1].r = 1., work[1].i = 0.;
if (wantz) {
i__1 = a_dim1 + 1;
a[i__1].r = 1., a[i__1].i = 0.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = zlanhe_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
iscale = 0;
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
zlascl_(uplo, &c__0, &c__0, &c_b18, &sigma, n, n, &a[a_offset], lda,
info);
}
/* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */
inde = 1;
indtau = 1;
indwrk = indtau + *n;
llwork = *lwork - indwrk + 1;
zhetrd_(uplo, n, &a[a_offset], lda, &w[1], &rwork[inde], &work[indtau], &
work[indwrk], &llwork, &iinfo);
/* For eigenvalues only, call DSTERF. For eigenvectors, first call */
/* ZUNGTR to generate the unitary matrix, then call ZSTEQR. */
if (! wantz) {
dsterf_(n, &w[1], &rwork[inde], info);
} else {
zungtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], &
llwork, &iinfo);
indwrk = inde + *n;
zsteqr_(jobz, n, &w[1], &rwork[inde], &a[a_offset], lda, &rwork[
indwrk], info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &w[1], &c__1);
}
/* Set WORK(1) to optimal complex workspace size. */
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
return 0;
/* End of ZHEEV */
} /* zheev_ */
/* Subroutine */
int zporfsx_(char *uplo, char *equed, integer *n, integer * nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer * ldaf, doublereal *s, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *berr, integer * n_err_bnds__, doublereal *err_bnds_norm__, doublereal * err_bnds_comp__, integer *nparams, doublereal *params, doublecomplex * work, doublereal *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;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal illrcond_thresh__, unstable_thresh__, err_lbnd__;
integer ref_type__, j;
doublereal rcond_tmp__;
integer prec_type__;
doublereal cwise_wrong__;
extern /* Subroutine */
int zla_porfsx_extended_(integer *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, logical *, doublereal *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublecomplex *, doublereal *, doublecomplex *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, logical *, integer *);
char norm[1];
logical ignore_cwise__;
extern logical lsame_(char *, char *);
doublereal anorm;
logical rcequ;
extern doublereal zla_porcond_c_(char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublereal *, logical *, integer *, doublecomplex *, doublereal *), zla_porcond_x_(char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublereal *), dlamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *);
extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, integer *, doublereal *);
extern /* Subroutine */
int zpocon_(char *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublecomplex *, doublereal *, integer *);
extern integer ilaprec_(char *);
integer ithresh, n_norms__;
doublereal rthresh;
/* -- LAPACK computational 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 Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Check the input parameters. */
/* Parameter adjustments */
err_bnds_comp_dim1 = *nrhs;
err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
err_bnds_comp__ -= err_bnds_comp_offset;
err_bnds_norm_dim1 = *nrhs;
err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
err_bnds_norm__ -= err_bnds_norm_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--s;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--berr;
--params;
--work;
--rwork;
/* Function Body */
*info = 0;
ref_type__ = 1;
if (*nparams >= 1)
{
if (params[1] < 0.)
{
params[1] = 1.;
}
else
{
ref_type__ = (integer) params[1];
}
}
/* Set default parameters. */
illrcond_thresh__ = (doublereal) (*n) * dlamch_("Epsilon");
ithresh = 10;
rthresh = .5;
unstable_thresh__ = .25;
ignore_cwise__ = FALSE_;
if (*nparams >= 2)
{
if (params[2] < 0.)
{
params[2] = (doublereal) ithresh;
}
else
{
ithresh = (integer) params[2];
}
}
if (*nparams >= 3)
{
if (params[3] < 0.)
{
if (ignore_cwise__)
{
params[3] = 0.;
}
else
{
params[3] = 1.;
}
}
else
{
ignore_cwise__ = params[3] == 0.;
}
}
if (ref_type__ == 0 || *n_err_bnds__ == 0)
{
n_norms__ = 0;
}
else if (ignore_cwise__)
{
n_norms__ = 1;
}
else
{
n_norms__ = 2;
}
rcequ = lsame_(equed, "Y");
/* Test input parameters. */
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (! rcequ && ! lsame_(equed, "N"))
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
else if (*nrhs < 0)
{
*info = -4;
}
else if (*lda < max(1,*n))
{
*info = -6;
}
else if (*ldaf < max(1,*n))
{
*info = -8;
}
else if (*ldb < max(1,*n))
{
*info = -11;
}
else if (*ldx < max(1,*n))
{
*info = -13;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZPORFSX", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || *nrhs == 0)
{
*rcond = 1.;
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
berr[j] = 0.;
if (*n_err_bnds__ >= 1)
{
err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
}
if (*n_err_bnds__ >= 2)
{
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.;
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.;
}
if (*n_err_bnds__ >= 3)
{
err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.;
err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.;
}
}
return 0;
}
/* Default to failure. */
*rcond = 0.;
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
berr[j] = 1.;
if (*n_err_bnds__ >= 1)
{
err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
}
if (*n_err_bnds__ >= 2)
{
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
}
if (*n_err_bnds__ >= 3)
{
err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.;
err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.;
}
}
/* Compute the norm of A and the reciprocal of the condition */
/* number of A. */
*(unsigned char *)norm = 'I';
anorm = zlanhe_(norm, uplo, n, &a[a_offset], lda, &rwork[1]);
zpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1], info);
/* Perform refinement on each right-hand side */
if (ref_type__ != 0)
{
prec_type__ = ilaprec_("E");
zla_porfsx_extended_(&prec_type__, uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &rcequ, &s[1], &b[b_offset], ldb, &x[ x_offset], ldx, &berr[1], &n_norms__, &err_bnds_norm__[ err_bnds_norm_offset], &err_bnds_comp__[err_bnds_comp_offset], &work[1], &rwork[1], &work[*n + 1], &rwork[1], rcond, & ithresh, &rthresh, &unstable_thresh__, &ignore_cwise__, info);
}
/* Computing MAX */
d__1 = 10.;
d__2 = sqrt((doublereal) (*n)); // , expr subst
err_lbnd__ = max(d__1,d__2) * dlamch_("Epsilon");
if (*n_err_bnds__ >= 1 && n_norms__ >= 1)
{
/* Compute scaled normwise condition number cond(A*C). */
if (rcequ)
{
rcond_tmp__ = zla_porcond_c_(uplo, n, &a[a_offset], lda, &af[ af_offset], ldaf, &s[1], &c_true, info, &work[1], &rwork[ 1]);
}
else
{
rcond_tmp__ = zla_porcond_c_(uplo, n, &a[a_offset], lda, &af[ af_offset], ldaf, &s[1], &c_false, info, &work[1], &rwork[ 1]);
}
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
/* Cap the error at 1.0. */
if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] > 1.)
{
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
}
/* Threshold the error (see LAWN). */
if (rcond_tmp__ < illrcond_thresh__)
{
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.;
err_bnds_norm__[j + err_bnds_norm_dim1] = 0.;
if (*info <= *n)
{
*info = *n + j;
}
}
else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] < err_lbnd__)
{
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__;
err_bnds_norm__[j + err_bnds_norm_dim1] = 1.;
}
/* Save the condition number. */
if (*n_err_bnds__ >= 3)
{
err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__;
}
}
}
if (*n_err_bnds__ >= 1 && n_norms__ >= 2)
{
/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */
/* each right-hand side using the current solution as an estimate of */
/* the true solution. If the componentwise error estimate is too */
/* large, then the solution is a lousy estimate of truth and the */
/* estimated RCOND may be too optimistic. To avoid misleading users, */
/* the inverse condition number is set to 0.0 when the estimated */
/* cwise error is at least CWISE_WRONG. */
cwise_wrong__ = sqrt(dlamch_("Epsilon"));
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < cwise_wrong__)
{
rcond_tmp__ = zla_porcond_x_(uplo, n, &a[a_offset], lda, &af[ af_offset], ldaf, &x[j * x_dim1 + 1], info, &work[1], &rwork[1]);
}
else
{
rcond_tmp__ = 0.;
}
/* Cap the error at 1.0. */
if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] > 1.)
{
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
}
/* Threshold the error (see LAWN). */
if (rcond_tmp__ < illrcond_thresh__)
{
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.;
err_bnds_comp__[j + err_bnds_comp_dim1] = 0.;
if (params[3] == 1. && *info < *n + j)
{
*info = *n + j;
}
}
else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < err_lbnd__)
{
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__;
err_bnds_comp__[j + err_bnds_comp_dim1] = 1.;
}
/* Save the condition number. */
if (*n_err_bnds__ >= 3)
{
err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__;
}
}
}
return 0;
/* End of ZPORFSX */
}
/* Subroutine */
int zheevx_(char *jobz, char *range, char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal * w, doublecomplex *z__, integer *ldz, doublecomplex *work, integer * lwork, doublereal *rwork, integer *iwork, integer *ifail, integer * info)
{
/* System generated locals */
integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, nb, jj;
doublereal eps, vll, vuu, tmp1;
integer indd, inde;
doublereal anrm;
integer imax;
doublereal rmin, rmax;
logical test;
integer itmp1, indee;
extern /* Subroutine */
int dscal_(integer *, doublereal *, doublereal *, integer *);
doublereal sigma;
extern logical lsame_(char *, char *);
integer iinfo;
char order[1];
extern /* Subroutine */
int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
logical lower, wantz;
extern /* Subroutine */
int zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
logical alleig, indeig;
integer iscale, indibl;
logical valeig;
doublereal safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
extern /* Subroutine */
int xerbla_(char *, integer *), zdscal_( integer *, doublereal *, doublecomplex *, integer *);
doublereal abstll, bignum;
extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, integer *, doublereal *);
integer indiwk, indisp, indtau;
extern /* Subroutine */
int dsterf_(integer *, doublereal *, doublereal *, integer *), dstebz_(char *, char *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, integer *);
integer indrwk, indwrk;
extern /* Subroutine */
int zhetrd_(char *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublecomplex *, doublecomplex *, integer *, integer *);
integer lwkmin;
extern /* Subroutine */
int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
integer llwork, nsplit;
doublereal smlnum;
extern /* Subroutine */
int zstein_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, doublecomplex *, integer *, doublereal *, integer *, integer *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */
int zsteqr_(char *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, doublereal *, integer *), zungtr_(char *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zunmtr_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *);
/* -- LAPACK driver routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
--ifail;
/* Function Body */
lower = lsame_(uplo, "L");
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1;
*info = 0;
if (! (wantz || lsame_(jobz, "N")))
{
*info = -1;
}
else if (! (alleig || valeig || indeig))
{
*info = -2;
}
else if (! (lower || lsame_(uplo, "U")))
{
*info = -3;
}
else if (*n < 0)
{
*info = -4;
}
else if (*lda < max(1,*n))
{
*info = -6;
}
else
{
if (valeig)
{
if (*n > 0 && *vu <= *vl)
{
*info = -8;
}
}
else if (indeig)
{
if (*il < 1 || *il > max(1,*n))
{
*info = -9;
}
else if (*iu < min(*n,*il) || *iu > *n)
{
*info = -10;
}
}
}
if (*info == 0)
{
if (*ldz < 1 || wantz && *ldz < *n)
{
*info = -15;
}
}
if (*info == 0)
{
if (*n <= 1)
{
lwkmin = 1;
work[1].r = (doublereal) lwkmin;
work[1].i = 0.; // , expr subst
}
else
{
lwkmin = *n << 1;
nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = nb;
i__2 = ilaenv_(&c__1, "ZUNMTR", uplo, n, &c_n1, &c_n1, &c_n1); // , expr subst
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = 1;
i__2 = (nb + 1) * *n; // , expr subst
lwkopt = max(i__1,i__2);
work[1].r = (doublereal) lwkopt;
work[1].i = 0.; // , expr subst
}
if (*lwork < lwkmin && ! lquery)
{
*info = -17;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZHEEVX", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0)
{
return 0;
}
if (*n == 1)
{
if (alleig || indeig)
{
*m = 1;
i__1 = a_dim1 + 1;
w[1] = a[i__1].r;
}
else if (valeig)
{
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
if (*vl < a[i__1].r && *vu >= a[i__2].r)
{
*m = 1;
i__1 = a_dim1 + 1;
w[1] = a[i__1].r;
}
}
if (wantz)
{
i__1 = z_dim1 + 1;
z__[i__1].r = 1.;
z__[i__1].i = 0.; // , expr subst
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum);
d__2 = 1. / sqrt(sqrt(safmin)); // , expr subst
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig)
{
vll = *vl;
vuu = *vu;
}
anrm = zlanhe_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anrm > 0. && anrm < rmin)
{
iscale = 1;
sigma = rmin / anrm;
}
else if (anrm > rmax)
{
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1)
{
if (lower)
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j + 1;
zdscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
/* L10: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
zdscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
/* L20: */
}
}
if (*abstol > 0.)
{
abstll = *abstol * sigma;
}
if (valeig)
{
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indrwk = inde + *n;
indtau = 1;
indwrk = indtau + *n;
llwork = *lwork - indwrk + 1;
zhetrd_(uplo, n, &a[a_offset], lda, &rwork[indd], &rwork[inde], &work[ indtau], &work[indwrk], &llwork, &iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal to */
/* zero, then call DSTERF or ZUNGTR and ZSTEQR. If this fails for */
/* some eigenvalue, then try DSTEBZ. */
test = FALSE_;
if (indeig)
{
if (*il == 1 && *iu == *n)
{
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.)
{
dcopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
indee = indrwk + (*n << 1);
if (! wantz)
{
i__1 = *n - 1;
dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
dsterf_(n, &w[1], &rwork[indee], info);
}
else
{
zlacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz);
zungtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk] , &llwork, &iinfo);
i__1 = *n - 1;
dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
zsteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, & rwork[indrwk], info);
if (*info == 0)
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
ifail[i__] = 0;
/* L30: */
}
}
}
if (*info == 0)
{
*m = *n;
goto L40;
}
*info = 0;
}
/* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. */
if (wantz)
{
*(unsigned char *)order = 'B';
}
else
{
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwk = indisp + *n;
dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], & rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], & rwork[indrwk], &iwork[indiwk], info);
if (wantz)
{
zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], & iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[ indiwk], &ifail[1], info);
/* Apply unitary matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by ZSTEIN. */
zunmtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[ z_offset], ldz, &work[indwrk], &llwork, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L40:
if (iscale == 1)
{
if (*info == 0)
{
imax = *m;
}
else
{
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &w[1], &c__1);
}
/* If eigenvalues are not in order, then sort them, along with */
/* eigenvectors. */
if (wantz)
{
i__1 = *m - 1;
for (j = 1;
j <= i__1;
++j)
{
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1;
jj <= i__2;
++jj)
{
if (w[jj] < tmp1)
{
i__ = jj;
tmp1 = w[jj];
}
/* L50: */
}
if (i__ != 0)
{
itmp1 = iwork[indibl + i__ - 1];
w[i__] = w[j];
iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
w[j] = tmp1;
iwork[indibl + j - 1] = itmp1;
zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], &c__1);
if (*info != 0)
{
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L60: */
}
}
/* Set WORK(1) to optimal complex workspace size. */
work[1].r = (doublereal) lwkopt;
work[1].i = 0.; // , expr subst
return 0;
/* End of ZHEEVX */
}
/* Subroutine */ int zheevx_(char *jobz, char *range, char *uplo, integer *n,
doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu,
integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *
w, doublecomplex *z, integer *ldz, doublecomplex *work, integer *
lwork, doublereal *rwork, integer *iwork, integer *ifail, integer *
info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZHEEVX computes selected eigenvalues and, optionally, eigenvectors
of a complex Hermitian matrix A. Eigenvalues and eigenvectors can
be selected by specifying either a range of values or a range of
indices for the desired eigenvalues.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
RANGE (input) CHARACTER*1
= 'A': all eigenvalues will be found.
= 'V': all eigenvalues in the half-open interval (VL,VU]
will be found.
= 'I': the IL-th through IU-th eigenvalues will be found.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX*16 array, dimension (LDA, N)
On entry, the Hermitian matrix A. If UPLO = 'U', the
leading N-by-N upper triangular part of A contains the
upper triangular part of the matrix A. If UPLO = 'L',
the leading N-by-N lower triangular part of A contains
the lower triangular part of the matrix A.
On exit, the lower triangle (if UPLO='L') or the upper
triangle (if UPLO='U') of A, including the diagonal, is
destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
VL (input) DOUBLE PRECISION
VU (input) DOUBLE PRECISION
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) DOUBLE PRECISION
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*DLAMCH('S'), not zero.
If this routine returns with INFO>0, indicating that some
eigenvectors did not converge, try setting ABSTOL to
2*DLAMCH('S').
See "Computing Small Singular Values of Bidiagonal Matrices
with Guaranteed High Relative Accuracy," by Demmel and
Kahan, LAPACK Working Note #3.
M (output) INTEGER
The total number of eigenvalues found. 0 <= M <= N.
If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
W (output) DOUBLE PRECISION array, dimension (N)
On normal exit, the first M elements contain the selected
eigenvalues in ascending order.
Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))
If JOBZ = 'V', then if INFO = 0, the first M columns of Z
contain the orthonormal eigenvectors of the matrix A
corresponding to the selected eigenvalues, with the i-th
column of Z holding the eigenvector associated with W(i).
If an eigenvector fails to converge, then that column of Z
contains the latest approximation to the eigenvector, and the
index of the eigenvector is returned in IFAIL.
If JOBZ = 'N', then Z is not referenced.
Note: the user must ensure that at least max(1,M) columns are
supplied in the array Z; if RANGE = 'V', the exact value of M
is not known in advance and an upper bound must be used.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
WORK (workspace/output) COMPLEX*16 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 ZHETRD returned by ILAENV.
RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)
IWORK (workspace) INTEGER array, dimension (5*N)
IFAIL (output) INTEGER array, dimension (N)
If JOBZ = 'V', then if INFO = 0, the first M elements of
IFAIL are zero. If INFO > 0, then IFAIL contains the
indices of the eigenvectors that failed to converge.
If JOBZ = 'N', then IFAIL is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, then i eigenvectors failed to converge.
Their indices are stored in array IFAIL.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer indd, inde;
static doublereal anrm;
static integer imax;
static doublereal rmin, rmax;
static integer lopt, itmp1, i, j, indee;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
static char order[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static logical lower, wantz;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static integer jj;
extern doublereal dlamch_(char *);
static logical alleig, indeig;
static integer iscale, indibl;
static logical valeig;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
static doublereal abstll, bignum;
extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
static integer indiwk, indisp, indtau;
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), dstebz_(char *, char *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
static integer indrwk, indwrk;
extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublecomplex *,
doublecomplex *, integer *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
static integer llwork, nsplit;
static doublereal smlnum;
extern /* Subroutine */ int zstein_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublecomplex *,
integer *, doublereal *, integer *, integer *, integer *),
zsteqr_(char *, integer *, doublereal *, doublereal *,
doublecomplex *, integer *, doublereal *, integer *),
zungtr_(char *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *),
zunmtr_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *);
static doublereal eps, vll, vuu, tmp1;
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define IFAIL(I) ifail[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
lower = lsame_(uplo, "L");
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (valeig && *n > 0 && *vu <= *vl) {
*info = -8;
} else if (indeig && *il < 1) {
*info = -9;
} else if (indeig && (*iu < min(*n,*il) || *iu > *n)) {
*info = -10;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -15;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 1) - 1;
if (*lwork < max(i__1,i__2)) {
*info = -17;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHEEVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
WORK(1).r = 1., WORK(1).i = 0.;
return 0;
}
if (*n == 1) {
WORK(1).r = 1., WORK(1).i = 0.;
if (alleig || indeig) {
*m = 1;
i__1 = a_dim1 + 1;
W(1) = A(1,1).r;
} else if (valeig) {
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
if (*vl < A(1,1).r && *vu >= A(1,1).r) {
*m = 1;
i__1 = a_dim1 + 1;
W(1) = A(1,1).r;
}
}
if (wantz) {
i__1 = z_dim1 + 1;
Z(1,1).r = 1., Z(1,1).i = 0.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
}
anrm = zlanhe_("M", uplo, n, &A(1,1), lda, &RWORK(1));
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
i__2 = *n - j + 1;
zdscal_(&i__2, &sigma, &A(j,j), &c__1);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
zdscal_(&j, &sigma, &A(1,j), &c__1);
/* L20: */
}
}
if (*abstol > 0.) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indrwk = inde + *n;
indtau = 1;
indwrk = indtau + *n;
llwork = *lwork - indwrk + 1;
zhetrd_(uplo, n, &A(1,1), lda, &RWORK(indd), &RWORK(inde), &WORK(
indtau), &WORK(indwrk), &llwork, &iinfo);
i__1 = indwrk;
z__1.r = *n + WORK(indwrk).r, z__1.i = WORK(indwrk).i;
lopt = (integer) z__1.r;
/* If all eigenvalues are desired and ABSTOL is less than or equal to
zero, then call DSTERF or ZUNGTR and ZSTEQR. If this fails for
some eigenvalue, then try DSTEBZ. */
if ((alleig || indeig && *il == 1 && *iu == *n) && *abstol <= 0.) {
dcopy_(n, &RWORK(indd), &c__1, &W(1), &c__1);
indee = indrwk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
dcopy_(&i__1, &RWORK(inde), &c__1, &RWORK(indee), &c__1);
dsterf_(n, &W(1), &RWORK(indee), info);
} else {
zlacpy_("A", n, n, &A(1,1), lda, &Z(1,1), ldz);
zungtr_(uplo, n, &Z(1,1), ldz, &WORK(indtau), &WORK(indwrk),
&llwork, &iinfo);
i__1 = *n - 1;
dcopy_(&i__1, &RWORK(inde), &c__1, &RWORK(indee), &c__1);
zsteqr_(jobz, n, &W(1), &RWORK(indee), &Z(1,1), ldz, &RWORK(
indrwk), info);
if (*info == 0) {
i__1 = *n;
for (i = 1; i <= *n; ++i) {
IFAIL(i) = 0;
/* L30: */
}
}
}
if (*info == 0) {
*m = *n;
goto L40;
}
*info = 0;
}
/* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwk = indisp + *n;
dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &RWORK(indd), &
RWORK(inde), m, &nsplit, &W(1), &IWORK(indibl), &IWORK(indisp), &
RWORK(indrwk), &IWORK(indiwk), info);
if (wantz) {
zstein_(n, &RWORK(indd), &RWORK(inde), m, &W(1), &IWORK(indibl), &
IWORK(indisp), &Z(1,1), ldz, &RWORK(indrwk), &IWORK(
indiwk), &IFAIL(1), info);
/* Apply unitary matrix used in reduction to tridiagonal
form to eigenvectors returned by ZSTEIN. */
zunmtr_("L", uplo, "N", n, m, &A(1,1), lda, &WORK(indtau), &Z(1,1), ldz, &WORK(indwrk), &llwork, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L40:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &W(1), &c__1);
}
/* If eigenvalues are not in order, then sort them, along with
eigenvectors. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= *m-1; ++j) {
i = 0;
tmp1 = W(j);
i__2 = *m;
for (jj = j + 1; jj <= *m; ++jj) {
if (W(jj) < tmp1) {
i = jj;
tmp1 = W(jj);
}
/* L50: */
}
if (i != 0) {
itmp1 = IWORK(indibl + i - 1);
W(i) = W(j);
IWORK(indibl + i - 1) = IWORK(indibl + j - 1);
W(j) = tmp1;
IWORK(indibl + j - 1) = itmp1;
zswap_(n, &Z(1,i), &c__1, &Z(1,j), &
c__1);
if (*info != 0) {
itmp1 = IFAIL(i);
IFAIL(i) = IFAIL(j);
IFAIL(j) = itmp1;
}
}
/* L60: */
}
}
/* Set WORK(1) to optimal complex workspace size.
Computing MAX */
i__1 = (*n << 1) - 1;
d__1 = (doublereal) max(i__1,lopt);
WORK(1).r = d__1, WORK(1).i = 0.;
return 0;
/* End of ZHEEVX */
} /* zheevx_ */
/* Subroutine */ int zpst01_(char *uplo, integer *n, doublecomplex *a,
integer *lda, doublecomplex *afac, integer *ldafac, doublecomplex *
perm, integer *ldperm, integer *piv, doublereal *rwork, doublereal *
resid, integer *rank)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, perm_dim1, perm_offset,
i__1, i__2, i__3, i__4, i__5;
doublereal d__1;
doublecomplex z__1;
/* Local variables */
integer i__, j, k;
doublecomplex tc;
doublereal tr, eps;
doublereal anorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZPST01 reconstructs an Hermitian positive semidefinite matrix A */
/* from its L or U factors and the permutation matrix P and computes */
/* the residual */
/* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or */
/* norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon, L' is the conjugate transpose of L, */
/* and U' is the conjugate transpose of U. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX*16 array, dimension (LDA,N) */
/* The original Hermitian matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AFAC (input) COMPLEX*16 array, dimension (LDAFAC,N) */
/* The factor L or U from the L*L' or U'*U */
/* factorization of A. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
/* PERM (output) COMPLEX*16 array, dimension (LDPERM,N) */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference P*L*L'*P' - A (or P*U'*U*P' - A) */
/* LDPERM (input) INTEGER */
/* The leading dimension of the array PERM. */
/* LDAPERM >= max(1,N). */
/* PIV (input) INTEGER array, dimension (N) */
/* PIV is such that the nonzero entries are */
/* P( PIV( K ), K ) = 1. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RESID (output) DOUBLE PRECISION */
/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
perm_dim1 = *ldperm;
perm_offset = 1 + perm_dim1;
perm -= perm_offset;
--piv;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
anorm = zlanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Check the imaginary parts of the diagonal elements and return with */
/* an error code if any are nonzero. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (d_imag(&afac[j + j * afac_dim1]) != 0.) {
*resid = 1. / eps;
return 0;
}
/* L100: */
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = *rank + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
afac[i__3].r = 0., afac[i__3].i = 0.;
/* L110: */
}
/* L120: */
}
}
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
zdotc_(&z__1, &k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
afac_dim1 + 1], &c__1);
tr = z__1.r;
i__1 = k + k * afac_dim1;
afac[i__1].r = tr, afac[i__1].i = 0.;
/* Compute the rest of column K. */
i__1 = k - 1;
ztrmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[afac_offset]
, ldafac, &afac[k * afac_dim1 + 1], &c__1);
/* L130: */
}
/* Compute the product L*L', overwriting L. */
} else {
if (*rank < *n) {
i__1 = *n;
for (j = *rank + 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
afac[i__3].r = 0., afac[i__3].i = 0.;
/* L140: */
}
/* L150: */
}
}
for (k = *n; k >= 1; --k) {
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (k + 1 <= *n) {
i__1 = *n - k;
zher_("Lower", &i__1, &c_b20, &afac[k + 1 + k * afac_dim1], &
c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
}
/* Scale column K by the diagonal element. */
i__1 = k + k * afac_dim1;
tc.r = afac[i__1].r, tc.i = afac[i__1].i;
i__1 = *n - k + 1;
zscal_(&i__1, &tc, &afac[k + k * afac_dim1], &c__1);
/* L160: */
}
}
/* Form P*L*L'*P' or P*U'*U*P' */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] <= piv[j]) {
if (i__ <= j) {
i__3 = piv[i__] + piv[j] * perm_dim1;
i__4 = i__ + j * afac_dim1;
perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
.i;
} else {
i__3 = piv[i__] + piv[j] * perm_dim1;
d_cnjg(&z__1, &afac[j + i__ * afac_dim1]);
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
}
}
/* L170: */
}
/* L180: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (piv[i__] >= piv[j]) {
if (i__ >= j) {
i__3 = piv[i__] + piv[j] * perm_dim1;
i__4 = i__ + j * afac_dim1;
perm[i__3].r = afac[i__4].r, perm[i__3].i = afac[i__4]
.i;
} else {
i__3 = piv[i__] + piv[j] * perm_dim1;
d_cnjg(&z__1, &afac[j + i__ * afac_dim1]);
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
}
}
/* L190: */
}
/* L200: */
}
}
/* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * perm_dim1;
i__4 = i__ + j * perm_dim1;
i__5 = i__ + j * a_dim1;
z__1.r = perm[i__4].r - a[i__5].r, z__1.i = perm[i__4].i - a[
i__5].i;
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
/* L210: */
}
i__2 = j + j * perm_dim1;
i__3 = j + j * perm_dim1;
i__4 = j + j * a_dim1;
d__1 = a[i__4].r;
z__1.r = perm[i__3].r - d__1, z__1.i = perm[i__3].i;
perm[i__2].r = z__1.r, perm[i__2].i = z__1.i;
/* L220: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * perm_dim1;
i__3 = j + j * perm_dim1;
i__4 = j + j * a_dim1;
d__1 = a[i__4].r;
z__1.r = perm[i__3].r - d__1, z__1.i = perm[i__3].i;
perm[i__2].r = z__1.r, perm[i__2].i = z__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * perm_dim1;
i__4 = i__ + j * perm_dim1;
i__5 = i__ + j * a_dim1;
z__1.r = perm[i__4].r - a[i__5].r, z__1.i = perm[i__4].i - a[
i__5].i;
perm[i__3].r = z__1.r, perm[i__3].i = z__1.i;
/* L230: */
}
/* L240: */
}
}
/* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or */
/* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). */
*resid = zlanhe_("1", uplo, n, &perm[perm_offset], ldafac, &rwork[1]);
*resid = *resid / (doublereal) (*n) / anorm / eps;
return 0;
/* End of ZPST01 */
} /* zpst01_ */
/* Subroutine */ int zheevd_(char *jobz, char *uplo, integer *n,
doublecomplex *a, integer *lda, doublereal *w, doublecomplex *work,
integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork,
integer *liwork, integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a
complex Hermitian matrix A. If eigenvectors are desired, it uses a
divide and conquer algorithm.
The divide and conquer algorithm makes very mild assumptions about
floating point arithmetic. It will work on machines with a guard
digit in add/subtract, or on those binary machines without guard
digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
Cray-2. It could conceivably fail on hexadecimal or decimal machines
without guard digits, but we know of none.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX*16 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
orthonormal eigenvectors of the matrix A.
If JOBZ = 'N', then 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).
W (output) DOUBLE PRECISION array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
On exit, if LWORK > 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of the array WORK.
If N <= 1, LWORK must be at least 1.
If JOBZ = 'N' and N > 1, LWORK must be at least N + 1.
If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2.
RWORK (workspace/output) DOUBLE PRECISION array,
dimension (LRWORK)
On exit, if LRWORK > 0, RWORK(1) returns the optimal LRWORK.
LRWORK (input) INTEGER
The dimension of the array RWORK.
If N <= 1, LRWORK must be at least 1.
If JOBZ = 'N' and N > 1, LRWORK must be at least N.
If JOBZ = 'V' and N > 1, LRWORK must be at least
1 + 4*N + 2*N*lg N + 3*N**2 ,
where lg( N ) = smallest integer k such
that 2**k >= N .
IWORK (workspace/output) INTEGER array, dimension (LIWORK)
On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.
LIWORK (input) INTEGER
The dimension of the array IWORK.
If N <= 1, LIWORK must be at least 1.
If JOBZ = 'N' and N > 1, LIWORK must be at least 1.
If JOBZ = 'V' and N > 1, LIWORK must be at least 2 + 5*N.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the algorithm failed to converge; i
off-diagonal elements of an intermediate tridiagonal
form did not converge to zero.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__2 = 2;
static integer c__0 = 0;
static doublereal c_b16 = 1.;
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
/* Builtin functions */
double log(doublereal);
integer pow_ii(integer *, integer *);
double sqrt(doublereal);
/* Local variables */
static integer inde;
static doublereal anrm;
static integer imax;
static doublereal rmin, rmax;
static integer lopt;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *);
static integer iinfo, lwmin, liopt;
static logical lower;
static integer llrwk, lropt;
static logical wantz;
static integer indwk2, llwrk2;
extern doublereal dlamch_(char *);
static integer iscale;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal bignum;
extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
static integer indtau;
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), zlascl_(char *, integer *, integer *, doublereal *,
doublereal *, integer *, integer *, doublecomplex *, integer *,
integer *), zstedc_(char *, integer *, doublereal *,
doublereal *, doublecomplex *, integer *, doublecomplex *,
integer *, doublereal *, integer *, integer *, integer *, integer
*);
static integer indrwk, indwrk, liwmin;
extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublecomplex *,
doublecomplex *, integer *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
static integer lrwmin, llwork;
static doublereal smlnum;
extern /* Subroutine */ int zunmtr_(char *, char *, char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
static integer lgn;
static doublereal eps;
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
wantz = lsame_(jobz, "V");
lower = lsame_(uplo, "L");
*info = 0;
if (*n <= 1) {
lgn = 0;
lwmin = 1;
lrwmin = 1;
liwmin = 1;
lopt = lwmin;
lropt = lrwmin;
liopt = liwmin;
} else {
lgn = (integer) (log((doublereal) (*n)) / log(2.));
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (pow_ii(&c__2, &lgn) < *n) {
++lgn;
}
if (wantz) {
lwmin = (*n << 1) + *n * *n;
/* Computing 2nd power */
i__1 = *n;
lrwmin = (*n << 2) + 1 + (*n << 1) * lgn + i__1 * i__1 * 3;
liwmin = *n * 5 + 2;
} else {
lwmin = *n + 1;
lrwmin = *n;
liwmin = 1;
}
lopt = lwmin;
lropt = lrwmin;
liopt = liwmin;
}
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*lwork < lwmin) {
*info = -8;
} else if (*lrwork < lrwmin) {
*info = -10;
} else if (*liwork < liwmin) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHEEVD ", &i__1);
goto L10;
}
/* Quick return if possible */
if (*n == 0) {
goto L10;
}
if (*n == 1) {
i__1 = a_dim1 + 1;
W(1) = A(1,1).r;
if (wantz) {
i__1 = a_dim1 + 1;
A(1,1).r = 1., A(1,1).i = 0.;
}
goto L10;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = zlanhe_("M", uplo, n, &A(1,1), lda, &RWORK(1));
iscale = 0;
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
zlascl_(uplo, &c__0, &c__0, &c_b16, &sigma, n, n, &A(1,1), lda,
info);
}
/* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */
inde = 1;
indtau = 1;
indwrk = indtau + *n;
indrwk = inde + *n;
indwk2 = indwrk + *n * *n;
llwork = *lwork - indwrk + 1;
llwrk2 = *lwork - indwk2 + 1;
llrwk = *lrwork - indrwk + 1;
zhetrd_(uplo, n, &A(1,1), lda, &W(1), &RWORK(inde), &WORK(indtau), &
WORK(indwrk), &llwork, &iinfo);
/* Computing MAX */
i__1 = indwrk;
d__1 = (doublereal) lopt, d__2 = (doublereal) (*n) + WORK(indwrk).r;
lopt = (integer) max(d__1,d__2);
/* For eigenvalues only, call DSTERF. For eigenvectors, first call
ZSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
tridiagonal matrix, then call ZUNMTR to multiply it to the
Householder transformations represented as Householder vectors in
A. */
if (! wantz) {
dsterf_(n, &W(1), &RWORK(inde), info);
} else {
zstedc_("I", n, &W(1), &RWORK(inde), &WORK(indwrk), n, &WORK(indwk2),
&llwrk2, &RWORK(indrwk), &llrwk, &IWORK(1), liwork, info);
zunmtr_("L", uplo, "N", n, n, &A(1,1), lda, &WORK(indtau), &WORK(
indwrk), n, &WORK(indwk2), &llwrk2, &iinfo);
zlacpy_("A", n, n, &WORK(indwrk), n, &A(1,1), lda);
/* Computing MAX
Computing 2nd power */
i__3 = *n;
i__4 = indwk2;
i__1 = lopt, i__2 = *n + i__3 * i__3 + (integer) WORK(indwk2).r;
lopt = max(i__1,i__2);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &W(1), &c__1);
}
L10:
if (*lwork > 0) {
WORK(1).r = (doublereal) lopt, WORK(1).i = 0.;
}
if (*lrwork > 0) {
RWORK(1) = (doublereal) lropt;
}
if (*liwork > 0) {
IWORK(1) = liopt;
}
return 0;
/* End of ZHEEVD */
} /* zheevd_ */
