/* Subroutine */ int dstt21_(integer *n, integer *kband, doublereal *ad,
doublereal *ae, doublereal *sd, doublereal *se, doublereal *u,
integer *ldu, doublereal *work, doublereal *result)
{
/* System generated locals */
integer u_dim1, u_offset, i__1;
doublereal d__1, d__2, d__3;
/* Local variables */
static doublereal unfl;
extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static doublereal temp1, temp2;
extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
static integer j;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static doublereal anorm, wnorm;
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
static doublereal ulp;
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
/* -- 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
=======
DSTT21 checks a decomposition of the form
A = U S U'
where ' means transpose, A is symmetric tridiagonal, U is orthogonal,
and S is diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1).
Two tests are performed:
RESULT(1) = | A - U S U' | / ( |A| n ulp )
RESULT(2) = | I - UU' | / ( n ulp )
Arguments
=========
N (input) INTEGER
The size of the matrix. If it is zero, DSTT21 does nothing.
It must be at least zero.
KBAND (input) INTEGER
The bandwidth of the matrix S. It may only be zero or one.
If zero, then S is diagonal, and SE is not referenced. If
one, then S is symmetric tri-diagonal.
AD (input) DOUBLE PRECISION array, dimension (N)
The diagonal of the original (unfactored) matrix A. A is
assumed to be symmetric tridiagonal.
AE (input) DOUBLE PRECISION array, dimension (N-1)
The off-diagonal of the original (unfactored) matrix A. A
is assumed to be symmetric tridiagonal. AE(1) is the (1,2)
and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc.
SD (input) DOUBLE PRECISION array, dimension (N)
The diagonal of the (symmetric tri-) diagonal matrix S.
SE (input) DOUBLE PRECISION array, dimension (N-1)
The off-diagonal of the (symmetric tri-) diagonal matrix S.
Not referenced if KBSND=0. If KBAND=1, then AE(1) is the
(1,2) and (2,1) element, SE(2) is the (2,3) and (3,2)
element, etc.
U (input) DOUBLE PRECISION array, dimension (LDU, N)
The orthogonal matrix in the decomposition.
LDU (input) INTEGER
The leading dimension of U. LDU must be at least N.
WORK (workspace) DOUBLE PRECISION array, dimension (N*(N+1))
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.
=====================================================================
1) Constants
Parameter adjustments */
--ad;
--ae;
--sd;
--se;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
--work;
--result;
/* Function Body */
result[1] = 0.;
result[2] = 0.;
if (*n <= 0) {
return 0;
}
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Precision");
/* Do Test 1
Copy A & Compute its 1-Norm: */
dlaset_("Full", n, n, &c_b5, &c_b5, &work[1], n);
anorm = 0.;
temp1 = 0.;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
work[(*n + 1) * (j - 1) + 1] = ad[j];
work[(*n + 1) * (j - 1) + 2] = ae[j];
temp2 = (d__1 = ae[j], abs(d__1));
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = ad[j], abs(d__1)) + temp1 + temp2;
anorm = max(d__2,d__3);
temp1 = temp2;
/* L10: */
}
/* Computing 2nd power */
i__1 = *n;
work[i__1 * i__1] = ad[*n];
/* Computing MAX */
d__2 = anorm, d__3 = (d__1 = ad[*n], abs(d__1)) + temp1, d__2 = max(d__2,
d__3);
anorm = max(d__2,unfl);
/* Norm of A - USU' */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
d__1 = -sd[j];
dsyr_("L", n, &d__1, &u_ref(1, j), &c__1, &work[1], n);
/* L20: */
}
if (*n > 1 && *kband == 1) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
d__1 = -se[j];
dsyr2_("L", n, &d__1, &u_ref(1, j), &c__1, &u_ref(1, j + 1), &
c__1, &work[1], n);
/* L30: */
}
}
/* Computing 2nd power */
i__1 = *n;
wnorm = dlansy_("1", "L", n, &work[1], n, &work[i__1 * i__1 + 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 */
dgemm_("N", "C", n, n, n, &c_b19, &u[u_offset], ldu, &u[u_offset], ldu, &
c_b5, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
work[(*n + 1) * (j - 1) + 1] += -1.;
/* L40: */
}
/* Computing MIN
Computing 2nd power */
i__1 = *n;
d__1 = (doublereal) (*n), d__2 = dlange_("1", n, n, &work[1], n, &work[
i__1 * i__1 + 1]);
result[2] = min(d__1,d__2) / (*n * ulp);
return 0;
/* End of DSTT21 */
} /* dstt21_ */
/* Subroutine */ int dchkpo_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
doublereal *afac, doublereal *ainv, doublereal *b, doublereal *x,
doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"=\002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, 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;
extern /* Subroutine */ int alahd_(integer *, char *), dget04_(
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
doublereal rcond;
extern /* Subroutine */ int dpot01_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
integer nimat;
extern /* Subroutine */ int dpot02_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *), dpot03_(char *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *), dpot05_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *);
doublereal anorm;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), alaerh_(char *,
char *, integer *, integer *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *);
doublereal rcondc;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), alasum_(char *,
integer *, integer *, integer *, integer *);
doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *), dpocon_(char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int derrpo_(char *, integer *), dporfs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *), dpotrf_(char *, integer *, doublereal *, integer *,
integer *), xlaenv_(integer *, integer *), dpotri_(char *,
integer *, doublereal *, integer *, integer *), dpotrs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, integer *);
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 */
/* ======= */
/* DCHKPO tests DPOTRF, -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) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* where NSMAX is the largest entry in NSVAL. */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NSMAX)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension */
/* (max(NMAX,2*NSMAX)) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
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) {
derrpo_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
/* 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 DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)6, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &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__) {
a[ioff + i__] = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L50: */
}
}
} else {
izero = 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. */
dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
s_copy(srnamc_1.srnamt, "DPOTRF", (ftnlen)6, (ftnlen)6);
dpotrf_(uplo, &n, &afac[1], &lda, &info);
/* Check error code from DPOTRF. */
if (info != izero) {
alaerh_(path, "DPOTRF", &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. */
dlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
dpot01_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &rwork[1],
result);
/* + TEST 2 */
/* Form the inverse and compute the residual. */
dlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "DPOTRI", (ftnlen)6, (ftnlen)6);
dpotri_(uplo, &n, &ainv[1], &lda, &info);
/* Check error code from DPOTRI. */
if (info != 0) {
alaerh_(path, "DPOTRI", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
dpot03_(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, "DLARHS", (ftnlen)6, (ftnlen)
6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "DPOTRS", (ftnlen)6, (ftnlen)
6);
dpotrs_(uplo, &n, &nrhs, &afac[1], &lda, &x[1], &lda,
&info);
/* Check error code from DPOTRS. */
if (info != 0) {
alaerh_(path, "DPOTRS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
lda);
dpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[2]);
/* + TEST 4 */
/* Check solution from generated exact solution. */
dget04_(&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, "DPORFS", (ftnlen)6, (ftnlen)
6);
dporfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
&b[1], &lda, &x[1], &lda, &rwork[1], &rwork[
nrhs + 1], &work[1], &iwork[1], &info);
/* Check error code from DPORFS. */
if (info != 0) {
alaerh_(path, "DPORFS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
dpot05_(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 = dlansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
s_copy(srnamc_1.srnamt, "DPOCON", (ftnlen)6, (ftnlen)6);
dpocon_(uplo, &n, &afac[1], &lda, &anorm, &rcond, &work[1]
, &iwork[1], &info);
/* Check error code from DPOCON. */
if (info != 0) {
alaerh_(path, "DPOCON", &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 DCHKPO */
} /* dchkpo_ */
/* Subroutine */ int dqlt01_(integer *m, integer *n, doublereal *a,
doublereal *af, doublereal *q, doublereal *l, integer *lda,
doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1, i__2;
/* Local variables */
doublereal eps;
integer info;
doublereal resid, anorm;
integer minmn;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DQLT01 tests DGEQLF, which computes the QL factorization of an m-by-n */
/* matrix A, and partially tests DORGQL which forms the m-by-m */
/* orthogonal matrix Q. */
/* DQLT01 compares L with Q'*A, and checks that Q is orthogonal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The m-by-n matrix A. */
/* AF (output) DOUBLE PRECISION array, dimension (LDA,N) */
/* Details of the QL factorization of A, as returned by DGEQLF. */
/* See DGEQLF for further details. */
/* Q (output) DOUBLE PRECISION array, dimension (LDA,M) */
/* The m-by-m orthogonal matrix Q. */
/* L (workspace) DOUBLE PRECISION array, dimension (LDA,max(M,N)) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and R. */
/* LDA >= max(M,N). */
/* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by DGEQLF. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* The test ratios: */
/* RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q'*Q ) / ( M * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
minmn = min(*m,*n);
eps = dlamch_("Epsilon");
/* Copy the matrix A to the array AF. */
dlacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
/* Factorize the matrix A in the array AF. */
s_copy(srnamc_1.srnamt, "DGEQLF", (ftnlen)32, (ftnlen)6);
dgeqlf_(m, n, &af[af_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy details of Q */
dlaset_("Full", m, m, &c_b6, &c_b6, &q[q_offset], lda);
if (*m >= *n) {
if (*n < *m && *n > 0) {
i__1 = *m - *n;
dlacpy_("Full", &i__1, n, &af[af_offset], lda, &q[(*m - *n + 1) *
q_dim1 + 1], lda);
}
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
dlacpy_("Upper", &i__1, &i__2, &af[*m - *n + 1 + (af_dim1 << 1)],
lda, &q[*m - *n + 1 + (*m - *n + 2) * q_dim1], lda);
}
} else {
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
dlacpy_("Upper", &i__1, &i__2, &af[(*n - *m + 2) * af_dim1 + 1],
lda, &q[(q_dim1 << 1) + 1], lda);
}
}
/* Generate the m-by-m matrix Q */
s_copy(srnamc_1.srnamt, "DORGQL", (ftnlen)32, (ftnlen)6);
dorgql_(m, m, &minmn, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L */
dlaset_("Full", m, n, &c_b13, &c_b13, &l[l_offset], lda);
if (*m >= *n) {
if (*n > 0) {
dlacpy_("Lower", n, n, &af[*m - *n + 1 + af_dim1], lda, &l[*m - *
n + 1 + l_dim1], lda);
}
} else {
if (*n > *m && *m > 0) {
i__1 = *n - *m;
dlacpy_("Full", m, &i__1, &af[af_offset], lda, &l[l_offset], lda);
}
if (*m > 0) {
dlacpy_("Lower", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &l[(
*n - *m + 1) * l_dim1 + 1], lda);
}
}
/* Compute L - Q'*A */
dgemm_("Transpose", "No transpose", m, n, m, &c_b20, &q[q_offset], lda, &
a[a_offset], lda, &c_b21, &l[l_offset], lda);
/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
anorm = dlange_("1", m, n, &a[a_offset], lda, &rwork[1]);
resid = dlange_("1", m, n, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*m) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q'*Q */
dlaset_("Full", m, m, &c_b13, &c_b21, &l[l_offset], lda);
dsyrk_("Upper", "Transpose", m, m, &c_b20, &q[q_offset], lda, &c_b21, &l[
l_offset], lda);
/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
resid = dlansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*m) / eps;
return 0;
/* End of DQLT01 */
} /* dqlt01_ */
/* Subroutine */ int dpot02_(char *uplo, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *x, integer *ldx, doublereal *
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;
/* Local variables */
static integer j;
extern doublereal dasum_(integer *, doublereal *, integer *);
static doublereal anorm, bnorm;
extern /* Subroutine */ int dsymm_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
static doublereal xnorm;
extern doublereal dlamch_(char *), dlansy_(char *, char *,
integer *, doublereal *, integer *, doublereal *);
static doublereal eps;
#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DPOT02 computes the residual for the solution of a symmetric system
of linear equations A*x = b:
RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ),
where EPS is the machine epsilon.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
symmetric matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The number of rows and columns of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of columns of B, the matrix of right hand sides.
NRHS >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
The original symmetric matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N)
X (input) DOUBLE PRECISION 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) DOUBLE PRECISION 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 ).
=====================================================================
Quick exit if N = 0 or NRHS = 0.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--rwork;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = dlamch_("Epsilon");
anorm = dlansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Compute B - A*X */
dsymm_("Left", uplo, n, nrhs, &c_b5, &a[a_offset], lda, &x[x_offset], ldx,
&c_b6, &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 = dasum_(n, &b_ref(1, j), &c__1);
xnorm = dasum_(n, &x_ref(1, j), &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 DPOT02 */
} /* dpot02_ */
/* Subroutine */ int dposvx_(char *fact, char *uplo, integer *n, integer *
nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
char *equed, doublereal *s, doublereal *b, integer *ldb, doublereal *
x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *
berr, doublereal *work, integer *iwork, 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;
doublereal d__1, d__2;
/* Local variables */
integer i__, j;
doublereal amax, smin, smax;
doublereal scond, anorm;
logical equil, rcequ;
logical nofact;
doublereal bignum;
integer infequ;
doublereal smlnum;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to */
/* compute the solution to a real system of linear equations */
/* A * X = B, */
/* where A is an N-by-N symmetric positive definite matrix and X and B */
/* are N-by-NRHS matrices. */
/* 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**T* U, if UPLO = 'U', or */
/* A = L * L**T, if UPLO = 'L', */
/* where U is an upper triangular matrix and L is a lower triangular */
/* matrix. */
/* 3. If the leading i-by-i principal minor is not positive definite, */
/* then the routine returns with INFO = i. Otherwise, the factored */
/* form of A is used to estimate the condition number of the matrix */
/* A. 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) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the symmetric matrix A, except if FACT = 'F' and */
/* EQUED = 'Y', then A must contain the equilibrated matrix */
/* diag(S)*A*diag(S). If UPLO = 'U', the leading */
/* N-by-N upper triangular part of A contains the upper */
/* triangular part of the matrix A, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading N-by-N lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. A is not modified if */
/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
/* diag(S)*A*diag(S). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */
/* If FACT = 'F', then AF is an input argument and on entry */
/* contains the triangular factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T, in the same storage */
/* format as A. If EQUED .ne. 'N', then AF is the factored form */
/* of the equilibrated matrix diag(S)*A*diag(S). */
/* If FACT = 'N', then AF is an output argument and on exit */
/* returns the triangular factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T of the original */
/* matrix A. */
/* If FACT = 'E', then AF is an output argument and on exit */
/* returns the triangular factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T of the equilibrated */
/* matrix A (see the description of A for the form of the */
/* equilibrated matrix). */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* EQUED (input or output) CHARACTER*1 */
/* Specifies the form of equilibration that was done. */
/* = 'N': No equilibration (always true if FACT = 'N'). */
/* = 'Y': 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) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS right hand side matrix B. */
/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
/* B is overwritten by diag(S) * B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (3*N) */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, and i is */
/* <= N: the leading minor of order i of A is */
/* not positive definite, so the factorization */
/* could not be completed, and the solution has not */
/* been computed. RCOND = 0 is returned. */
/* = N+1: U is nonsingular, but RCOND is less than machine */
/* precision, meaning that the matrix is singular */
/* to working precision. Nevertheless, the */
/* solution and error bounds are computed because */
/* there are a number of situations where the */
/* computed solution can be more accurate than the */
/* value of RCOND would suggest. */
/* ===================================================================== */
/* Parameter adjustments */
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;
--iwork;
/* 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];
smin = min(d__1,d__2);
/* Computing MAX */
d__1 = smax, d__2 = s[j];
smax = max(d__1,d__2);
}
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_("DPOSVX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
dpoequ_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
dlaqsy_(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__) {
b[i__ + j * b_dim1] = s[i__] * b[i__ + j * b_dim1];
}
}
}
if (nofact || equil) {
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
dlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
dpotrf_(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 = dlansy_("1", uplo, n, &a[a_offset], lda, &work[1]);
/* Compute the reciprocal of the condition number of A. */
dpocon_(uplo, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &iwork[1],
info);
/* Compute the solution matrix X. */
dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
dpotrs_(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. */
dporfs_(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], &
iwork[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__) {
x[i__ + j * x_dim1] = s[i__] * x[i__ + j * x_dim1];
}
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= scond;
}
}
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon")) {
*info = *n + 1;
}
return 0;
/* End of DPOSVX */
} /* dposvx_ */
int dsyevx_(char *jobz, char *range, char *uplo, int *n,
double *a, int *lda, double *vl, double *vu, int *
il, int *iu, double *abstol, int *m, double *w,
double *z__, int *ldz, double *work, int *lwork,
int *iwork, int *ifail, int *info)
{
/* System generated locals */
int a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
double d__1, d__2;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int i__, j, nb, jj;
double eps, vll, vuu, tmp1;
int indd, inde;
double anrm;
int imax;
double rmin, rmax;
int test;
int itmp1, indee;
extern int dscal_(int *, double *, double *,
int *);
double sigma;
extern int lsame_(char *, char *);
int iinfo;
char order[1];
extern int dcopy_(int *, double *, int *,
double *, int *), dswap_(int *, double *, int
*, double *, int *);
int lower, wantz;
extern double dlamch_(char *);
int alleig, indeig;
int iscale, indibl;
int valeig;
extern int dlacpy_(char *, int *, int *,
double *, int *, double *, int *);
double safmin;
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
extern int xerbla_(char *, int *);
double abstll, bignum;
int indtau, indisp;
extern int dstein_(int *, double *, double *,
int *, double *, int *, int *, double *,
int *, double *, int *, int *, int *),
dsterf_(int *, double *, double *, int *);
int indiwo, indwkn;
extern double dlansy_(char *, char *, int *, double *,
int *, double *);
extern int dstebz_(char *, char *, int *, double
*, double *, int *, int *, double *, double *,
double *, int *, int *, double *, int *,
int *, double *, int *, int *);
int indwrk, lwkmin;
extern int dorgtr_(char *, int *, double *,
int *, double *, double *, int *, int *), dsteqr_(char *, int *, double *, double *,
double *, int *, double *, int *),
dormtr_(char *, char *, char *, int *, int *, double *
, int *, double *, double *, int *, double *,
int *, int *);
int llwrkn, llwork, nsplit;
double smlnum;
extern int dsytrd_(char *, int *, double *,
int *, double *, double *, double *, double *,
int *, int *);
int lwkopt;
int lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSYEVX computes selected eigenvalues and, optionally, eigenvectors */
/* of a float symmetric 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) DOUBLE PRECISION array, dimension (LDA, N) */
/* On entry, 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. 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 >= 1, when N <= 1; */
/* otherwise 8*N. */
/* For optimal efficiency, LWORK >= (NB+3)*N, */
/* where NB is the max of the blocksize for DSYTRD and DORMTR */
/* 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. */
/* 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. */
/* ===================================================================== */
/* .. 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;
--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] = (double) lwkmin;
} else {
lwkmin = *n << 3;
nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1,
&c_n1);
nb = MAX(i__1,i__2);
/* Computing MAX */
i__1 = lwkmin, i__2 = (nb + 3) * *n;
lwkopt = MAX(i__1,i__2);
work[1] = (double) lwkopt;
}
if (*lwork < lwkmin && ! lquery) {
*info = -17;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYEVX", &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;
w[1] = a[a_dim1 + 1];
} else {
if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) {
*m = 1;
w[1] = a[a_dim1 + 1];
}
}
if (wantz) {
z__[z_dim1 + 1] = 1.;
}
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 = dlansy_("M", uplo, n, &a[a_offset], lda, &work[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;
dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dscal_(&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 DSYTRD to reduce symmetric matrix to tridiagonal form. */
indtau = 1;
inde = indtau + *n;
indd = inde + *n;
indwrk = indd + *n;
llwork = *lwork - indwrk + 1;
dsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[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 DORGTR and SSTEQR. 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, &work[indd], &c__1, &w[1], &c__1);
indee = indwrk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsterf_(n, &w[1], &work[indee], info);
} else {
dlacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz);
dorgtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk]
, &llwork, &iinfo);
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
indwrk], 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, SSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwo = indisp + *n;
dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
indwrk], &iwork[indiwo], info);
if (wantz) {
dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
ifail[1], info);
/* Apply orthogonal matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by DSTEIN. */
indwkn = inde;
llwrkn = *lwork - indwkn + 1;
dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
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;
dswap_(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 workspace size. */
work[1] = (double) lwkopt;
return 0;
/* End of DSYEVX */
} /* dsyevx_ */
/* Subroutine */ int dsyev_(char *jobz, char *uplo, integer *n, doublereal *a,
integer *lda, doublereal *w, doublereal *work, integer *lwork,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer nb;
doublereal eps;
integer inde;
doublereal anrm;
integer imax;
doublereal rmin, rmax;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
doublereal sigma;
extern logical lsame_(char *, char *);
integer iinfo;
logical lower, wantz;
extern doublereal dlamch_(char *);
integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
doublereal safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal bignum;
integer indtau;
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
integer indwrk;
extern /* Subroutine */ int dorgtr_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *), dsteqr_(char *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *),
dsytrd_(char *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *);
integer llwork;
doublereal smlnum;
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSYEV computes all eigenvalues and, optionally, eigenvectors of a */
/* real symmetric 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) DOUBLE PRECISION array, dimension (LDA, N) */
/* On entry, 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. 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) DOUBLE PRECISION 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,3*N-1). */
/* For optimal efficiency, LWORK >= (NB+2)*N, */
/* where NB is the blocksize for DSYTRD 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. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the algorithm failed to converge; i */
/* off-diagonal elements of an intermediate tridiagonal */
/* form did not converge to zero. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
--work;
/* 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, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = 1, i__2 = (nb + 2) * *n;
lwkopt = max(i__1,i__2);
work[1] = (doublereal) lwkopt;
/* Computing MAX */
i__1 = 1, i__2 = *n * 3 - 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -8;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYEV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
w[1] = a[a_dim1 + 1];
work[1] = 2.;
if (wantz) {
a[a_dim1 + 1] = 1.;
}
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 = dlansy_("M", uplo, n, &a[a_offset], lda, &work[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) {
dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda,
info);
}
/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */
inde = 1;
indtau = inde + *n;
indwrk = indtau + *n;
llwork = *lwork - indwrk + 1;
dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], &
work[indwrk], &llwork, &iinfo);
/* For eigenvalues only, call DSTERF. For eigenvectors, first call */
/* DORGTR to generate the orthogonal matrix, then call DSTEQR. */
if (! wantz) {
dsterf_(n, &w[1], &work[inde], info);
} else {
dorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], &
llwork, &iinfo);
dsteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau],
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 workspace size. */
work[1] = (doublereal) lwkopt;
return 0;
/* End of DSYEV */
} /* dsyev_ */
/* Subroutine */ int dpot03_(char *uplo, integer *n, doublereal *a, integer *
lda, doublereal *ainv, integer *ldainv, doublereal *work, integer *
ldwork, doublereal *rwork, doublereal *rcond, doublereal *resid)
{
/* System generated locals */
integer a_dim1, a_offset, ainv_dim1, ainv_offset, work_dim1, work_offset,
i__1, i__2;
/* Local variables */
integer i__, j;
doublereal eps;
extern logical lsame_(char *, char *);
doublereal anorm;
extern /* Subroutine */ int dsymm_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
doublereal ainvnm;
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DPOT03 computes the residual for a symmetric matrix times its */
/* inverse: */
/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The original symmetric matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AINV (input/output) DOUBLE PRECISION array, dimension (LDAINV,N) */
/* On entry, the inverse of the matrix A, stored as a symmetric */
/* matrix in the same format as A. */
/* In this version, AINV is expanded into a full matrix and */
/* multiplied by A, so the opposing triangle of AINV will be */
/* changed; i.e., if the upper triangular part of AINV is */
/* stored, the lower triangular part will be used as work space. */
/* LDAINV (input) INTEGER */
/* The leading dimension of the array AINV. LDAINV >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N) */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (N) */
/* RCOND (output) DOUBLE PRECISION */
/* The reciprocal of the condition number of A, computed as */
/* ( 1/norm(A) ) / norm(AINV). */
/* RESID (output) DOUBLE PRECISION */
/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
ainv_dim1 = *ldainv;
ainv_offset = 1 + ainv_dim1;
ainv -= ainv_offset;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*rcond = 1.;
*resid = 0.;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
eps = dlamch_("Epsilon");
anorm = dlansy_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
ainvnm = dlansy_("1", uplo, n, &ainv[ainv_offset], ldainv, &rwork[1]);
if (anorm <= 0. || ainvnm <= 0.) {
*rcond = 0.;
*resid = 1. / eps;
return 0;
}
*rcond = 1. / anorm / ainvnm;
/* Expand AINV into a full matrix and call DSYMM to multiply */
/* AINV on the left by 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__) {
ainv[j + i__ * ainv_dim1] = ainv[i__ + j * ainv_dim1];
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
ainv[j + i__ * ainv_dim1] = ainv[i__ + j * ainv_dim1];
/* L30: */
}
/* L40: */
}
}
dsymm_("Left", uplo, n, n, &c_b11, &a[a_offset], lda, &ainv[ainv_offset],
ldainv, &c_b12, &work[work_offset], ldwork);
/* Add the identity matrix to WORK . */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__ + i__ * work_dim1] += 1.;
/* L50: */
}
/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
*resid = dlange_("1", n, n, &work[work_offset], ldwork, &rwork[1]);
*resid = *resid * *rcond / eps / (doublereal) (*n);
return 0;
/* End of DPOT03 */
} /* dpot03_ */
/* Subroutine */ int dsgt01_(integer *itype, char *uplo, integer *n, integer *
m, doublereal *a, integer *lda, doublereal *b, integer *ldb,
doublereal *z__, integer *ldz, doublereal *d__, doublereal *work,
doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1;
/* Local variables */
static integer i__;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal anorm;
extern /* Subroutine */ int dsymm_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *),
dlansy_(char *, char *, integer *, doublereal *, integer *,
doublereal *);
static doublereal ulp;
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
/* -- 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
modified August 1997, a new parameter M is added to the calling
sequence.
Purpose
=======
DDGT01 checks a decomposition of the form
A Z = B Z D or
A B Z = Z D or
B A Z = Z D
where A is a symmetric matrix, B is
symmetric positive definite, Z is orthogonal, and D is diagonal.
One of the following test ratios is computed:
ITYPE = 1: RESULT(1) = | A Z - B Z D | / ( |A| |Z| n ulp )
ITYPE = 2: RESULT(1) = | A B Z - Z D | / ( |A| |Z| n ulp )
ITYPE = 3: RESULT(1) = | B A Z - Z D | / ( |A| |Z| n ulp )
Arguments
=========
ITYPE (input) INTEGER
The form of the symmetric generalized eigenproblem.
= 1: A*z = (lambda)*B*z
= 2: A*B*z = (lambda)*z
= 3: B*A*z = (lambda)*z
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
symmetric matrices A and B is stored.
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
M (input) INTEGER
The number of eigenvalues found. 0 <= M <= N.
A (input) DOUBLE PRECISION array, dimension (LDA, N)
The original symmetric matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input) DOUBLE PRECISION array, dimension (LDB, N)
The original symmetric positive definite matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
Z (input) DOUBLE PRECISION array, dimension (LDZ, M)
The computed eigenvectors of the generalized eigenproblem.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= max(1,N).
D (input) DOUBLE PRECISION array, dimension (M)
The computed eigenvalues of the generalized eigenproblem.
WORK (workspace) DOUBLE PRECISION array, dimension (N*N)
RESULT (output) DOUBLE PRECISION array, dimension (1)
The test ratio as described above.
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--d__;
--work;
--result;
/* Function Body */
result[1] = 0.;
if (*n <= 0) {
return 0;
}
ulp = dlamch_("Epsilon");
/* Compute product of 1-norms of A and Z. */
anorm = dlansy_("1", uplo, n, &a[a_offset], lda, &work[1]) * dlange_("1", n, m, &z__[z_offset], ldz, &work[1]);
if (anorm == 0.) {
anorm = 1.;
}
if (*itype == 1) {
/* Norm of AZ - BZD */
dsymm_("Left", uplo, n, m, &c_b6, &a[a_offset], lda, &z__[z_offset],
ldz, &c_b7, &work[1], n);
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
dscal_(n, &d__[i__], &z___ref(1, i__), &c__1);
/* L10: */
}
dsymm_("Left", uplo, n, m, &c_b6, &b[b_offset], ldb, &z__[z_offset],
ldz, &c_b12, &work[1], n);
result[1] = dlange_("1", n, m, &work[1], n, &work[1]) /
anorm / (*n * ulp);
} else if (*itype == 2) {
/* Norm of ABZ - ZD */
dsymm_("Left", uplo, n, m, &c_b6, &b[b_offset], ldb, &z__[z_offset],
ldz, &c_b7, &work[1], n);
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
dscal_(n, &d__[i__], &z___ref(1, i__), &c__1);
/* L20: */
}
dsymm_("Left", uplo, n, m, &c_b6, &a[a_offset], lda, &work[1], n, &
c_b12, &z__[z_offset], ldz);
result[1] = dlange_("1", n, m, &z__[z_offset], ldz, &work[1]) / anorm / (*n * ulp);
} else if (*itype == 3) {
/* Norm of BAZ - ZD */
dsymm_("Left", uplo, n, m, &c_b6, &a[a_offset], lda, &z__[z_offset],
ldz, &c_b7, &work[1], n);
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
dscal_(n, &d__[i__], &z___ref(1, i__), &c__1);
/* L30: */
}
dsymm_("Left", uplo, n, m, &c_b6, &b[b_offset], ldb, &work[1], n, &
c_b12, &z__[z_offset], ldz);
result[1] = dlange_("1", n, m, &z__[z_offset], ldz, &work[1]) / anorm / (*n * ulp);
}
return 0;
/* End of DDGT01 */
} /* dsgt01_ */
/* Subroutine */ int dsyevd_(char *jobz, char *uplo, integer *n, doublereal *
a, integer *lda, doublereal *w, doublereal *work, integer *lwork,
integer *iwork, integer *liwork, integer *info, ftnlen jobz_len,
ftnlen uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static doublereal eps;
static integer inde;
static doublereal anrm, rmin, rmax;
static integer lopt;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static integer iinfo, lwmin, liopt;
static logical lower, wantz;
static integer indwk2, llwrk2;
extern doublereal dlamch_(char *, ftnlen);
static integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen), dstedc_(char *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *, integer *, integer *, ftnlen), dlacpy_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, ftnlen);
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
static doublereal bignum;
static integer indtau;
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *, ftnlen, ftnlen);
static integer indwrk, liwmin;
extern /* Subroutine */ int dormtr_(char *, char *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, ftnlen, ftnlen,
ftnlen), dsytrd_(char *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *, ftnlen);
static integer llwork;
static doublereal smlnum;
static logical lquery;
/* -- 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 */
/* ======= */
/* DSYEVD computes all eigenvalues and, optionally, eigenvectors of a */
/* real symmetric 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. */
/* Because of large use of BLAS of level 3, DSYEVD needs N**2 more */
/* workspace than DSYEVX. */
/* 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) DOUBLE PRECISION array, dimension (LDA, N) */
/* On entry, 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. 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) DOUBLE PRECISION array, */
/* dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* If N <= 1, LWORK must be at least 1. */
/* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1. */
/* If JOBZ = 'V' and N > 1, LWORK must be at least */
/* 1 + 6*N + 2*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. */
/* 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 */
/* Modified by Francoise Tisseur, University of Tennessee. */
/* ===================================================================== */
/* .. 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;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V", (ftnlen)1, (ftnlen)1);
lower = lsame_(uplo, "L", (ftnlen)1, (ftnlen)1);
lquery = *lwork == -1 || *liwork == -1;
*info = 0;
if (*n <= 1) {
liwmin = 1;
lwmin = 1;
lopt = lwmin;
liopt = liwmin;
} else {
if (wantz) {
liwmin = *n * 5 + 3;
/* Computing 2nd power */
i__1 = *n;
lwmin = *n * 6 + 1 + (i__1 * i__1 << 1);
} else {
liwmin = 1;
lwmin = (*n << 1) + 1;
}
lopt = lwmin;
liopt = liwmin;
}
if (! (wantz || lsame_(jobz, "N", (ftnlen)1, (ftnlen)1))) {
*info = -1;
} else if (! (lower || lsame_(uplo, "U", (ftnlen)1, (ftnlen)1))) {
*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 (*liwork < liwmin && ! lquery) {
*info = -10;
}
if (*info == 0) {
work[1] = (doublereal) lopt;
iwork[1] = liopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYEVD", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
w[1] = a[a_dim1 + 1];
if (wantz) {
a[a_dim1 + 1] = 1.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum", (ftnlen)12);
eps = dlamch_("Precision", (ftnlen)9);
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1], (ftnlen)1, (
ftnlen)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) {
dlascl_(uplo, &c__0, &c__0, &c_b12, &sigma, n, n, &a[a_offset], lda,
info, (ftnlen)1);
}
/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */
inde = 1;
indtau = inde + *n;
indwrk = indtau + *n;
llwork = *lwork - indwrk + 1;
indwk2 = indwrk + *n * *n;
llwrk2 = *lwork - indwk2 + 1;
dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], &
work[indwrk], &llwork, &iinfo, (ftnlen)1);
lopt = (integer) ((*n << 1) + work[indwrk]);
/* For eigenvalues only, call DSTERF. For eigenvectors, first call */
/* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */
/* tridiagonal matrix, then call DORMTR to multiply it by the */
/* Householder transformations stored in A. */
if (! wantz) {
dsterf_(n, &w[1], &work[inde], info);
} else {
dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], &
llwrk2, &iwork[1], liwork, info, (ftnlen)1);
dormtr_("L", uplo, "N", n, n, &a[a_offset], lda, &work[indtau], &work[
indwrk], n, &work[indwk2], &llwrk2, &iinfo, (ftnlen)1, (
ftnlen)1, (ftnlen)1);
dlacpy_("A", n, n, &work[indwrk], n, &a[a_offset], lda, (ftnlen)1);
/* Computing MAX */
/* Computing 2nd power */
i__3 = *n;
i__1 = lopt, i__2 = *n * 6 + 1 + (i__3 * i__3 << 1);
lopt = max(i__1,i__2);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
d__1 = 1. / sigma;
dscal_(n, &d__1, &w[1], &c__1);
}
work[1] = (doublereal) lopt;
iwork[1] = liopt;
return 0;
/* End of DSYEVD */
} /* dsyevd_ */
/* Subroutine */ int dsyt21_(integer *itype, char *uplo, integer *n, integer *
kband, doublereal *a, integer *lda, doublereal *d__, doublereal *e,
doublereal *u, integer *ldu, doublereal *v, integer *ldv, doublereal *
tau, doublereal *work, doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
i__3;
doublereal d__1, d__2;
/* Local variables */
integer j, jr;
doublereal ulp;
integer jcol;
doublereal unfl;
integer jrow;
extern /* Subroutine */ int dsyr_(char *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *), dsyr2_(
char *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *), dgemm_(
char *, char *, integer *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *);
extern logical lsame_(char *, char *);
integer iinfo;
doublereal anorm;
char cuplo[1];
doublereal vsave;
logical lower;
doublereal wnorm;
extern /* Subroutine */ int dorm2l_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *), dorm2r_(char
*, char *, integer *, integer *, integer *, doublereal *, integer
*, doublereal *, doublereal *, integer *, doublereal *, integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), dlarfy_(char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSYT21 generally checks a decomposition of the form */
/* A = U S U' */
/* where ' means transpose, A is symmetric, U is orthogonal, and S is */
/* diagonal (if KBAND=0) or 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 - VU' | / ( 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 orthogonal 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 orthogonal matrix and */
/* as a product of Housholder transformations: */
/* RESULT(1) = | I - VU' | / ( 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, DSYT21 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) DOUBLE PRECISION array, dimension (LDA, N) */
/* The original (unfactored) matrix. It is assumed to be */
/* symmetric, 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) DOUBLE PRECISION array, dimension (LDU, N) */
/* If ITYPE=1 or 3, this contains the orthogonal 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) DOUBLE PRECISION array, dimension (LDV, N) */
/* If ITYPE=2 or 3, the columns of this array contain the */
/* Householder vectors used to describe the orthogonal 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (2*N**2) */
/* 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;
--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 = dlansy_("1", cuplo, n, &a[a_offset], lda, &work[1]);
anorm = max(d__1,unfl);
}
/* Compute error matrix: */
if (*itype == 1) {
/* ITYPE=1: error = A - U S U' */
dlaset_("Full", n, n, &c_b10, &c_b10, &work[1], n);
dlacpy_(cuplo, n, n, &a[a_offset], lda, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
d__1 = -d__[j];
dsyr_(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) {
d__1 = -e[j];
dsyr2_(cuplo, n, &d__1, &u[j * u_dim1 + 1], &c__1, &u[(j + 1)
* u_dim1 + 1], &c__1, &work[1], n);
/* L20: */
}
}
/* Computing 2nd power */
i__1 = *n;
wnorm = dlansy_("1", cuplo, n, &work[1], n, &work[i__1 * i__1 + 1]);
} else if (*itype == 2) {
/* ITYPE=2: error = V S V' - A */
dlaset_("Full", n, n, &c_b10, &c_b10, &work[1], n);
if (lower) {
/* Computing 2nd power */
i__1 = *n;
work[i__1 * i__1] = d__[*n];
for (j = *n - 1; j >= 1; --j) {
if (*kband == 1) {
work[(*n + 1) * (j - 1) + 2] = (1. - tau[j]) * e[j];
i__1 = *n;
for (jr = j + 2; jr <= i__1; ++jr) {
work[(j - 1) * *n + jr] = -tau[j] * e[j] * v[jr + j *
v_dim1];
/* L30: */
}
}
vsave = v[j + 1 + j * v_dim1];
v[j + 1 + j * v_dim1] = 1.;
i__1 = *n - j;
/* Computing 2nd power */
i__2 = *n;
dlarfy_("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]);
v[j + 1 + j * v_dim1] = vsave;
work[(*n + 1) * (j - 1) + 1] = d__[j];
/* L40: */
}
} else {
work[1] = d__[1];
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
if (*kband == 1) {
work[(*n + 1) * j] = (1. - tau[j]) * e[j];
i__2 = j - 1;
for (jr = 1; jr <= i__2; ++jr) {
work[j * *n + jr] = -tau[j] * e[j] * v[jr + (j + 1) *
v_dim1];
/* L50: */
}
}
vsave = v[j + (j + 1) * v_dim1];
v[j + (j + 1) * v_dim1] = 1.;
/* Computing 2nd power */
i__2 = *n;
dlarfy_("U", &j, &v[(j + 1) * v_dim1 + 1], &c__1, &tau[j], &
work[1], n, &work[i__2 * i__2 + 1]);
v[j + (j + 1) * v_dim1] = vsave;
work[(*n + 1) * j + 1] = d__[j + 1];
/* L60: */
}
}
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
if (lower) {
i__2 = *n;
for (jrow = jcol; jrow <= i__2; ++jrow) {
work[jrow + *n * (jcol - 1)] -= a[jrow + jcol * a_dim1];
/* L70: */
}
} else {
i__2 = jcol;
for (jrow = 1; jrow <= i__2; ++jrow) {
work[jrow + *n * (jcol - 1)] -= a[jrow + jcol * a_dim1];
/* L80: */
}
}
/* L90: */
}
/* Computing 2nd power */
i__1 = *n;
wnorm = dlansy_("1", cuplo, n, &work[1], n, &work[i__1 * i__1 + 1]);
} else if (*itype == 3) {
/* ITYPE=3: error = U V' - I */
if (*n < 2) {
return 0;
}
dlacpy_(" ", 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;
dorm2r_("R", "T", 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;
dorm2l_("R", "T", 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) {
work[(*n + 1) * (j - 1) + 1] += -1.;
/* L100: */
}
/* Computing 2nd power */
i__1 = *n;
wnorm = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 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) {
dgemm_("N", "C", n, n, n, &c_b42, &u[u_offset], ldu, &u[u_offset],
ldu, &c_b10, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
work[(*n + 1) * (j - 1) + 1] += -1.;
/* L110: */
}
/* Computing MIN */
/* Computing 2nd power */
i__1 = *n;
d__1 = dlange_("1", n, n, &work[1], n, &work[i__1 * i__1 + 1]), d__2 = (doublereal) (*n);
result[2] = min(d__1,d__2) / (*n * ulp);
}
return 0;
/* End of DSYT21 */
} /* dsyt21_ */
/* Subroutine */ int dlqt02_(integer *m, integer *n, integer *k, doublereal *
a, doublereal *af, doublereal *q, doublereal *l, integer *lda,
doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static doublereal resid, anorm;
extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *), dorglq_(integer *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
static doublereal eps;
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define af_ref(a_1,a_2) af[(a_2)*af_dim1 + a_1]
/* -- 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
=======
DLQT02 tests DORGLQ, which generates an m-by-n matrix Q with
orthonornmal rows that is defined as the product of k elementary
reflectors.
Given the LQ factorization of an m-by-n matrix A, DLQT02 generates
the orthogonal matrix Q defined by the factorization of the first k
rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and
checks that the rows of Q are orthonormal.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q to be generated. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q to be generated.
N >= M >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. M >= K >= 0.
A (input) DOUBLE PRECISION array, dimension (LDA,N)
The m-by-n matrix A which was factorized by DLQT01.
AF (input) DOUBLE PRECISION array, dimension (LDA,N)
Details of the LQ factorization of A, as returned by DGELQF.
See DGELQF for further details.
Q (workspace) DOUBLE PRECISION array, dimension (LDA,N)
L (workspace) DOUBLE PRECISION array, dimension (LDA,M)
LDA (input) INTEGER
The leading dimension of the arrays A, AF, Q and L. LDA >= N.
TAU (input) DOUBLE PRECISION array, dimension (M)
The scalar factors of the elementary reflectors corresponding
to the LQ factorization in AF.
WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
RWORK (workspace) DOUBLE PRECISION array, dimension (M)
RESULT (output) DOUBLE PRECISION array, dimension (2)
The test ratios:
RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS )
RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
=====================================================================
Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1 * 1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
eps = dlamch_("Epsilon");
/* Copy the first k rows of the factorization to the array Q */
dlaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
i__1 = *n - 1;
dlacpy_("Upper", k, &i__1, &af_ref(1, 2), lda, &q_ref(1, 2), lda);
/* Generate the first n columns of the matrix Q */
s_copy(srnamc_1.srnamt, "DORGLQ", (ftnlen)6, (ftnlen)6);
dorglq_(m, n, k, &q[q_offset], lda, &tau[1], &work[1], lwork, &info);
/* Copy L(1:k,1:m) */
dlaset_("Full", k, m, &c_b9, &c_b9, &l[l_offset], lda);
dlacpy_("Lower", k, m, &af[af_offset], lda, &l[l_offset], lda);
/* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)' */
dgemm_("No transpose", "Transpose", k, m, n, &c_b14, &a[a_offset], lda, &
q[q_offset], lda, &c_b15, &l[l_offset], lda);
/* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = dlange_("1", k, n, &a[a_offset], lda, &rwork[1]);
resid = dlange_("1", k, m, &l[l_offset], lda, &rwork[1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q*Q' */
dlaset_("Full", m, m, &c_b9, &c_b15, &l[l_offset], lda);
dsyrk_("Upper", "No transpose", m, n, &c_b14, &q[q_offset], lda, &c_b15, &
l[l_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = dlansy_("1", "Upper", m, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*n) / eps;
return 0;
/* End of DLQT02 */
} /* dlqt02_ */
/* Subroutine */
int dsyevx_(char *jobz, char *range, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer * il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, integer *lwork, 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 *), dswap_(integer *, doublereal *, integer *, doublereal *, integer *);
logical lower, wantz;
extern doublereal dlamch_(char *);
logical alleig, indeig;
integer iscale, indibl;
logical valeig;
extern /* Subroutine */
int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *);
doublereal safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
extern /* Subroutine */
int xerbla_(char *, integer *);
doublereal abstll, bignum;
integer indtau, indisp;
extern /* Subroutine */
int dstein_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *, integer *), dsterf_(integer *, doublereal *, doublereal *, integer *);
integer indiwo, indwkn;
extern doublereal dlansy_(char *, char *, integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */
int dstebz_(char *, char *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, integer *);
integer indwrk, lwkmin;
extern /* Subroutine */
int dorgtr_(char *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *), dsteqr_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *), dormtr_(char *, char *, char *, integer *, integer *, doublereal * , integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *);
integer llwrkn, llwork, nsplit;
doublereal smlnum;
extern /* Subroutine */
int dsytrd_(char *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, integer *);
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--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] = (doublereal) lwkmin;
}
else
{
lwkmin = *n << 3;
nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = nb;
i__2 = ilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1, &c_n1); // , expr subst
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = lwkmin;
i__2 = (nb + 3) * *n; // , expr subst
lwkopt = max(i__1,i__2);
work[1] = (doublereal) lwkopt;
}
if (*lwork < lwkmin && ! lquery)
{
*info = -17;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DSYEVX", &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;
w[1] = a[a_dim1 + 1];
}
else
{
if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1])
{
*m = 1;
w[1] = a[a_dim1 + 1];
}
}
if (wantz)
{
z__[z_dim1 + 1] = 1.;
}
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 = dlansy_("M", uplo, n, &a[a_offset], lda, &work[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;
dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
/* L10: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
dscal_(&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 DSYTRD to reduce symmetric matrix to tridiagonal form. */
indtau = 1;
inde = indtau + *n;
indd = inde + *n;
indwrk = indd + *n;
llwork = *lwork - indwrk + 1;
dsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[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 DORGTR and SSTEQR. 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, &work[indd], &c__1, &w[1], &c__1);
indee = indwrk + (*n << 1);
if (! wantz)
{
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsterf_(n, &w[1], &work[indee], info);
}
else
{
dlacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz);
dorgtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk] , &llwork, &iinfo);
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[ indwrk], 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, SSTEIN. */
if (wantz)
{
*(unsigned char *)order = 'B';
}
else
{
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwo = indisp + *n;
dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ indwrk], &iwork[indiwo], info);
if (wantz)
{
dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & ifail[1], info);
/* Apply orthogonal matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by DSTEIN. */
indwkn = inde;
llwrkn = *lwork - indwkn + 1;
dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[ z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
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;
dswap_(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 workspace size. */
work[1] = (doublereal) lwkopt;
return 0;
/* End of DSYEVX */
}
/* Subroutine */ int dpot06_(char *uplo, integer *n, integer *nrhs,
doublereal *a, integer *lda, doublereal *x, integer *ldx, doublereal *
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;
/* Local variables */
integer j;
doublereal eps;
integer ifail;
doublereal anorm, bnorm;
extern /* Subroutine */ int dsymm_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
doublereal xnorm;
extern doublereal dlamch_(char *);
extern integer idamax_(integer *, doublereal *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
/* -- LAPACK test routine (version 3.1.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* April 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DPOT06 computes the residual for a solution of a system of linear */
/* equations A*x = b : */
/* RESID = norm(B - A*X,inf) / ( norm(A,inf) * norm(X,inf) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* symmetric matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of B, the matrix of right hand sides. */
/* NRHS >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The original M x N matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
/* The computed solution vectors for the system of linear */
/* equations. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. If TRANS = 'N', */
/* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,N). */
/* B (input/output) DOUBLE PRECISION 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. IF TRANS = 'N', */
/* LDB >= max(1,M); if TRANS = 'T' or 'C', 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 = dlansy_("I", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.) {
*resid = 1. / eps;
return 0;
}
/* Compute B - A*X and store in B. */
ifail = 0;
dsymm_("Left", uplo, n, nrhs, &c_b5, &a[a_offset], lda, &x[x_offset], ldx,
&c_b6, &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 = (d__1 = b[idamax_(n, &b[j * b_dim1 + 1], &c__1) + j * b_dim1],
abs(d__1));
xnorm = (d__1 = x[idamax_(n, &x[j * x_dim1 + 1], &c__1) + j * x_dim1],
abs(d__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 DPOT06 */
} /* dpot06_ */
/* Subroutine */ int dgqrts_(integer *n, integer *m, integer *p, doublereal *
a, doublereal *af, doublereal *q, doublereal *r__, integer *lda,
doublereal *taua, doublereal *b, doublereal *bf, doublereal *z__,
doublereal *t, doublereal *bwk, integer *ldb, doublereal *taub,
doublereal *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;
/* Local variables */
static integer info;
static doublereal unfl;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
static doublereal resid, anorm, bnorm;
extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dggqrf_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, integer *), dlacpy_(char *,
integer *, integer *, doublereal *, integer *, doublereal *,
integer *), dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dorgqr_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *), dorgrq_(integer *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *);
static doublereal ulp;
#define q_ref(a_1,a_2) q[(a_2)*q_dim1 + a_1]
#define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1]
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
#define af_ref(a_1,a_2) af[(a_2)*af_dim1 + a_1]
#define bf_ref(a_1,a_2) bf[(a_2)*bf_dim1 + a_1]
/* -- 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
=======
DGQRTS tests DGGQRF, 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) DOUBLE PRECISION array, dimension (LDA,M)
The N-by-M matrix A.
AF (output) DOUBLE PRECISION array, dimension (LDA,N)
Details of the GQR factorization of A and B, as returned
by DGGQRF, see SGGQRF for further details.
Q (output) DOUBLE PRECISION array, dimension (LDA,N)
The M-by-M orthogonal matrix Q.
R (workspace) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (min(M,N))
The scalar factors of the elementary reflectors, as returned
by DGGQRF.
B (input) DOUBLE PRECISION array, dimension (LDB,P)
On entry, the N-by-P matrix A.
BF (output) DOUBLE PRECISION array, dimension (LDB,N)
Details of the GQR factorization of A and B, as returned
by DGGQRF, see SGGQRF for further details.
Z (output) DOUBLE PRECISION array, dimension (LDB,P)
The P-by-P orthogonal matrix Z.
T (workspace) DOUBLE PRECISION array, dimension (LDB,max(P,N))
BWK (workspace) DOUBLE PRECISION array, dimension (LDB,N)
LDB (input) INTEGER
The leading dimension of the arrays B, BF, Z and T.
LDB >= max(P,N).
TAUB (output) DOUBLE PRECISION array, dimension (min(P,N))
The scalar factors of the elementary reflectors, as returned
by DGGRQF.
WORK (workspace) DOUBLE PRECISION 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 )
=====================================================================
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. */
dlacpy_("Full", n, m, &a[a_offset], lda, &af[af_offset], lda);
dlacpy_("Full", n, p, &b[b_offset], ldb, &bf[bf_offset], ldb);
/* Computing MAX */
d__1 = dlange_("1", n, m, &a[a_offset], lda, &rwork[1]);
anorm = max(d__1,unfl);
/* Computing MAX */
d__1 = dlange_("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. */
dggqrf_(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 */
dlaset_("Full", n, n, &c_b9, &c_b9, &q[q_offset], lda);
i__1 = *n - 1;
dlacpy_("Lower", &i__1, m, &af_ref(2, 1), lda, &q_ref(2, 1), lda);
i__1 = min(*n,*m);
dorgqr_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
/* Generate the P-by-P matrix Z */
dlaset_("Full", p, p, &c_b9, &c_b9, &z__[z_offset], ldb);
if (*n <= *p) {
if (*n > 0 && *n < *p) {
i__1 = *p - *n;
dlacpy_("Full", n, &i__1, &bf[bf_offset], ldb, &z___ref(*p - *n +
1, 1), ldb);
}
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
dlacpy_("Lower", &i__1, &i__2, &bf_ref(2, *p - *n + 1), ldb, &
z___ref(*p - *n + 2, *p - *n + 1), ldb);
}
} else {
if (*p > 1) {
i__1 = *p - 1;
i__2 = *p - 1;
dlacpy_("Lower", &i__1, &i__2, &bf_ref(*n - *p + 2, 1), ldb, &
z___ref(2, 1), ldb);
}
}
i__1 = min(*n,*p);
dorgrq_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
info);
/* Copy R */
dlaset_("Full", n, m, &c_b19, &c_b19, &r__[r_offset], lda);
dlacpy_("Upper", n, m, &af[af_offset], lda, &r__[r_offset], lda);
/* Copy T */
dlaset_("Full", n, p, &c_b19, &c_b19, &t[t_offset], ldb);
if (*n <= *p) {
dlacpy_("Upper", n, n, &bf_ref(1, *p - *n + 1), ldb, &t_ref(1, *p - *
n + 1), ldb);
} else {
i__1 = *n - *p;
dlacpy_("Full", &i__1, p, &bf[bf_offset], ldb, &t[t_offset], ldb);
dlacpy_("Upper", p, p, &bf_ref(*n - *p + 1, 1), ldb, &t_ref(*n - *p +
1, 1), ldb);
}
/* Compute R - Q'*A */
dgemm_("Transpose", "No transpose", n, m, n, &c_b30, &q[q_offset], lda, &
a[a_offset], lda, &c_b31, &r__[r_offset], lda);
/* Compute norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP ) . */
resid = dlange_("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 */
dgemm_("No Transpose", "No transpose", n, p, p, &c_b31, &t[t_offset], ldb,
&z__[z_offset], ldb, &c_b19, &bwk[bwk_offset], ldb);
dgemm_("Transpose", "No transpose", n, p, n, &c_b30, &q[q_offset], lda, &
b[b_offset], ldb, &c_b31, &bwk[bwk_offset], ldb);
/* Compute norm( T*Z - Q'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
resid = dlange_("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 */
dlaset_("Full", n, n, &c_b19, &c_b31, &r__[r_offset], lda);
dsyrk_("Upper", "Transpose", n, n, &c_b30, &q[q_offset], lda, &c_b31, &
r__[r_offset], lda);
/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
resid = dlansy_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
result[3] = resid / (doublereal) max(1,*n) / ulp;
/* Compute I - Z'*Z */
dlaset_("Full", p, p, &c_b19, &c_b31, &t[t_offset], ldb);
dsyrk_("Upper", "Transpose", p, p, &c_b30, &z__[z_offset], ldb, &c_b31, &
t[t_offset], ldb);
/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
resid = dlansy_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
result[4] = resid / (doublereal) max(1,*p) / ulp;
return 0;
/* End of DGQRTS */
} /* dgqrts_ */
/* Subroutine */ int dlatmr_(integer *m, integer *n, char *dist, integer *
iseed, char *sym, doublereal *d__, integer *mode, doublereal *cond,
doublereal *dmax__, char *rsign, char *grade, doublereal *dl, integer
*model, doublereal *condl, doublereal *dr, integer *moder, doublereal
*condr, char *pivtng, integer *ipivot, integer *kl, integer *ku,
doublereal *sparse, doublereal *anorm, char *pack, doublereal *a,
integer *lda, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2, d__3;
/* Local variables */
static integer isub, jsub;
static doublereal temp;
static integer isym, i__, j, k;
static doublereal alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static integer ipack;
extern logical lsame_(char *, char *);
static doublereal tempa[1];
static integer iisub, idist, jjsub, mnmin;
static logical dzero;
static integer mnsub;
static doublereal onorm;
static integer mxsub, npvts;
extern /* Subroutine */ int dlatm1_(integer *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *, integer *);
extern doublereal dlatm2_(integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, doublereal *, integer
*, doublereal *, doublereal *, integer *, integer *, doublereal *)
, dlatm3_(integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *), dlangb_(char *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *), dlange_(char *,
integer *, integer *, doublereal *, integer *, doublereal *);
static integer igrade;
extern doublereal dlansb_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *);
static logical fulbnd;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical badpvt;
extern doublereal dlansp_(char *, char *, integer *, doublereal *,
doublereal *), dlansy_(char *, char *, integer *,
doublereal *, integer *, doublereal *);
static integer irsign, ipvtng, kll, kuu;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
DLATMR generates random matrices of various types for testing
LAPACK programs.
DLATMR operates by applying the following sequence of
operations:
Generate a matrix A with random entries of distribution DIST
which is symmetric if SYM='S', and nonsymmetric
if SYM='N'.
Set the diagonal to D, where D may be input or
computed according to MODE, COND, DMAX and RSIGN
as described below.
Grade the matrix, if desired, from the left and/or right
as specified by GRADE. The inputs DL, MODEL, CONDL, DR,
MODER and CONDR also determine the grading as described
below.
Permute, if desired, the rows and/or columns as specified by
PIVTNG and IPIVOT.
Set random entries to zero, if desired, to get a random sparse
matrix as specified by SPARSE.
Make A a band matrix, if desired, by zeroing out the matrix
outside a band of lower bandwidth KL and upper bandwidth KU.
Scale A, if desired, to have maximum entry ANORM.
Pack the matrix if desired. Options specified by PACK are:
no packing
zero out upper half (if symmetric)
zero out lower half (if symmetric)
store the upper half columnwise (if symmetric or
square upper triangular)
store the lower half columnwise (if symmetric or
square lower triangular)
same as upper half rowwise if symmetric
store the lower triangle in banded format (if symmetric)
store the upper triangle in banded format (if symmetric)
store the entire matrix in banded format
Note: If two calls to DLATMR differ only in the PACK parameter,
they will generate mathematically equivalent matrices.
If two calls to DLATMR both have full bandwidth (KL = M-1
and KU = N-1), and differ only in the PIVTNG and PACK
parameters, then the matrices generated will differ only
in the order of the rows and/or columns, and otherwise
contain the same data. This consistency cannot be and
is not maintained with less than full bandwidth.
Arguments
=========
M - INTEGER
Number of rows of A. Not modified.
N - INTEGER
Number of columns of A. Not modified.
DIST - CHARACTER*1
On entry, DIST specifies the type of distribution to be used
to generate a random matrix .
'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
'N' => NORMAL( 0, 1 ) ( 'N' for normal )
Not modified.
ISEED - INTEGER array, dimension (4)
On entry ISEED specifies the seed of the random number
generator. They should lie between 0 and 4095 inclusive,
and ISEED(4) should be odd. The random number generator
uses a linear congruential sequence limited to small
integers, and so should produce machine independent
random numbers. The values of ISEED are changed on
exit, and can be used in the next call to DLATMR
to continue the same random number sequence.
Changed on exit.
SYM - CHARACTER*1
If SYM='S' or 'H', generated matrix is symmetric.
If SYM='N', generated matrix is nonsymmetric.
Not modified.
D - DOUBLE PRECISION array, dimension (min(M,N))
On entry this array specifies the diagonal entries
of the diagonal of A. D may either be specified
on entry, or set according to MODE and COND as described
below. May be changed on exit if MODE is nonzero.
MODE - INTEGER
On entry describes how D is to be used:
MODE = 0 means use D as input
MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
MODE = 5 sets D to random numbers in the range
( 1/COND , 1 ) such that their logarithms
are uniformly distributed.
MODE = 6 set D to random numbers from same distribution
as the rest of the matrix.
MODE < 0 has the same meaning as ABS(MODE), except that
the order of the elements of D is reversed.
Thus if MODE is positive, D has entries ranging from
1 to 1/COND, if negative, from 1/COND to 1,
Not modified.
COND - DOUBLE PRECISION
On entry, used as described under MODE above.
If used, it must be >= 1. Not modified.
DMAX - DOUBLE PRECISION
If MODE neither -6, 0 nor 6, the diagonal is scaled by
DMAX / max(abs(D(i))), so that maximum absolute entry
of diagonal is abs(DMAX). If DMAX is negative (or zero),
diagonal will be scaled by a negative number (or zero).
RSIGN - CHARACTER*1
If MODE neither -6, 0 nor 6, specifies sign of diagonal
as follows:
'T' => diagonal entries are multiplied by 1 or -1
with probability .5
'F' => diagonal unchanged
Not modified.
GRADE - CHARACTER*1
Specifies grading of matrix as follows:
'N' => no grading
'L' => matrix premultiplied by diag( DL )
(only if matrix nonsymmetric)
'R' => matrix postmultiplied by diag( DR )
(only if matrix nonsymmetric)
'B' => matrix premultiplied by diag( DL ) and
postmultiplied by diag( DR )
(only if matrix nonsymmetric)
'S' or 'H' => matrix premultiplied by diag( DL ) and
postmultiplied by diag( DL )
('S' for symmetric, or 'H' for Hermitian)
'E' => matrix premultiplied by diag( DL ) and
postmultiplied by inv( diag( DL ) )
( 'E' for eigenvalue invariance)
(only if matrix nonsymmetric)
Note: if GRADE='E', then M must equal N.
Not modified.
DL - DOUBLE PRECISION array, dimension (M)
If MODEL=0, then on entry this array specifies the diagonal
entries of a diagonal matrix used as described under GRADE
above. If MODEL is not zero, then DL will be set according
to MODEL and CONDL, analogous to the way D is set according
to MODE and COND (except there is no DMAX parameter for DL).
If GRADE='E', then DL cannot have zero entries.
Not referenced if GRADE = 'N' or 'R'. Changed on exit.
MODEL - INTEGER
This specifies how the diagonal array DL is to be computed,
just as MODE specifies how D is to be computed.
Not modified.
CONDL - DOUBLE PRECISION
When MODEL is not zero, this specifies the condition number
of the computed DL. Not modified.
DR - DOUBLE PRECISION array, dimension (N)
If MODER=0, then on entry this array specifies the diagonal
entries of a diagonal matrix used as described under GRADE
above. If MODER is not zero, then DR will be set according
to MODER and CONDR, analogous to the way D is set according
to MODE and COND (except there is no DMAX parameter for DR).
Not referenced if GRADE = 'N', 'L', 'H', 'S' or 'E'.
Changed on exit.
MODER - INTEGER
This specifies how the diagonal array DR is to be computed,
just as MODE specifies how D is to be computed.
Not modified.
CONDR - DOUBLE PRECISION
When MODER is not zero, this specifies the condition number
of the computed DR. Not modified.
PIVTNG - CHARACTER*1
On entry specifies pivoting permutations as follows:
'N' or ' ' => none.
'L' => left or row pivoting (matrix must be nonsymmetric).
'R' => right or column pivoting (matrix must be
nonsymmetric).
'B' or 'F' => both or full pivoting, i.e., on both sides.
In this case, M must equal N
If two calls to DLATMR both have full bandwidth (KL = M-1
and KU = N-1), and differ only in the PIVTNG and PACK
parameters, then the matrices generated will differ only
in the order of the rows and/or columns, and otherwise
contain the same data. This consistency cannot be
maintained with less than full bandwidth.
IPIVOT - INTEGER array, dimension (N or M)
This array specifies the permutation used. After the
basic matrix is generated, the rows, columns, or both
are permuted. If, say, row pivoting is selected, DLATMR
starts with the *last* row and interchanges the M-th and
IPIVOT(M)-th rows, then moves to the next-to-last row,
interchanging the (M-1)-th and the IPIVOT(M-1)-th rows,
and so on. In terms of "2-cycles", the permutation is
(1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M))
where the rightmost cycle is applied first. This is the
*inverse* of the effect of pivoting in LINPACK. The idea
is that factoring (with pivoting) an identity matrix
which has been inverse-pivoted in this way should
result in a pivot vector identical to IPIVOT.
Not referenced if PIVTNG = 'N'. Not modified.
SPARSE - DOUBLE PRECISION
On entry specifies the sparsity of the matrix if a sparse
matrix is to be generated. SPARSE should lie between
0 and 1. To generate a sparse matrix, for each matrix entry
a uniform ( 0, 1 ) random number x is generated and
compared to SPARSE; if x is larger the matrix entry
is unchanged and if x is smaller the entry is set
to zero. Thus on the average a fraction SPARSE of the
entries will be set to zero.
Not modified.
KL - INTEGER
On entry specifies the lower bandwidth of the matrix. For
example, KL=0 implies upper triangular, KL=1 implies upper
Hessenberg, and KL at least M-1 implies the matrix is not
banded. Must equal KU if matrix is symmetric.
Not modified.
KU - INTEGER
On entry specifies the upper bandwidth of the matrix. For
example, KU=0 implies lower triangular, KU=1 implies lower
Hessenberg, and KU at least N-1 implies the matrix is not
banded. Must equal KL if matrix is symmetric.
Not modified.
ANORM - DOUBLE PRECISION
On entry specifies maximum entry of output matrix
(output matrix will by multiplied by a constant so that
its largest absolute entry equal ANORM)
if ANORM is nonnegative. If ANORM is negative no scaling
is done. Not modified.
PACK - CHARACTER*1
On entry specifies packing of matrix as follows:
'N' => no packing
'U' => zero out all subdiagonal entries (if symmetric)
'L' => zero out all superdiagonal entries (if symmetric)
'C' => store the upper triangle columnwise
(only if matrix symmetric or square upper triangular)
'R' => store the lower triangle columnwise
(only if matrix symmetric or square lower triangular)
(same as upper half rowwise if symmetric)
'B' => store the lower triangle in band storage scheme
(only if matrix symmetric)
'Q' => store the upper triangle in band storage scheme
(only if matrix symmetric)
'Z' => store the entire matrix in band storage scheme
(pivoting can be provided for by using this
option to store A in the trailing rows of
the allocated storage)
Using these options, the various LAPACK packed and banded
storage schemes can be obtained:
GB - use 'Z'
PB, SB or TB - use 'B' or 'Q'
PP, SP or TP - use 'C' or 'R'
If two calls to DLATMR differ only in the PACK parameter,
they will generate mathematically equivalent matrices.
Not modified.
A - DOUBLE PRECISION array, dimension (LDA,N)
On exit A is the desired test matrix. Only those
entries of A which are significant on output
will be referenced (even if A is in packed or band
storage format). The 'unoccupied corners' of A in
band format will be zeroed out.
LDA - INTEGER
on entry LDA specifies the first dimension of A as
declared in the calling program.
If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ).
If PACK='C' or 'R', LDA must be at least 1.
If PACK='B', or 'Q', LDA must be MIN ( KU+1, N )
If PACK='Z', LDA must be at least KUU+KLL+1, where
KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 )
Not modified.
IWORK - INTEGER array, dimension ( N or M)
Workspace. Not referenced if PIVTNG = 'N'. Changed on exit.
INFO - INTEGER
Error parameter on exit:
0 => normal return
-1 => M negative or unequal to N and SYM='S' or 'H'
-2 => N negative
-3 => DIST illegal string
-5 => SYM illegal string
-7 => MODE not in range -6 to 6
-8 => COND less than 1.0, and MODE neither -6, 0 nor 6
-10 => MODE neither -6, 0 nor 6 and RSIGN illegal string
-11 => GRADE illegal string, or GRADE='E' and
M not equal to N, or GRADE='L', 'R', 'B' or 'E' and
SYM = 'S' or 'H'
-12 => GRADE = 'E' and DL contains zero
-13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H',
'S' or 'E'
-14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E',
and MODEL neither -6, 0 nor 6
-16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B'
-17 => CONDR less than 1.0, GRADE='R' or 'B', and
MODER neither -6, 0 nor 6
-18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and
M not equal to N, or PIVTNG='L' or 'R' and SYM='S'
or 'H'
-19 => IPIVOT contains out of range number and
PIVTNG not equal to 'N'
-20 => KL negative
-21 => KU negative, or SYM='S' or 'H' and KU not equal to KL
-22 => SPARSE not in range 0. to 1.
-24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q'
and SYM='N', or PACK='C' and SYM='N' and either KL
not equal to 0 or N not equal to M, or PACK='R' and
SYM='N', and either KU not equal to 0 or N not equal
to M
-26 => LDA too small
1 => Error return from DLATM1 (computing D)
2 => Cannot scale diagonal to DMAX (max. entry is 0)
3 => Error return from DLATM1 (computing DL)
4 => Error return from DLATM1 (computing DR)
5 => ANORM is positive, but matrix constructed prior to
attempting to scale it to have norm ANORM, is zero
=====================================================================
1) Decode and Test the input parameters.
Initialize flags & seed.
Parameter adjustments */
--iseed;
--d__;
--dl;
--dr;
--ipivot;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--iwork;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Decode DIST */
if (lsame_(dist, "U")) {
idist = 1;
} else if (lsame_(dist, "S")) {
idist = 2;
} else if (lsame_(dist, "N")) {
idist = 3;
} else {
idist = -1;
}
/* Decode SYM */
if (lsame_(sym, "S")) {
isym = 0;
} else if (lsame_(sym, "N")) {
isym = 1;
} else if (lsame_(sym, "H")) {
isym = 0;
} else {
isym = -1;
}
/* Decode RSIGN */
if (lsame_(rsign, "F")) {
irsign = 0;
} else if (lsame_(rsign, "T")) {
irsign = 1;
} else {
irsign = -1;
}
/* Decode PIVTNG */
if (lsame_(pivtng, "N")) {
ipvtng = 0;
} else if (lsame_(pivtng, " ")) {
ipvtng = 0;
} else if (lsame_(pivtng, "L")) {
ipvtng = 1;
npvts = *m;
} else if (lsame_(pivtng, "R")) {
ipvtng = 2;
npvts = *n;
} else if (lsame_(pivtng, "B")) {
ipvtng = 3;
npvts = min(*n,*m);
} else if (lsame_(pivtng, "F")) {
ipvtng = 3;
npvts = min(*n,*m);
} else {
ipvtng = -1;
}
/* Decode GRADE */
if (lsame_(grade, "N")) {
igrade = 0;
} else if (lsame_(grade, "L")) {
igrade = 1;
} else if (lsame_(grade, "R")) {
igrade = 2;
} else if (lsame_(grade, "B")) {
igrade = 3;
} else if (lsame_(grade, "E")) {
igrade = 4;
} else if (lsame_(grade, "H") || lsame_(grade,
"S")) {
igrade = 5;
} else {
igrade = -1;
}
/* Decode PACK */
if (lsame_(pack, "N")) {
ipack = 0;
} else if (lsame_(pack, "U")) {
ipack = 1;
} else if (lsame_(pack, "L")) {
ipack = 2;
} else if (lsame_(pack, "C")) {
ipack = 3;
} else if (lsame_(pack, "R")) {
ipack = 4;
} else if (lsame_(pack, "B")) {
ipack = 5;
} else if (lsame_(pack, "Q")) {
ipack = 6;
} else if (lsame_(pack, "Z")) {
ipack = 7;
} else {
ipack = -1;
}
/* Set certain internal parameters */
mnmin = min(*m,*n);
/* Computing MIN */
i__1 = *kl, i__2 = *m - 1;
kll = min(i__1,i__2);
/* Computing MIN */
i__1 = *ku, i__2 = *n - 1;
kuu = min(i__1,i__2);
/* If inv(DL) is used, check to see if DL has a zero entry. */
dzero = FALSE_;
if (igrade == 4 && *model == 0) {
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
if (dl[i__] == 0.) {
dzero = TRUE_;
}
/* L10: */
}
}
/* Check values in IPIVOT */
badpvt = FALSE_;
if (ipvtng > 0) {
i__1 = npvts;
for (j = 1; j <= i__1; ++j) {
if (ipivot[j] <= 0 || ipivot[j] > npvts) {
badpvt = TRUE_;
}
/* L20: */
}
}
/* Set INFO if an error */
if (*m < 0) {
*info = -1;
} else if (*m != *n && isym == 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (idist == -1) {
*info = -3;
} else if (isym == -1) {
*info = -5;
} else if (*mode < -6 || *mode > 6) {
*info = -7;
} else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) {
*info = -8;
} else if (*mode != -6 && *mode != 0 && *mode != 6 && irsign == -1) {
*info = -10;
} else if (igrade == -1 || igrade == 4 && *m != *n || igrade >= 1 &&
igrade <= 4 && isym == 0) {
*info = -11;
} else if (igrade == 4 && dzero) {
*info = -12;
} else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) && (
*model < -6 || *model > 6)) {
*info = -13;
} else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) && (
*model != -6 && *model != 0 && *model != 6) && *condl < 1.) {
*info = -14;
} else if ((igrade == 2 || igrade == 3) && (*moder < -6 || *moder > 6)) {
*info = -16;
} else if ((igrade == 2 || igrade == 3) && (*moder != -6 && *moder != 0 &&
*moder != 6) && *condr < 1.) {
*info = -17;
} else if (ipvtng == -1 || ipvtng == 3 && *m != *n || (ipvtng == 1 ||
ipvtng == 2) && isym == 0) {
*info = -18;
} else if (ipvtng != 0 && badpvt) {
*info = -19;
} else if (*kl < 0) {
*info = -20;
} else if (*ku < 0 || isym == 0 && *kl != *ku) {
*info = -21;
} else if (*sparse < 0. || *sparse > 1.) {
*info = -22;
} else if (ipack == -1 || (ipack == 1 || ipack == 2 || ipack == 5 ||
ipack == 6) && isym == 1 || ipack == 3 && isym == 1 && (*kl != 0
|| *m != *n) || ipack == 4 && isym == 1 && (*ku != 0 || *m != *n))
{
*info = -24;
} else if ((ipack == 0 || ipack == 1 || ipack == 2) && *lda < max(1,*m) ||
(ipack == 3 || ipack == 4) && *lda < 1 || (ipack == 5 || ipack ==
6) && *lda < kuu + 1 || ipack == 7 && *lda < kll + kuu + 1) {
*info = -26;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLATMR", &i__1);
return 0;
}
/* Decide if we can pivot consistently */
fulbnd = FALSE_;
if (kuu == *n - 1 && kll == *m - 1) {
fulbnd = TRUE_;
}
/* Initialize random number generator */
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
/* L30: */
}
iseed[4] = (iseed[4] / 2 << 1) + 1;
/* 2) Set up D, DL, and DR, if indicated.
Compute D according to COND and MODE */
dlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, info);
if (*info != 0) {
*info = 1;
return 0;
}
if (*mode != 0 && *mode != -6 && *mode != 6) {
/* Scale by DMAX */
temp = abs(d__[1]);
i__1 = mnmin;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1));
temp = max(d__2,d__3);
/* L40: */
}
if (temp == 0. && *dmax__ != 0.) {
*info = 2;
return 0;
}
if (temp != 0.) {
alpha = *dmax__ / temp;
} else {
alpha = 1.;
}
i__1 = mnmin;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = alpha * d__[i__];
/* L50: */
}
}
/* Compute DL if grading set */
if (igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) {
dlatm1_(model, condl, &c__0, &idist, &iseed[1], &dl[1], m, info);
if (*info != 0) {
*info = 3;
return 0;
}
}
/* Compute DR if grading set */
if (igrade == 2 || igrade == 3) {
dlatm1_(moder, condr, &c__0, &idist, &iseed[1], &dr[1], n, info);
if (*info != 0) {
*info = 4;
return 0;
}
}
/* 3) Generate IWORK if pivoting */
if (ipvtng > 0) {
i__1 = npvts;
for (i__ = 1; i__ <= i__1; ++i__) {
iwork[i__] = i__;
/* L60: */
}
if (fulbnd) {
i__1 = npvts;
for (i__ = 1; i__ <= i__1; ++i__) {
k = ipivot[i__];
j = iwork[i__];
iwork[i__] = iwork[k];
iwork[k] = j;
/* L70: */
}
} else {
for (i__ = npvts; i__ >= 1; --i__) {
k = ipivot[i__];
j = iwork[i__];
iwork[i__] = iwork[k];
iwork[k] = j;
/* L80: */
}
}
}
/* 4) Generate matrices for each kind of PACKing
Always sweep matrix columnwise (if symmetric, upper
half only) so that matrix generated does not depend
on PACK */
if (fulbnd) {
/* Use DLATM3 so matrices generated with differing PIVOTing only
differ only in the order of their rows and/or columns. */
if (ipack == 0) {
if (isym == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
a_ref(isub, jsub) = temp;
a_ref(jsub, isub) = temp;
/* L90: */
}
/* L100: */
}
} else if (isym == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
a_ref(isub, jsub) = temp;
/* L110: */
}
/* L120: */
}
}
} else if (ipack == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
, &ipvtng, &iwork[1], sparse);
mnsub = min(isub,jsub);
mxsub = max(isub,jsub);
a_ref(mnsub, mxsub) = temp;
if (mnsub != mxsub) {
a_ref(mxsub, mnsub) = 0.;
}
/* L130: */
}
/* L140: */
}
} else if (ipack == 2) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
, &ipvtng, &iwork[1], sparse);
mnsub = min(isub,jsub);
mxsub = max(isub,jsub);
a_ref(mxsub, mnsub) = temp;
if (mnsub != mxsub) {
a_ref(mnsub, mxsub) = 0.;
}
/* L150: */
}
/* L160: */
}
} else if (ipack == 3) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
, &ipvtng, &iwork[1], sparse);
/* Compute K = location of (ISUB,JSUB) entry in packed
array */
mnsub = min(isub,jsub);
mxsub = max(isub,jsub);
k = mxsub * (mxsub - 1) / 2 + mnsub;
/* Convert K to (IISUB,JJSUB) location */
jjsub = (k - 1) / *lda + 1;
iisub = k - *lda * (jjsub - 1);
a_ref(iisub, jjsub) = temp;
/* L170: */
}
/* L180: */
}
} else if (ipack == 4) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
, &ipvtng, &iwork[1], sparse);
/* Compute K = location of (I,J) entry in packed array */
mnsub = min(isub,jsub);
mxsub = max(isub,jsub);
if (mnsub == 1) {
k = mxsub;
} else {
k = *n * (*n + 1) / 2 - (*n - mnsub + 1) * (*n -
mnsub + 2) / 2 + mxsub - mnsub + 1;
}
/* Convert K to (IISUB,JJSUB) location */
jjsub = (k - 1) / *lda + 1;
iisub = k - *lda * (jjsub - 1);
a_ref(iisub, jjsub) = temp;
/* L190: */
}
/* L200: */
}
} else if (ipack == 5) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = j - kuu; i__ <= i__2; ++i__) {
if (i__ < 1) {
a_ref(j - i__ + 1, i__ + *n) = 0.;
} else {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
mnsub = min(isub,jsub);
mxsub = max(isub,jsub);
a_ref(mxsub - mnsub + 1, mnsub) = temp;
}
/* L210: */
}
/* L220: */
}
} else if (ipack == 6) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = j - kuu; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
, &ipvtng, &iwork[1], sparse);
mnsub = min(isub,jsub);
mxsub = max(isub,jsub);
a_ref(mnsub - mxsub + kuu + 1, mxsub) = temp;
/* L230: */
}
/* L240: */
}
} else if (ipack == 7) {
if (isym == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = j - kuu; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
mnsub = min(isub,jsub);
mxsub = max(isub,jsub);
a_ref(mnsub - mxsub + kuu + 1, mxsub) = temp;
if (i__ < 1) {
a_ref(j - i__ + 1 + kuu, i__ + *n) = 0.;
}
if (i__ >= 1 && mnsub != mxsub) {
a_ref(mxsub - mnsub + 1 + kuu, mnsub) = temp;
}
/* L250: */
}
/* L260: */
}
} else if (isym == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + kll;
for (i__ = j - kuu; i__ <= i__2; ++i__) {
temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
a_ref(isub - jsub + kuu + 1, jsub) = temp;
/* L270: */
}
/* L280: */
}
}
}
} else {
/* Use DLATM2 */
if (ipack == 0) {
if (isym == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
a_ref(i__, j) = dlatm2_(m, n, &i__, &j, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
a_ref(j, i__) = a_ref(i__, j);
/* L290: */
}
/* L300: */
}
} else if (isym == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
a_ref(i__, j) = dlatm2_(m, n, &i__, &j, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
/* L310: */
}
/* L320: */
}
}
} else if (ipack == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
a_ref(i__, j) = dlatm2_(m, n, &i__, &j, kl, ku, &idist, &
iseed[1], &d__[1], &igrade, &dl[1], &dr[1], &
ipvtng, &iwork[1], sparse);
if (i__ != j) {
a_ref(j, i__) = 0.;
}
/* L330: */
}
/* L340: */
}
} else if (ipack == 2) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
a_ref(j, i__) = dlatm2_(m, n, &i__, &j, kl, ku, &idist, &
iseed[1], &d__[1], &igrade, &dl[1], &dr[1], &
ipvtng, &iwork[1], sparse);
if (i__ != j) {
a_ref(i__, j) = 0.;
}
/* L350: */
}
/* L360: */
}
} else if (ipack == 3) {
isub = 0;
jsub = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
++isub;
if (isub > *lda) {
isub = 1;
++jsub;
}
a_ref(isub, jsub) = dlatm2_(m, n, &i__, &j, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1]
, &ipvtng, &iwork[1], sparse);
/* L370: */
}
/* L380: */
}
} else if (ipack == 4) {
if (isym == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Compute K = location of (I,J) entry in packed array */
if (i__ == 1) {
k = j;
} else {
k = *n * (*n + 1) / 2 - (*n - i__ + 1) * (*n -
i__ + 2) / 2 + j - i__ + 1;
}
/* Convert K to (ISUB,JSUB) location */
jsub = (k - 1) / *lda + 1;
isub = k - *lda * (jsub - 1);
a_ref(isub, jsub) = dlatm2_(m, n, &i__, &j, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
/* L390: */
}
/* L400: */
}
} else {
isub = 0;
jsub = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = j; i__ <= i__2; ++i__) {
++isub;
if (isub > *lda) {
isub = 1;
++jsub;
}
a_ref(isub, jsub) = dlatm2_(m, n, &i__, &j, kl, ku, &
idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
/* L410: */
}
/* L420: */
}
}
} else if (ipack == 5) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = j - kuu; i__ <= i__2; ++i__) {
if (i__ < 1) {
a_ref(j - i__ + 1, i__ + *n) = 0.;
} else {
a_ref(j - i__ + 1, i__) = dlatm2_(m, n, &i__, &j, kl,
ku, &idist, &iseed[1], &d__[1], &igrade, &dl[
1], &dr[1], &ipvtng, &iwork[1], sparse);
}
/* L430: */
}
/* L440: */
}
} else if (ipack == 6) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = j - kuu; i__ <= i__2; ++i__) {
a_ref(i__ - j + kuu + 1, j) = dlatm2_(m, n, &i__, &j, kl,
ku, &idist, &iseed[1], &d__[1], &igrade, &dl[1], &
dr[1], &ipvtng, &iwork[1], sparse);
/* L450: */
}
/* L460: */
}
} else if (ipack == 7) {
if (isym == 0) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = j - kuu; i__ <= i__2; ++i__) {
a_ref(i__ - j + kuu + 1, j) = dlatm2_(m, n, &i__, &j,
kl, ku, &idist, &iseed[1], &d__[1], &igrade, &
dl[1], &dr[1], &ipvtng, &iwork[1], sparse);
if (i__ < 1) {
a_ref(j - i__ + 1 + kuu, i__ + *n) = 0.;
}
if (i__ >= 1 && i__ != j) {
a_ref(j - i__ + 1 + kuu, i__) = a_ref(i__ - j +
kuu + 1, j);
}
/* L470: */
}
/* L480: */
}
} else if (isym == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + kll;
for (i__ = j - kuu; i__ <= i__2; ++i__) {
a_ref(i__ - j + kuu + 1, j) = dlatm2_(m, n, &i__, &j,
kl, ku, &idist, &iseed[1], &d__[1], &igrade, &
dl[1], &dr[1], &ipvtng, &iwork[1], sparse);
/* L490: */
}
/* L500: */
}
}
}
}
/* 5) Scaling the norm */
if (ipack == 0) {
onorm = dlange_("M", m, n, &a[a_offset], lda, tempa);
} else if (ipack == 1) {
onorm = dlansy_("M", "U", n, &a[a_offset], lda, tempa);
} else if (ipack == 2) {
onorm = dlansy_("M", "L", n, &a[a_offset], lda, tempa);
} else if (ipack == 3) {
onorm = dlansp_("M", "U", n, &a[a_offset], tempa);
} else if (ipack == 4) {
onorm = dlansp_("M", "L", n, &a[a_offset], tempa);
} else if (ipack == 5) {
onorm = dlansb_("M", "L", n, &kll, &a[a_offset], lda, tempa);
} else if (ipack == 6) {
onorm = dlansb_("M", "U", n, &kuu, &a[a_offset], lda, tempa);
} else if (ipack == 7) {
onorm = dlangb_("M", n, &kll, &kuu, &a[a_offset], lda, tempa);
}
if (*anorm >= 0.) {
if (*anorm > 0. && onorm == 0.) {
/* Desired scaling impossible */
*info = 5;
return 0;
} else if (*anorm > 1. && onorm < 1. || *anorm < 1. && onorm > 1.) {
/* Scale carefully to avoid over / underflow */
if (ipack <= 2) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
d__1 = 1. / onorm;
dscal_(m, &d__1, &a_ref(1, j), &c__1);
dscal_(m, anorm, &a_ref(1, j), &c__1);
/* L510: */
}
} else if (ipack == 3 || ipack == 4) {
i__1 = *n * (*n + 1) / 2;
d__1 = 1. / onorm;
dscal_(&i__1, &d__1, &a[a_offset], &c__1);
i__1 = *n * (*n + 1) / 2;
dscal_(&i__1, anorm, &a[a_offset], &c__1);
} else if (ipack >= 5) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = kll + kuu + 1;
d__1 = 1. / onorm;
dscal_(&i__2, &d__1, &a_ref(1, j), &c__1);
i__2 = kll + kuu + 1;
dscal_(&i__2, anorm, &a_ref(1, j), &c__1);
/* L520: */
}
}
} else {
/* Scale straightforwardly */
if (ipack <= 2) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
d__1 = *anorm / onorm;
dscal_(m, &d__1, &a_ref(1, j), &c__1);
/* L530: */
}
} else if (ipack == 3 || ipack == 4) {
i__1 = *n * (*n + 1) / 2;
d__1 = *anorm / onorm;
dscal_(&i__1, &d__1, &a[a_offset], &c__1);
} else if (ipack >= 5) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = kll + kuu + 1;
d__1 = *anorm / onorm;
dscal_(&i__2, &d__1, &a_ref(1, j), &c__1);
/* L540: */
}
}
}
}
/* End of DLATMR */
return 0;
} /* dlatmr_ */
/* Subroutine */ int drqt02_(integer *m, integer *n, integer *k, doublereal *
a, doublereal *af, doublereal *q, doublereal *r__, integer *lda,
doublereal *tau, doublereal *work, integer *lwork, doublereal *rwork,
doublereal *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
r_offset, i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublereal eps;
integer info;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
doublereal resid, anorm;
extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *);
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlaset_(char *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dorgrq_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, 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 */
/* ======= */
/* DRQT02 tests DORGRQ, which generates an m-by-n matrix Q with */
/* orthonornmal rows that is defined as the product of k elementary */
/* reflectors. */
/* Given the RQ factorization of an m-by-n matrix A, DRQT02 generates */
/* the orthogonal matrix Q defined by the factorization of the last k */
/* rows of A; it compares R(m-k+1:m,n-m+1:n) with */
/* A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are */
/* orthonormal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q to be generated. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q to be generated. */
/* N >= M >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. M >= K >= 0. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The m-by-n matrix A which was factorized by DRQT01. */
/* AF (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* Details of the RQ factorization of A, as returned by DGERQF. */
/* See DGERQF for further details. */
/* Q (workspace) DOUBLE PRECISION array, dimension (LDA,N) */
/* R (workspace) DOUBLE PRECISION array, dimension (LDA,M) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
/* TAU (input) DOUBLE PRECISION array, dimension (M) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the RQ factorization in AF. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (M) */
/* RESULT (output) DOUBLE PRECISION array, dimension (2) */
/* The test ratios: */
/* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
r_dim1 = *lda;
r_offset = 1 + r_dim1;
r__ -= r_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
if (*m == 0 || *n == 0 || *k == 0) {
result[1] = 0.;
result[2] = 0.;
return 0;
}
eps = dlamch_("Epsilon");
/* Copy the last k rows of the factorization to the array Q */
dlaset_("Full", m, n, &c_b4, &c_b4, &q[q_offset], lda);
if (*k < *n) {
i__1 = *n - *k;
dlacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*m - *k
+ 1 + q_dim1], lda);
}
if (*k > 1) {
i__1 = *k - 1;
i__2 = *k - 1;
dlacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) *
af_dim1], lda, &q[*m - *k + 2 + (*n - *k + 1) * q_dim1], lda);
}
/* Generate the last n rows of the matrix Q */
s_copy(srnamc_1.srnamt, "DORGRQ", (ftnlen)6, (ftnlen)6);
dorgrq_(m, n, k, &q[q_offset], lda, &tau[*m - *k + 1], &work[1], lwork, &
info);
/* Copy R(m-k+1:m,n-m+1:n) */
dlaset_("Full", k, m, &c_b10, &c_b10, &r__[*m - *k + 1 + (*n - *m + 1) *
r_dim1], lda);
dlacpy_("Upper", k, k, &af[*m - *k + 1 + (*n - *k + 1) * af_dim1], lda, &
r__[*m - *k + 1 + (*n - *k + 1) * r_dim1], lda);
/* Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)' */
dgemm_("No transpose", "Transpose", k, m, n, &c_b15, &a[*m - *k + 1 +
a_dim1], lda, &q[q_offset], lda, &c_b16, &r__[*m - *k + 1 + (*n -
*m + 1) * r_dim1], lda);
/* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = dlange_("1", k, n, &a[*m - *k + 1 + a_dim1], lda, &rwork[1]);
resid = dlange_("1", k, m, &r__[*m - *k + 1 + (*n - *m + 1) * r_dim1],
lda, &rwork[1]);
if (anorm > 0.) {
result[1] = resid / (doublereal) max(1,*n) / anorm / eps;
} else {
result[1] = 0.;
}
/* Compute I - Q*Q' */
dlaset_("Full", m, m, &c_b10, &c_b16, &r__[r_offset], lda);
dsyrk_("Upper", "No transpose", m, n, &c_b15, &q[q_offset], lda, &c_b16, &
r__[r_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = dlansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);
result[2] = resid / (doublereal) max(1,*n) / eps;
return 0;
/* End of DRQT02 */
} /* drqt02_ */
/* Subroutine */ int dsyevr_(char *jobz, char *range, char *uplo, integer *n,
doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer *
il, integer *iu, doublereal *abstol, integer *m, doublereal *w,
doublereal *z__, integer *ldz, integer *isuppz, doublereal *work,
integer *lwork, integer *iwork, integer *liwork, integer *info)
{
/* -- LAPACK driver routine (version 3.1) --
Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
November 2006
Purpose
=======
DSYEVR computes selected eigenvalues and, optionally, eigenvectors
of a real symmetric matrix A. Eigenvalues and eigenvectors can be
selected by specifying either a range of values or a range of
indices for the desired eigenvalues.
DSYEVR first reduces the matrix A to tridiagonal form T with a call
to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute
the eigenspectrum using Relatively Robust Representations. DSTEMR
computes eigenvalues by the dqds algorithm, while orthogonal
eigenvectors are computed from various "good" L D L^T representations
(also known as Relatively Robust Representations). Gram-Schmidt
orthogonalization is avoided as far as possible. More specifically,
the various steps of the algorithm are as follows.
For each unreduced block (submatrix) of T,
(a) Compute T - sigma I = L D L^T, so that L and D
define all the wanted eigenvalues to high relative accuracy.
This means that small relative changes in the entries of D and L
cause only small relative changes in the eigenvalues and
eigenvectors. The standard (unfactored) representation of the
tridiagonal matrix T does not have this property in general.
(b) Compute the eigenvalues to suitable accuracy.
If the eigenvectors are desired, the algorithm attains full
accuracy of the computed eigenvalues only right before
the corresponding vectors have to be computed, see steps c) and d).
(c) For each cluster of close eigenvalues, select a new
shift close to the cluster, find a new factorization, and refine
the shifted eigenvalues to suitable accuracy.
(d) For each eigenvalue with a large enough relative separation compute
the corresponding eigenvector by forming a rank revealing twisted
factorization. Go back to (c) for any clusters that remain.
The desired accuracy of the output can be specified by the input
parameter ABSTOL.
For more details, see DSTEMR's documentation and:
- Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
- Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
2004. Also LAPACK Working Note 154.
- Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
tridiagonal eigenvalue/eigenvector problem",
Computer Science Division Technical Report No. UCB/CSD-97-971,
UC Berkeley, May 1997.
Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested
on machines which conform to the ieee-754 floating point standard.
DSYEVR calls DSTEBZ and SSTEIN on non-ieee machines and
when partial spectrum requests are made.
Normal execution of DSTEMR may create NaNs and infinities and
hence may abort due to a floating point exception in environments
which do not handle NaNs and infinities in the ieee standard default
manner.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
RANGE (input) CHARACTER*1
= 'A': all eigenvalues will be found.
= 'V': all eigenvalues in the half-open interval (VL,VU]
will be found.
= 'I': the IL-th through IU-th eigenvalues will be found.
********* For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and
********* DSTEIN are called
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
On entry, 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. 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.
See "Computing Small Singular Values of Bidiagonal Matrices
with Guaranteed High Relative Accuracy," by Demmel and
Kahan, LAPACK Working Note #3.
If high relative accuracy is important, set ABSTOL to
DLAMCH( 'Safe minimum' ). Doing so will guarantee that
eigenvalues are computed to high relative accuracy when
possible in future releases. The current code does not
make any guarantees about high relative accuracy, but
future releases will. See J. Barlow and J. Demmel,
"Computing Accurate Eigensystems of Scaled Diagonally
Dominant Matrices", LAPACK Working Note #7, for a discussion
of which matrices define their eigenvalues to high relative
accuracy.
M (output) INTEGER
The total number of eigenvalues found. 0 <= M <= N.
If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
W (output) DOUBLE PRECISION array, dimension (N)
The first M elements contain the selected eigenvalues in
ascending order.
Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
If JOBZ = 'V', then if INFO = 0, the first M columns of Z
contain the orthonormal eigenvectors of the matrix A
corresponding to the selected eigenvalues, with the i-th
column of Z holding the eigenvector associated with W(i).
If JOBZ = 'N', then Z is not referenced.
Note: the user must ensure that at least max(1,M) columns are
supplied in the array Z; if RANGE = 'V', the exact value of M
is not known in advance and an upper bound must be used.
Supplying N columns is always safe.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
The support of the eigenvectors in Z, i.e., the indices
indicating the nonzero elements in Z. The i-th eigenvector
is nonzero only in elements ISUPPZ( 2*i-1 ) through
ISUPPZ( 2*i ).
********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,26*N).
For optimal efficiency, LWORK >= (NB+6)*N,
where NB is the max of the blocksize for DSYTRD and DORMTR
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.
IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.
LIWORK (input) INTEGER
The dimension of the array IWORK. LIWORK >= max(1,10*N).
If LIWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal 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: Internal error
Further Details
===============
Based on contributions by
Inderjit Dhillon, IBM Almaden, USA
Osni Marques, LBNL/NERSC, USA
Ken Stanley, Computer Science Division, University of
California at Berkeley, USA
Jason Riedy, Computer Science Division, University of
California at Berkeley, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__10 = 10;
static integer c__1 = 1;
static integer c__2 = 2;
static integer c__3 = 3;
static integer c__4 = 4;
static integer c_n1 = -1;
/* 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 */
static integer i__, j, nb, jj;
static doublereal eps, vll, vuu, tmp1;
static integer indd, inde;
static doublereal anrm;
static integer imax;
static doublereal rmin, rmax;
static integer inddd, indee;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
static char order[1];
static integer indwk;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static integer lwmin;
static logical lower, wantz;
extern doublereal dlamch_(char *);
static logical alleig, indeig;
static integer iscale, ieeeok, indibl, indifl;
static logical valeig;
static doublereal safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal abstll, bignum;
static integer indtau, indisp;
extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *),
dsterf_(integer *, doublereal *, doublereal *, integer *);
static integer indiwo, indwkn;
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
*, doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *),
dstemr_(char *, char *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, integer *,
logical *, doublereal *, integer *, integer *, integer *, integer
*);
static integer liwmin;
static logical tryrac;
extern /* Subroutine */ int dormtr_(char *, char *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
static integer llwrkn, llwork, nsplit;
static doublereal smlnum;
extern /* Subroutine */ int dsytrd_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
static integer lwkopt;
static logical lquery;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--isuppz;
--work;
--iwork;
/* Function Body */
ieeeok = ilaenv_(&c__10, "DSYEVR", "N", &c__1, &c__2, &c__3, &c__4, (
ftnlen)6, (ftnlen)1);
lower = lsame_(uplo, "L");
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1 || *liwork == -1;
/* Computing MAX */
i__1 = 1, i__2 = *n * 26;
lwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = *n * 10;
liwmin = max(i__1,i__2);
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -8;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -9;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -10;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -15;
} else if (*lwork < lwmin && ! lquery) {
*info = -18;
} else if (*liwork < liwmin && ! lquery) {
*info = -20;
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = (nb + 1) * *n;
lwkopt = max(i__1,lwmin);
work[1] = (doublereal) lwkopt;
iwork[1] = liwmin;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYEVR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
work[1] = 1.;
return 0;
}
if (*n == 1) {
work[1] = 7.;
if (alleig || indeig) {
*m = 1;
w[1] = a[a_dim1 + 1];
} else {
if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) {
*m = 1;
w[1] = a[a_dim1 + 1];
}
}
if (wantz) {
z__[z_dim1 + 1] = 1.;
}
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;
vll = *vl;
vuu = *vu;
anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[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;
dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
/* L20: */
}
}
if (*abstol > 0.) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Initialize indices into workspaces. Note: The IWORK indices are
used only if DSTERF or DSTEMR fail.
WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the
elementary reflectors used in DSYTRD. */
indtau = 1;
/* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. */
indd = indtau + *n;
/* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the
tridiagonal matrix from DSYTRD. */
inde = indd + *n;
/* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over
-written by DSTEMR (the DSTERF path copies the diagonal to W). */
inddd = inde + *n;
/* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over
-written while computing the eigenvalues in DSTERF and DSTEMR. */
indee = inddd + *n;
/* INDWK is the starting offset of the left-over workspace, and
LLWORK is the remaining workspace size. */
indwk = indee + *n;
llwork = *lwork - indwk + 1;
/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and
stores the block indices of each of the M<=N eigenvalues. */
indibl = 1;
/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and
stores the starting and finishing indices of each block. */
indisp = indibl + *n;
/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
that corresponding to eigenvectors that fail to converge in
DSTEIN. This information is discarded; if any fail, the driver
returns INFO > 0. */
indifl = indisp + *n;
/* INDIWO is the offset of the remaining integer workspace. */
indiwo = indisp + *n;
/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */
dsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[
indtau], &work[indwk], &llwork, &iinfo);
/* If all eigenvalues are desired
then call DSTERF or DSTEMR and DORMTR. */
if ((alleig || indeig && *il == 1 && *iu == *n) && ieeeok == 1) {
if (! wantz) {
dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsterf_(n, &w[1], &work[indee], info);
} else {
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dcopy_(n, &work[indd], &c__1, &work[inddd], &c__1);
if (*abstol <= *n * 0. * eps) {
tryrac = TRUE_;
} else {
tryrac = FALSE_;
}
dstemr_(jobz, "A", n, &work[inddd], &work[indee], vl, vu, il, iu,
m, &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, &
work[indwk], lwork, &iwork[1], liwork, info);
/* Apply orthogonal matrix used in reduction to tridiagonal
form to eigenvectors returned by DSTEIN. */
if (wantz && *info == 0) {
indwkn = inde;
llwrkn = *lwork - indwkn + 1;
dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau]
, &z__[z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
}
}
if (*info == 0) {
/* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are
undefined. */
*m = *n;
goto L30;
}
*info = 0;
}
/* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN.
Also call DSTEBZ and DSTEIN if DSTEMR fails. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
indwk], &iwork[indiwo], info);
if (wantz) {
dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
indisp], &z__[z_offset], ldz, &work[indwk], &iwork[indiwo], &
iwork[indifl], info);
/* Apply orthogonal matrix used in reduction to tridiagonal
form to eigenvectors returned by DSTEIN. */
indwkn = inde;
llwrkn = *lwork - indwkn + 1;
dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately.
Jump here if DSTEMR/DSTEIN succeeded. */
L30:
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. Note: We do not sort the IFAIL portion of IWORK.
It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do
not return this detailed information to the user. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp1) {
i__ = jj;
tmp1 = w[jj];
}
/* L40: */
}
if (i__ != 0) {
w[i__] = w[j];
w[j] = tmp1;
dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
&c__1);
}
/* L50: */
}
}
/* Set WORK(1) to optimal workspace size. */
work[1] = (doublereal) lwkopt;
iwork[1] = liwmin;
return 0;
/* End of DSYEVR */
} /* dsyevr_ */
/* Subroutine */ int ddrvpo_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
doublereal *a, doublereal *afac, doublereal *asav, doublereal *b,
doublereal *bsav, doublereal *x, doublereal *xact, doublereal *s,
doublereal *work, doublereal *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char facts[1*3] = "F" "N" "E";
static char equeds[1*2] = "N" "Y";
/* Format strings */
static char fmt_9999[] = "(1x,a,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9997[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
"a1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,"
"\002, test(\002,i1,\002) =\002,g12.5)";
static char fmt_9998[] = "(1x,a,\002, FACT='\002,a1,\002', UPLO='\002,"
"a1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
"=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
char ch__1[2];
/* 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 */
integer i__, k, n, k1, nb, in, kl, ku, nt, lda;
char fact[1];
integer ioff, mode;
doublereal amax;
char path[3];
integer imat, info;
char dist[1], uplo[1], type__[1];
integer nrun, ifact;
extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
integer nfail, iseed[4], nfact;
extern doublereal dget06_(doublereal *, doublereal *);
extern logical lsame_(char *, char *);
char equed[1];
integer nbmin;
doublereal rcond, roldc, scond;
integer nimat;
extern /* Subroutine */ int dpot01_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *), dpot02_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *), dpot05_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *);
doublereal anorm;
logical equil;
integer iuplo, izero, nerrs;
extern /* Subroutine */ int dposv_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *);
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), aladhd_(integer *,
char *), alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
logical prefac;
doublereal rcondc;
logical nofact;
integer iequed;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), dlaset_(char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *), alasvm_(char *, integer *, integer *, integer
*, integer *);
doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *);
doublereal ainvnm;
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dlaqsy_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, char *), dpoequ_(integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *), dpotrf_(
char *, integer *, doublereal *, integer *, integer *),
dpotri_(char *, integer *, doublereal *, integer *, integer *), xlaenv_(integer *, integer *), derrvx_(char *, integer *);
doublereal result[6];
extern /* Subroutine */ int dposvx_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, char *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *);
/* 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.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DDRVPO tests the driver routines DPOSV 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) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */
/* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) */
/* S (workspace) DOUBLE PRECISION array, dimension (NMAX) */
/* WORK (workspace) DOUBLE PRECISION array, dimension */
/* (NMAX*max(3,NRHS)) */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--s;
--xact;
--x;
--bsav;
--b;
--asav;
--afac;
--a;
--nval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
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) {
derrvx_(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 DLATB4 and generate a test matrix */
/* with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)32, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &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__) {
a[ioff + i__] = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L50: */
}
}
} else {
izero = 0;
}
/* Save a copy of the matrix A in ASAV. */
dlacpy_(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 DPOSVX (FACT = 'N' reuses */
/* the condition number from the previous iteration */
/* with FACT = 'F'). */
dlacpy_(uplo, &n, &n, &asav[1], &lda, &afac[1], &
lda);
if (equil || iequed > 1) {
/* Compute row and column scale factors to */
/* equilibrate the matrix A. */
dpoequ_(&n, &afac[1], &lda, &s[1], &scond, &
amax, &info);
if (info == 0 && n > 0) {
if (iequed > 1) {
scond = 0.;
}
/* Equilibrate the matrix. */
dlaqsy_(uplo, &n, &afac[1], &lda, &s[1], &
scond, &amax, equed);
}
}
/* Save the condition number of the */
/* non-equilibrated system for use in DGET04. */
if (equil) {
roldc = rcondc;
}
/* Compute the 1-norm of A. */
anorm = dlansy_("1", uplo, &n, &afac[1], &lda, &
rwork[1]);
/* Factor the matrix A. */
dpotrf_(uplo, &n, &afac[1], &lda, &info);
/* Form the inverse of A. */
dlacpy_(uplo, &n, &n, &afac[1], &lda, &a[1], &lda);
dpotri_(uplo, &n, &a[1], &lda, &info);
/* Compute the 1-norm condition number of A. */
ainvnm = dlansy_("1", uplo, &n, &a[1], &lda, &
rwork[1]);
if (anorm <= 0. || ainvnm <= 0.) {
rcondc = 1.;
} else {
rcondc = 1. / anorm / ainvnm;
}
}
/* Restore the matrix A. */
dlacpy_(uplo, &n, &n, &asav[1], &lda, &a[1], &lda);
/* Form an exact solution and set the right hand side. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)32, (ftnlen)
6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku,
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
*(unsigned char *)xtype = 'C';
dlacpy_("Full", &n, nrhs, &b[1], &lda, &bsav[1], &lda);
if (nofact) {
/* --- Test DPOSV --- */
/* Compute the L*L' or U'*U factorization of the */
/* matrix and solve the system. */
dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
dlacpy_("Full", &n, nrhs, &b[1], &lda, &x[1], &
lda);
s_copy(srnamc_1.srnamt, "DPOSV ", (ftnlen)32, (
ftnlen)6);
dposv_(uplo, &n, nrhs, &afac[1], &lda, &x[1], &
lda, &info);
/* Check error code from DPOSV . */
if (info != izero) {
alaerh_(path, "DPOSV ", &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. */
dpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &
rwork[1], result);
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &b[1], &lda, &work[1], &
lda);
dpot02_(uplo, &n, nrhs, &a[1], &lda, &x[1], &lda,
&work[1], &lda, &rwork[1], &result[1]);
/* Check solution from generated exact solution. */
dget04_(&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, "DPOSV ", (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 DPOSVX --- */
if (! prefac) {
dlaset_(uplo, &n, &n, &c_b50, &c_b50, &afac[1], &
lda);
}
dlaset_("Full", &n, nrhs, &c_b50, &c_b50, &x[1], &lda);
if (iequed > 1 && n > 0) {
/* Equilibrate the matrix if FACT='F' and */
/* EQUED='Y'. */
dlaqsy_(uplo, &n, &a[1], &lda, &s[1], &scond, &
amax, equed);
}
/* Solve the system and compute the condition number */
/* and error bounds using DPOSVX. */
s_copy(srnamc_1.srnamt, "DPOSVX", (ftnlen)32, (ftnlen)
6);
dposvx_(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],
&iwork[1], &info);
/* Check the error code from DPOSVX. */
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, "DPOSVX", &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. */
dpot01_(uplo, &n, &a[1], &lda, &afac[1], &lda,
&rwork[(*nrhs << 1) + 1], result);
k1 = 1;
} else {
k1 = 2;
}
/* Compute residual of the computed solution. */
dlacpy_("Full", &n, nrhs, &bsav[1], &lda, &work[1]
, &lda);
dpot02_(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")) {
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&rcondc, &result[2]);
} else {
dget04_(&n, nrhs, &x[1], &lda, &xact[1], &lda,
&roldc, &result[2]);
}
/* Check the error bounds from iterative */
/* refinement. */
dpot05_(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 DPOSVX 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, "DPOSVX", (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, "DPOSVX", (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 DDRVPO */
} /* ddrvpo_ */
/* Subroutine */ int dsysvx_(char *fact, char *uplo, integer *n, integer *
nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf,
integer *ipiv, doublereal *b, integer *ldb, doublereal *x, integer *
ldx, doublereal *rcond, doublereal *ferr, doublereal *berr,
doublereal *work, integer *lwork, integer *iwork, 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 dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dsycon_(char *, integer *, doublereal *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *), dsyrfs_(char *, integer *, integer
*, doublereal *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, integer *),
dsytrf_(char *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */ int dsytrs_(char *, integer *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *);
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSYSVX uses the diagonal pivoting factorization to compute the */
/* solution to a real system of linear equations A * X = B, */
/* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
/* matrices. */
/* Error bounds on the solution and a condition estimate are also */
/* provided. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A. */
/* The form of the factorization is */
/* A = U * D * U**T, if UPLO = 'U', or */
/* A = L * D * L**T, if UPLO = 'L', */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, and D is symmetric and block diagonal with */
/* 1-by-1 and 2-by-2 diagonal blocks. */
/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
/* returns with INFO = i. Otherwise, the factored form of A is used */
/* to estimate the condition number of the matrix A. If the */
/* reciprocal of the condition number is less than machine precision, */
/* INFO = N+1 is returned as a warning, but the routine still goes on */
/* to solve for X and compute error bounds as described below. */
/* 3. The system of equations is solved for X using the factored form */
/* of A. */
/* 4. Iterative refinement is applied to improve the computed solution */
/* matrix and calculate error bounds and backward error estimates */
/* for it. */
/* Arguments */
/* ========= */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of A has been */
/* supplied on entry. */
/* = 'F': On entry, AF and IPIV contain the factored form of */
/* A. 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) DOUBLE PRECISION array, dimension (LDA,N) */
/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
/* upper triangular part of A contains the upper triangular part */
/* of the matrix A, and the strictly lower triangular part of A */
/* is not referenced. If UPLO = 'L', the leading N-by-N lower */
/* triangular part of A contains the lower triangular part of */
/* the matrix A, and the strictly upper triangular part of A is */
/* not referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) */
/* If FACT = 'F', then AF is an input argument and on entry */
/* contains the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L from the factorization */
/* A = U*D*U**T or A = L*D*L**T as computed by DSYTRF. */
/* If FACT = 'N', then AF is an output argument and on exit */
/* returns the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L from the factorization */
/* A = U*D*U**T or A = L*D*L**T. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input or output) INTEGER array, dimension (N) */
/* If FACT = 'F', then IPIV is an input argument and on entry */
/* contains details of the interchanges and the block structure */
/* of D, as determined by DSYTRF. */
/* 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 DSYTRF. */
/* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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,3*N), and for best */
/* performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where */
/* NB is the optimal blocksize for DSYTRF. */
/* 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. */
/* IWORK (workspace) INTEGER 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;
--iwork;
/* 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 * 3;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -18;
}
}
if (*info == 0) {
/* Computing MAX */
i__1 = 1, i__2 = *n * 3;
lwkopt = max(i__1,i__2);
if (nofact) {
nb = ilaenv_(&c__1, "DSYTRF", 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] = (doublereal) lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYSVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
if (nofact) {
/* Compute the factorization A = U*D*U' or A = L*D*L'. */
dlacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
dsytrf_(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 = dlansy_("I", uplo, n, &a[a_offset], lda, &work[1]);
/* Compute the reciprocal of the condition number of A. */
dsycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1],
&iwork[1], info);
/* Compute the solution vectors X. */
dlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
dsytrs_(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. */
dsyrfs_(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]
, &iwork[1], info);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < dlamch_("Epsilon")) {
*info = *n + 1;
}
work[1] = (doublereal) lwkopt;
return 0;
/* End of DSYSVX */
} /* dsysvx_ */
/* Subroutine */ int dsyevx_(char *jobz, char *range, char *uplo, integer *n,
doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer *
il, integer *iu, doublereal *abstol, integer *m, doublereal *w,
doublereal *z__, integer *ldz, doublereal *work, integer *lwork,
integer *iwork, integer *ifail, integer *info)
{
/* -- LAPACK driver routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
DSYEVX computes selected eigenvalues and, optionally, eigenvectors
of a real symmetric 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) DOUBLE PRECISION array, dimension (LDA, N)
On entry, 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. 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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,8*N).
For optimal efficiency, LWORK >= (NB+3)*N,
where NB is the max of the blocksize for DSYTRD and DORMTR
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.
IWORK (workspace) INTEGER array, dimension (5*N)
IFAIL (output) INTEGER array, dimension (N)
If JOBZ = 'V', then if INFO = 0, the first M elements of
IFAIL are zero. If INFO > 0, then IFAIL contains the
indices of the eigenvectors that failed to converge.
If JOBZ = 'N', then IFAIL is not referenced.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, then i eigenvectors failed to converge.
Their indices are stored in array IFAIL.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
/* 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 */
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 *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static logical lower, wantz;
static integer nb, jj;
extern doublereal dlamch_(char *);
static logical alleig, indeig;
static integer iscale, indibl;
static logical valeig;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
static doublereal safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal abstll, bignum;
static integer indtau, indisp;
extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *),
dsterf_(integer *, doublereal *, doublereal *, integer *);
static integer indiwo, indwkn;
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
*, doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
static integer indwrk;
extern /* Subroutine */ int dorgtr_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *), dsteqr_(char *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *),
dormtr_(char *, char *, char *, integer *, integer *, doublereal *
, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *);
static integer llwrkn, llwork, nsplit;
static doublereal smlnum;
extern /* Subroutine */ int dsytrd_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
static integer lwkopt;
static logical lquery;
static doublereal eps, vll, vuu, tmp1;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--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;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = *n << 3;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -17;
}
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1);
nb = max(i__1,i__2);
lwkopt = (nb + 3) * *n;
work[1] = (doublereal) lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
work[1] = 1.;
return 0;
}
if (*n == 1) {
work[1] = 7.;
if (alleig || indeig) {
*m = 1;
w[1] = a_ref(1, 1);
} else {
if (*vl < a_ref(1, 1) && *vu >= a_ref(1, 1)) {
*m = 1;
w[1] = a_ref(1, 1);
}
}
if (wantz) {
z___ref(1, 1) = 1.;
}
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;
vll = *vl;
vuu = *vu;
anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[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;
dscal_(&i__2, &sigma, &a_ref(j, j), &c__1);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dscal_(&j, &sigma, &a_ref(1, j), &c__1);
/* L20: */
}
}
if (*abstol > 0.) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */
indtau = 1;
inde = indtau + *n;
indd = inde + *n;
indwrk = indd + *n;
llwork = *lwork - indwrk + 1;
dsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[
indtau], &work[indwrk], &llwork, &iinfo);
lopt = (integer) (*n * 3 + work[indwrk]);
/* If all eigenvalues are desired and ABSTOL is less than or equal to
zero, then call DSTERF or DORGTR and SSTEQR. If this fails for
some eigenvalue, then try DSTEBZ. */
if ((alleig || indeig && *il == 1 && *iu == *n) && *abstol <= 0.) {
dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
indee = indwrk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsterf_(n, &w[1], &work[indee], info);
} else {
dlacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz);
dorgtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk]
, &llwork, &iinfo);
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
indwrk], 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, SSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwo = indisp + *n;
dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
indwrk], &iwork[indiwo], info);
if (wantz) {
dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
ifail[1], info);
/* Apply orthogonal matrix used in reduction to tridiagonal
form to eigenvectors returned by DSTEIN. */
indwkn = inde;
llwrkn = *lwork - indwkn + 1;
dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
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;
dswap_(n, &z___ref(1, i__), &c__1, &z___ref(1, j), &c__1);
if (*info != 0) {
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L60: */
}
}
/* Set WORK(1) to optimal workspace size. */
work[1] = (doublereal) lwkopt;
return 0;
/* End of DSYEVX */
} /* dsyevx_ */
/* Subroutine */ int dchksy_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
doublereal *afac, doublereal *ainv, doublereal *b, doublereal *x,
doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"=\002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer ioff, mode, imat, info;
static char path[3], dist[1];
static integer irhs, nrhs;
static char uplo[1], type__[1];
static integer nrun, i__, j, k;
extern /* Subroutine */ int alahd_(integer *, char *);
static integer n;
extern /* Subroutine */ int dget04_(integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
static integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
static doublereal rcond;
static integer nimat;
extern /* Subroutine */ int dpot02_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *), dpot03_(char *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *), dpot05_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *);
static doublereal anorm;
extern /* Subroutine */ int dsyt01_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *);
static integer iuplo, izero, i1, i2, nerrs, lwork;
static logical zerot;
static char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *);
static integer nb, in, kl;
extern /* Subroutine */ int alaerh_(char *, char *, integer *, integer *,
char *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer ku, nt;
static doublereal rcondc;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), alasum_(char *,
integer *, integer *, integer *, integer *);
static doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
static logical trfcon;
extern /* Subroutine */ int xlaenv_(integer *, integer *), dsycon_(char *,
integer *, doublereal *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, integer *),
derrsy_(char *, integer *), dsyrfs_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *), dsytrf_(char *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
static doublereal result[8];
extern /* Subroutine */ int dsytri_(char *, integer *, doublereal *,
integer *, integer *, doublereal *, integer *), dsytrs_(
char *, integer *, integer *, doublereal *, integer *, integer *,
doublereal *, integer *, integer *);
static integer lda, inb;
/* Fortran I/O blocks */
static cilist io___39 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
December 7, 1999
Purpose
=======
DCHKSY tests DSYTRF, -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) DOUBLE PRECISION array, dimension (NMAX*NMAX)
AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
where NSMAX is the largest entry in NSVAL.
X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
WORK (workspace) DOUBLE PRECISION array, dimension
(NMAX*max(3,NSMAX))
RWORK (workspace) DOUBLE PRECISION array, dimension
(max(NMAX,2*NSMAX))
IWORK (workspace) INTEGER array, dimension (2*NMAX)
NOUT (input) INTEGER
The unit number for output.
=====================================================================
Parameter adjustments */
--iwork;
--rwork;
--work;
--xact;
--x;
--b;
--ainv;
--afac;
--a;
--nsval;
--nbval;
--nval;
--dotype;
/* Function Body
Initialize constants and the random number seed. */
s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "SY", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
derrsy_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
/* Do for each value of N in NVAL */
i__1 = *nn;
for (in = 1; in <= i__1; ++in) {
n = nval[in];
lda = max(n,1);
*(unsigned char *)xtype = 'N';
nimat = 10;
if (n <= 0) {
nimat = 1;
}
izero = 0;
i__2 = nimat;
for (imat = 1; imat <= i__2; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L170;
}
/* Skip types 3, 4, 5, or 6 if the matrix size is too small. */
zerot = imat >= 3 && imat <= 6;
if (zerot && n < imat - 2) {
goto L170;
}
/* Do first for UPLO = 'U', then for UPLO = 'L' */
for (iuplo = 1; iuplo <= 2; ++iuplo) {
*(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
/* Set up parameters with DLATB4 and generate a test matrix
with DLATMS. */
dlatb4_(path, &imat, &n, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "DLATMS", (ftnlen)6, (ftnlen)6);
dlatms_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, uplo, &a[1], &lda, &work[1],
&info);
/* Check error code from DLATMS. */
if (info != 0) {
alaerh_(path, "DLATMS", &info, &c__0, uplo, &n, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L160;
}
/* For types 3-6, zero one or more rows and columns of
the matrix to test that INFO is returned correctly. */
if (zerot) {
if (imat == 3) {
izero = 1;
} else if (imat == 4) {
izero = n;
} else {
izero = n / 2 + 1;
}
if (imat < 6) {
/* Set row and column IZERO to zero. */
if (iuplo == 1) {
ioff = (izero - 1) * lda;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L20: */
}
ioff += izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L30: */
}
} else {
ioff = izero;
i__3 = izero - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
a[ioff] = 0.;
ioff += lda;
/* L40: */
}
ioff -= izero;
i__3 = n;
for (i__ = izero; i__ <= i__3; ++i__) {
a[ioff + i__] = 0.;
/* L50: */
}
}
} else {
ioff = 0;
if (iuplo == 1) {
/* Set the first IZERO rows and columns to zero. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i2 = min(j,izero);
i__4 = i2;
for (i__ = 1; i__ <= i__4; ++i__) {
a[ioff + i__] = 0.;
/* L60: */
}
ioff += lda;
/* L70: */
}
} else {
/* Set the last IZERO rows and columns to zero. */
i__3 = n;
for (j = 1; j <= i__3; ++j) {
i1 = max(j,izero);
i__4 = n;
for (i__ = i1; i__ <= i__4; ++i__) {
a[ioff + i__] = 0.;
/* L80: */
}
ioff += lda;
/* L90: */
}
}
}
} else {
izero = 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*D*L' or U*D*U' factorization of the
matrix. */
dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
lwork = max(2,nb) * lda;
s_copy(srnamc_1.srnamt, "DSYTRF", (ftnlen)6, (ftnlen)6);
dsytrf_(uplo, &n, &afac[1], &lda, &iwork[1], &ainv[1], &
lwork, &info);
/* Adjust the expected value of INFO to account for
pivoting. */
k = izero;
if (k > 0) {
L100:
if (iwork[k] < 0) {
if (iwork[k] != -k) {
k = -iwork[k];
goto L100;
}
} else if (iwork[k] != k) {
k = iwork[k];
goto L100;
}
}
/* Check error code from DSYTRF. */
if (info != k) {
alaerh_(path, "DSYTRF", &info, &k, uplo, &n, &n, &
c_n1, &c_n1, &nb, &imat, &nfail, &nerrs, nout);
}
if (info != 0) {
trfcon = TRUE_;
} else {
trfcon = FALSE_;
}
/* + TEST 1
Reconstruct matrix from factors and compute residual. */
dsyt01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &iwork[1],
&ainv[1], &lda, &rwork[1], result);
nt = 1;
/* + TEST 2
Form the inverse and compute the residual. */
if (inb == 1 && ! trfcon) {
dlacpy_(uplo, &n, &n, &afac[1], &lda, &ainv[1], &lda);
s_copy(srnamc_1.srnamt, "DSYTRI", (ftnlen)6, (ftnlen)
6);
dsytri_(uplo, &n, &ainv[1], &lda, &iwork[1], &work[1],
&info);
/* Check error code from DSYTRI. */
if (info != 0) {
alaerh_(path, "DSYTRI", &info, &c_n1, uplo, &n, &
n, &c_n1, &c_n1, &c_n1, &imat, &nfail, &
nerrs, nout);
}
dpot03_(uplo, &n, &a[1], &lda, &ainv[1], &lda, &work[
1], &lda, &rwork[1], &rcondc, &result[1]);
nt = 2;
}
/* Print information about the tests that did not pass
the threshold. */
i__4 = nt;
for (k = 1; k <= i__4; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L110: */
}
nrun += nt;
/* Skip the other tests if this is not the first block
size. */
if (inb > 1) {
goto L150;
}
/* Do only the condition estimate if INFO is not 0. */
if (trfcon) {
rcondc = 0.;
goto L140;
}
i__4 = *nns;
for (irhs = 1; irhs <= i__4; ++irhs) {
nrhs = nsval[irhs];
/* + TEST 3
Solve and compute residual for A * X = B. */
s_copy(srnamc_1.srnamt, "DLARHS", (ftnlen)6, (ftnlen)
6);
dlarhs_(path, xtype, uplo, " ", &n, &n, &kl, &ku, &
nrhs, &a[1], &lda, &xact[1], &lda, &b[1], &
lda, iseed, &info);
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &x[1], &lda);
s_copy(srnamc_1.srnamt, "DSYTRS", (ftnlen)6, (ftnlen)
6);
dsytrs_(uplo, &n, &nrhs, &afac[1], &lda, &iwork[1], &
x[1], &lda, &info);
/* Check error code from DSYTRS. */
if (info != 0) {
alaerh_(path, "DSYTRS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
dlacpy_("Full", &n, &nrhs, &b[1], &lda, &work[1], &
lda);
dpot02_(uplo, &n, &nrhs, &a[1], &lda, &x[1], &lda, &
work[1], &lda, &rwork[1], &result[2]);
/* + TEST 4
Check solution from generated exact solution. */
dget04_(&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, "DSYRFS", (ftnlen)6, (ftnlen)
6);
dsyrfs_(uplo, &n, &nrhs, &a[1], &lda, &afac[1], &lda,
&iwork[1], &b[1], &lda, &x[1], &lda, &rwork[1]
, &rwork[nrhs + 1], &work[1], &iwork[n + 1], &
info);
/* Check error code from DSYRFS. */
if (info != 0) {
alaerh_(path, "DSYRFS", &info, &c__0, uplo, &n, &
n, &c_n1, &c_n1, &nrhs, &imat, &nfail, &
nerrs, nout);
}
dget04_(&n, &nrhs, &x[1], &lda, &xact[1], &lda, &
rcondc, &result[4]);
dpot05_(uplo, &n, &nrhs, &a[1], &lda, &b[1], &lda, &x[
1], &lda, &xact[1], &lda, &rwork[1], &rwork[
nrhs + 1], &result[5]);
/* Print information about the tests that did not pass
the threshold. */
for (k = 3; k <= 7; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nrhs, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
++nfail;
}
/* L120: */
}
nrun += 5;
/* L130: */
}
/* + TEST 8
Get an estimate of RCOND = 1/CNDNUM. */
L140:
anorm = dlansy_("1", uplo, &n, &a[1], &lda, &rwork[1]);
s_copy(srnamc_1.srnamt, "DSYCON", (ftnlen)6, (ftnlen)6);
dsycon_(uplo, &n, &afac[1], &lda, &iwork[1], &anorm, &
rcond, &work[1], &iwork[n + 1], &info);
/* Check error code from DSYCON. */
if (info != 0) {
alaerh_(path, "DSYCON", &info, &c__0, uplo, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs,
nout);
}
result[7] = dget06_(&rcond, &rcondc);
/* Print information about the tests that did not pass
the threshold. */
if (result[7] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___44.ciunit = *nout;
s_wsfe(&io___44);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[7], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
++nrun;
L150:
;
}
L160:
;
}
L170:
;
}
/* L180: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of DCHKSY */
} /* dchksy_ */
/* Subroutine */ int dstt22_(integer *n, integer *m, integer *kband,
doublereal *ad, doublereal *ae, doublereal *sd, doublereal *se,
doublereal *u, integer *ldu, doublereal *work, integer *ldwork,
doublereal *result)
{
/* System generated locals */
integer u_dim1, u_offset, work_dim1, work_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3, d__4, d__5;
/* Local variables */
integer i__, j, k;
doublereal ulp, aukj, unfl;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
doublereal anorm, wnorm;
extern doublereal dlamch_(char *), dlange_(char *, integer *,
integer *, doublereal *, integer *, doublereal *),
dlansy_(char *, char *, integer *, doublereal *, integer *,
doublereal *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSTT22 checks a set of M eigenvalues and eigenvectors, */
/* A U = U S */
/* where A is symmetric tridiagonal, the columns of U are orthogonal, */
/* and S is diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1). */
/* Two tests are performed: */
/* RESULT(1) = | U' A U - S | / ( |A| m ulp ) */
/* RESULT(2) = | I - U'U | / ( m ulp ) */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The size of the matrix. If it is zero, DSTT22 does nothing. */
/* It must be at least zero. */
/* M (input) INTEGER */
/* The number of eigenpairs to check. If it is zero, DSTT22 */
/* does nothing. It must be at least zero. */
/* KBAND (input) INTEGER */
/* The bandwidth of the matrix S. It may only be zero or one. */
/* If zero, then S is diagonal, and SE is not referenced. If */
/* one, then S is symmetric tri-diagonal. */
/* AD (input) DOUBLE PRECISION array, dimension (N) */
/* The diagonal of the original (unfactored) matrix A. A is */
/* assumed to be symmetric tridiagonal. */
/* AE (input) DOUBLE PRECISION array, dimension (N) */
/* The off-diagonal of the original (unfactored) matrix A. A */
/* is assumed to be symmetric tridiagonal. AE(1) is ignored, */
/* AE(2) is the (1,2) and (2,1) element, etc. */
/* SD (input) DOUBLE PRECISION array, dimension (N) */
/* The diagonal of the (symmetric tri-) diagonal matrix S. */
/* SE (input) DOUBLE PRECISION array, dimension (N) */
/* The off-diagonal of the (symmetric tri-) diagonal matrix S. */
/* Not referenced if KBSND=0. If KBAND=1, then AE(1) is */
/* ignored, SE(2) is the (1,2) and (2,1) element, etc. */
/* U (input) DOUBLE PRECISION array, dimension (LDU, N) */
/* The orthogonal matrix in the decomposition. */
/* LDU (input) INTEGER */
/* The leading dimension of U. LDU must be at least N. */
/* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK, M+1) */
/* LDWORK (input) INTEGER */
/* The leading dimension of WORK. LDWORK must be at least */
/* max(1,M). */
/* 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ad;
--ae;
--sd;
--se;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1;
work -= work_offset;
--result;
/* Function Body */
result[1] = 0.;
result[2] = 0.;
if (*n <= 0 || *m <= 0) {
return 0;
}
unfl = dlamch_("Safe minimum");
ulp = dlamch_("Epsilon");
/* Do Test 1 */
/* Compute the 1-norm of A. */
if (*n > 1) {
anorm = abs(ad[1]) + abs(ae[1]);
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
/* Computing MAX */
d__4 = anorm, d__5 = (d__1 = ad[j], abs(d__1)) + (d__2 = ae[j],
abs(d__2)) + (d__3 = ae[j - 1], abs(d__3));
anorm = max(d__4,d__5);
/* L10: */
}
/* Computing MAX */
d__3 = anorm, d__4 = (d__1 = ad[*n], abs(d__1)) + (d__2 = ae[*n - 1],
abs(d__2));
anorm = max(d__3,d__4);
} else {
anorm = abs(ad[1]);
}
anorm = max(anorm,unfl);
/* Norm of U'AU - S */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *m;
for (j = 1; j <= i__2; ++j) {
work[i__ + j * work_dim1] = 0.;
i__3 = *n;
for (k = 1; k <= i__3; ++k) {
aukj = ad[k] * u[k + j * u_dim1];
if (k != *n) {
aukj += ae[k] * u[k + 1 + j * u_dim1];
}
if (k != 1) {
aukj += ae[k - 1] * u[k - 1 + j * u_dim1];
}
work[i__ + j * work_dim1] += u[k + i__ * u_dim1] * aukj;
/* L20: */
}
/* L30: */
}
work[i__ + i__ * work_dim1] -= sd[i__];
if (*kband == 1) {
if (i__ != 1) {
work[i__ + (i__ - 1) * work_dim1] -= se[i__ - 1];
}
if (i__ != *n) {
work[i__ + (i__ + 1) * work_dim1] -= se[i__];
}
}
/* L40: */
}
wnorm = dlansy_("1", "L", m, &work[work_offset], m, &work[(*m + 1) *
work_dim1 + 1]);
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*m * ulp);
} else {
if (anorm < 1.) {
/* Computing MIN */
d__1 = wnorm, d__2 = *m * anorm;
result[1] = min(d__1,d__2) / anorm / (*m * ulp);
} else {
/* Computing MIN */
d__1 = wnorm / anorm, d__2 = (doublereal) (*m);
result[1] = min(d__1,d__2) / (*m * ulp);
}
}
/* Do Test 2 */
/* Compute U'U - I */
dgemm_("T", "N", m, m, n, &c_b12, &u[u_offset], ldu, &u[u_offset], ldu, &
c_b13, &work[work_offset], m);
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
work[j + j * work_dim1] += -1.;
/* L50: */
}
/* Computing MIN */
d__1 = (doublereal) (*m), d__2 = dlange_("1", m, m, &work[work_offset], m,
&work[(*m + 1) * work_dim1 + 1]);
result[2] = min(d__1,d__2) / (*m * ulp);
return 0;
/* End of DSTT22 */
} /* dstt22_ */
/* Subroutine */ HYPRE_Int dsyev_(char *jobz, char *uplo, integer *n, doublereal *a,
integer *lda, doublereal *w, doublereal *work, integer *lwork,
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
=======
DSYEV computes all eigenvalues and, optionally, eigenvectors of a
real symmetric 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) DOUBLE PRECISION array, dimension (LDA, N)
On entry, 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. 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) DOUBLE PRECISION 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,3*N-1).
For optimal efficiency, LWORK >= (NB+2)*N,
where NB is the blocksize for DSYTRD 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.
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 */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__0 = 0;
static doublereal c_b17 = 1.;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1;
/* 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 */ HYPRE_Int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
static logical lower, wantz;
static integer nb;
extern doublereal dlamch_(char *);
static integer iscale;
extern /* Subroutine */ HYPRE_Int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
static doublereal safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ HYPRE_Int xerbla_(char *, integer *);
static doublereal bignum;
static integer indtau;
extern /* Subroutine */ HYPRE_Int dsterf_(integer *, doublereal *, doublereal *,
integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
static integer indwrk;
extern /* Subroutine */ HYPRE_Int dorgtr_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *), dsteqr_(char *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *),
dsytrd_(char *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *);
static integer llwork;
static doublereal smlnum;
static integer lwkopt;
static logical lquery;
static doublereal eps;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--w;
--work;
/* 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;
} else { /* if(complicated condition) */
/* Computing MAX */
i__1 = 1, i__2 = *n * 3 - 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -8;
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
/* Computing MAX */
i__1 = 1, i__2 = (nb + 2) * *n;
lwkopt = max(i__1,i__2);
work[1] = (doublereal) lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYEV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
work[1] = 1.;
return 0;
}
if (*n == 1) {
w[1] = a_ref(1, 1);
work[1] = 3.;
if (wantz) {
a_ref(1, 1) = 1.;
}
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 = dlansy_("M", uplo, n, &a[a_offset], lda, &work[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) {
dlascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda,
info);
}
/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */
inde = 1;
indtau = inde + *n;
indwrk = indtau + *n;
llwork = *lwork - indwrk + 1;
dsytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], &
work[indwrk], &llwork, &iinfo);
/***lopt = (integer) ((*n << 1) + work[indwrk]);***/
/* For eigenvalues only, call DSTERF. For eigenvectors, first call
DORGTR to generate the orthogonal matrix, then call DSTEQR. */
if (! wantz) {
dsterf_(n, &w[1], &work[inde], info);
} else {
dorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], &
llwork, &iinfo);
dsteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau],
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 workspace size. */
work[1] = (doublereal) lwkopt;
return 0;
/* End of DSYEV */
} /* dsyev_ */
/* Subroutine */
int dsposv_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * x, integer *ldx, doublereal *work, real *swork, integer *iter, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset, x_dim1, x_offset, i__1;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__;
doublereal cte, eps, anrm;
integer ptsa;
doublereal rnrm, xnrm;
integer ptsx;
extern logical lsame_(char *, char *);
integer iiter;
extern /* Subroutine */
int daxpy_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *), dsymm_(char *, char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), dlag2s_(integer *, integer *, doublereal *, integer *, real *, integer *, integer *), slag2d_(integer *, integer *, real *, integer *, doublereal *, integer *, integer *), dlat2s_(char *, integer *, doublereal *, integer *, real *, integer *, integer *);
extern doublereal dlamch_(char *);
extern integer idamax_(integer *, doublereal *, integer *);
extern /* Subroutine */
int dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *, integer *, doublereal *);
extern /* Subroutine */
int dpotrf_(char *, integer *, doublereal *, integer *, integer *), dpotrs_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *, integer *), spotrf_(char *, integer *, real *, integer *, integer *), spotrs_(char *, integer *, integer *, real *, integer *, real *, 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 Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
work_dim1 = *n;
work_offset = 1 + work_dim1;
work -= work_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--swork;
/* Function Body */
*info = 0;
*iter = 0;
/* Test the input parameters. */
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*nrhs < 0)
{
*info = -3;
}
else if (*lda < max(1,*n))
{
*info = -5;
}
else if (*ldb < max(1,*n))
{
*info = -7;
}
else if (*ldx < max(1,*n))
{
*info = -9;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("DSPOSV", &i__1);
return 0;
}
/* Quick return if (N.EQ.0). */
if (*n == 0)
{
return 0;
}
/* Skip single precision iterative refinement if a priori slower */
/* than double precision factorization. */
if (FALSE_)
{
*iter = -1;
goto L40;
}
/* Compute some constants. */
anrm = dlansy_("I", uplo, n, &a[a_offset], lda, &work[work_offset]);
eps = dlamch_("Epsilon");
cte = anrm * eps * sqrt((doublereal) (*n)) * 1.;
/* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. */
ptsa = 1;
ptsx = ptsa + *n * *n;
/* Convert B from double precision to single precision and store the */
/* result in SX. */
dlag2s_(n, nrhs, &b[b_offset], ldb, &swork[ptsx], n, info);
if (*info != 0)
{
*iter = -2;
goto L40;
}
/* Convert A from double precision to single precision and store the */
/* result in SA. */
dlat2s_(uplo, n, &a[a_offset], lda, &swork[ptsa], n, info);
if (*info != 0)
{
*iter = -2;
goto L40;
}
/* Compute the Cholesky factorization of SA. */
spotrf_(uplo, n, &swork[ptsa], n, info);
if (*info != 0)
{
*iter = -3;
goto L40;
}
/* Solve the system SA*SX = SB. */
spotrs_(uplo, n, nrhs, &swork[ptsa], n, &swork[ptsx], n, info);
/* Convert SX back to double precision */
slag2d_(n, nrhs, &swork[ptsx], n, &x[x_offset], ldx, info);
/* Compute R = B - AX (R is WORK). */
dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n);
dsymm_("Left", uplo, n, nrhs, &c_b10, &a[a_offset], lda, &x[x_offset], ldx, &c_b11, &work[work_offset], n);
/* Check whether the NRHS normwise backward errors satisfy the */
/* stopping criterion. If yes, set ITER=0 and return. */
i__1 = *nrhs;
for (i__ = 1;
i__ <= i__1;
++i__)
{
xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1], f2c_abs(d__1));
rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ * work_dim1], f2c_abs(d__1));
if (rnrm > xnrm * cte)
{
goto L10;
}
}
/* If we are here, the NRHS normwise backward errors satisfy the */
/* stopping criterion. We are good to exit. */
*iter = 0;
return 0;
L10:
for (iiter = 1;
iiter <= 30;
++iiter)
{
/* Convert R (in WORK) from double precision to single precision */
/* and store the result in SX. */
dlag2s_(n, nrhs, &work[work_offset], n, &swork[ptsx], n, info);
if (*info != 0)
{
*iter = -2;
goto L40;
}
/* Solve the system SA*SX = SR. */
spotrs_(uplo, n, nrhs, &swork[ptsa], n, &swork[ptsx], n, info);
/* Convert SX back to double precision and update the current */
/* iterate. */
slag2d_(n, nrhs, &swork[ptsx], n, &work[work_offset], n, info);
i__1 = *nrhs;
for (i__ = 1;
i__ <= i__1;
++i__)
{
daxpy_(n, &c_b11, &work[i__ * work_dim1 + 1], &c__1, &x[i__ * x_dim1 + 1], &c__1);
}
/* Compute R = B - AX (R is WORK). */
dlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n);
dsymm_("L", uplo, n, nrhs, &c_b10, &a[a_offset], lda, &x[x_offset], ldx, &c_b11, &work[work_offset], n);
/* Check whether the NRHS normwise backward errors satisfy the */
/* stopping criterion. If yes, set ITER=IITER>0 and return. */
i__1 = *nrhs;
for (i__ = 1;
i__ <= i__1;
++i__)
{
xnrm = (d__1 = x[idamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1], f2c_abs(d__1));
rnrm = (d__1 = work[idamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ * work_dim1], f2c_abs(d__1));
if (rnrm > xnrm * cte)
{
goto L20;
}
}
/* If we are here, the NRHS normwise backward errors satisfy the */
/* stopping criterion, we are good to exit. */
*iter = iiter;
return 0;
L20: /* L30: */
;
}
/* If we are at this place of the code, this is because we have */
/* performed ITER=ITERMAX iterations and never satisified the */
/* stopping criterion, set up the ITER flag accordingly and follow */
/* up on double precision routine. */
*iter = -31;
L40: /* Single-precision iterative refinement failed to converge to a */
/* satisfactory solution, so we resort to double precision. */
dpotrf_(uplo, n, &a[a_offset], lda, info);
if (*info != 0)
{
return 0;
}
dlacpy_("All", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
dpotrs_(uplo, n, nrhs, &a[a_offset], lda, &x[x_offset], ldx, info);
return 0;
/* End of DSPOSV. */
}
